Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

broquaint's scratchpad

by broquaint (Abbot)
on Jun 01, 2004 at 20:56 UTC ( #358595=scratchpad: print w/ replies, xml ) Need Help??

Dynamically change @ISA per object. Also note this code is *really* basic and will almost certainly break on anything complicated (for me and my wandering mind)
{ package root; sub new { bless ['yo'], shift } package left; @ISA = 'root'; sub branch { print 'yo, I be in: ', __PACKAGE__,$/ } package right; @ISA = 'root'; sub branch { print 'yo, I be in: ', __PACKAGE__,$/ } package righterer; @ISA = 'right'; sub branch { print 'calling big bro ...',$/; shift->SUPER::branch } } sub Class::SetISA::munge_isa { my($self => $obj, @pkgs) = @_; my $objclass = ref $obj; my $newclass = 'Class::SetISA::' . join '::', $objclass, @pkgs; unless(defined %{"$newclass\::"}) { *{"$newclass\::$_"} = *{"$objclass\::$_"} for keys %{"$objclass\::"}; } @{"$newclass\::ISA"} = @pkgs; bless $obj, $newclass; } my $obj = righterer->new; $obj->branch; print "obj is $obj\n"; ## be sure to include any existing classes you want to keep in @ISA Class::SetISA->munge_isa($obj, 'left'); $obj->branch; print "obj is $obj\n"; __output__ calling big bro ... yo, I be in: right obj is righterer=ARRAY(0x9486304) calling big bro ... yo, I be in: left obj is Class::SetISA::righterer::left=ARRAY(0x9486304)

private subroutines via MY and AUTOLOAD munging (for adrianh)
{ package MY; use Scalar::Util 'blessed'; sub AUTOLOAD { my($meth) = $AUTOLOAD =~ /::(\w+)$/; print "autoloading: $AUTOLOAD\n"; *{"MY::$meth"} = sub { goto &{(blessed($_[0])."::MY")->can($meth)} + }; goto &{"MY::$meth"}; } } use strict; { package foo; sub foo::MY::that { print "that(): I'm in ", __PACKAGE__, $/; } sub this { print "this(): I'm in ", __PACKAGE__, $/; $_[0]->MY::that; } } { package bar; sub bar::MY::that { print "that(): I'm in ", __PACKAGE__, $/; } sub this { print "this(): I'm in ", __PACKAGE__, $/; $_[0]->MY::that; } } my $foo = bless [], 'foo'; $foo->this; my $bar = bless [], 'bar'; $bar->this; __output__ this(): I'm in foo autoloading: MY::that that(): I'm in foo this(): I'm in bar that(): I'm in bar

global subroutine wrapping (for bart), and its more to date version can be found at http://www.broquaint.com/wrap_subs.pl.txt
use strict; use warnings; BEGIN { *CORE::GLOBAL::caller = sub { my $sub = (CORE::caller(1))[3]; my $depth = ($_[0] || 0) + (UNIVERSAL::isa(\&$sub, 'Hook::PackageWrap') ? 2 : 1); return CORE::caller($depth); }; } { package Hook::PackageWrap; use overload (); use Carp 'croak'; sub _init { my($self, %args) = @_; $args{handler} = \&trace unless exists $args{handler} and UNIVERSAL::isa($args{handler}, 'CODE'); $args{pre} = \&_pre unless exists $args{pre} and UNIVERSAL::isa($args{pre}, 'CODE'); $args{post} = \&_post unless exists $args{post} and UNIVERSAL::isa($args{post}, 'CODE'); $args{skip} = [] unless defined $args{skip} and UNIVERSAL::isa($args{skip}, 'ARRAY'); return bless { handler => $args{handler}, pre => $args{pre}, post => $args{post}, skip => join('|', __PACKAGE__, @{$args{skip}}), }, $self; } sub wrap_subs { my($self, %args) = @_; croak("No package was provided") unless exists $args{package}; $self->_init(%args)->_wrap($args{package}); } sub _wrap { my($self, $t) = @_; for(keys %$t) { ## avoid potential minefield of magical/recursive looking subs ## almost certainly needs to be tightened up next if / __ANON__ | ^(?:strict|warnings|overload|attributes|diagnostics|main +):: | ^[A-Z]+$ | ^(?:isa|can|VERSION|caller)$ /x or ( $self->{skip} and $t->{$_} =~ /^\*?(?:$self->{skip} +)::/ ); $self->_wrap(\%{$t->{$_}}), next if /[^:]::$/; my $c; next unless ref(\$t->{$_}) eq 'GLOB' && defined( $c = *{$t->{$_}}{CODE} ); next if *{$t->{$_}}{CODE} eq $self->{handler}; my($n,$pre,$post) = (substr($t->{$_}, 1), @$self{qw/pre post/}); no warnings; $t->{$_} = bless sub { unshift @_, { name => $n, code => $c, pre => $pre, post => $post, }; goto &{ $self->{handler} }; }, 'Hook::PackageWrap'; } } sub _pre { my $info = shift; ## avoid the infinite recursion of overloaded vars my @args = map { ref $_ && overload::Overloaded($_) ? overload::StrVal($_) : $_ } @_; print "## pre $info->{name}",(@args ? ", called with @args\n" : "\ +n"); } sub _post { my $info = shift; ## avoid the infinite recursion of overloaded vars my @retout = map { ref $_ && overload::Overloaded($_) ? overload::StrVal($_) : $_ } @_; print "## post $info->{name} returning: ",@retout,"\n"; } sub trace { my $info = shift; no warnings 'uninitialized'; my $pre = $info->{pre}; my $post = $info->{post}; &$pre($info => @_); ## might mess with the likes of Want my(@ret,$ret); if(wantarray) { @ret = $info->{code}->( @_ ) } elsif(defined wantarray) { $ret = $info->{code}->( @_ ) } else { $info->{code}->( @_ ) } &$post($info => wantarray ? @ret : defined wantarray ? $ret : ('void context') ); return wantarray ? @ret : defined wantarray ? $ret : (); } } sub foo { print "calling bar\n"; bar(qw/ some args /); print "done with bar\n"; my $o = wraptest->new; $o->test; print $o->list,$/; print $o->list.$/; $o->cani(); } sub bar { print "I was called by - ", (caller 1)[3],$/; print "I'm bar() and I got: @_\n"; } =head2 wrap_subs B<Arguments> A key =E<gt> value list e.g Hook::PackageWrap->wrap_subs(package => \%Your::Class::); =over 4 =item package A reference to the package to be wrapepd =item handler A subroutine that will be called for every sub wrapped =item pre A sub that will be called before the wrapped sub is called if C<handle +r> hasn't been provided. It is passed the C<$info> hash as the first argument an +d the rest of C<@_> will contain the wrapped sub's arguments. =item pre A sub that will be called after the wrapped sub is called if C<handler +> hasn't been provided. It is passed the C<$info> hash as the first argument an +d the rest of will contain the wrapped sub's return values, or 'void contex +t' if it was called in a void context. =item skip An array of package names not to wrap. =back =cut Hook::PackageWrap->wrap_subs( package => \%main::, pre => sub { print "-- $_[0]->{name}( @_[1 .. $#_] )\n" }, ); foo(); print "\n"; eval q<sub cheat { print "but *I* was called by: ",(caller 1)[3],$/ }s +ub ha { cheat() }>; ha(); { package wrap_isatest; sub meh { print "yep I'm here: $_[0]\n" } package wraptest; BEGIN { our @ISA = 'wrap_isatest' } sub new { bless [], shift } sub test { print "i'm a test $_[0]\n" } sub list { return qw/ a list of values / } sub cani { $_[0]->SUPER::meh } } __output__ -- main::foo( ) calling bar -- main::bar( some args ) I was called by - main::foo I'm bar() and I got: some args ## post main::bar returning: void context done with bar -- wraptest::new( wraptest ) ## post wraptest::new returning: wraptest=ARRAY(0x8108c4c) -- wraptest::test( wraptest=ARRAY(0x8108c4c) ) i'm a test wraptest=ARRAY(0x8108c4c) ## post wraptest::test returning: void context -- wraptest::list( wraptest=ARRAY(0x8108c4c) ) ## post wraptest::list returning: alistofvalues alistofvalues -- wraptest::list( wraptest=ARRAY(0x8108c4c) ) ## post wraptest::list returning: values values -- wraptest::cani( wraptest=ARRAY(0x8108c4c) ) -- wrap_isatest::meh( wraptest=ARRAY(0x8108c4c) ) yep I'm here: wraptest=ARRAY(0x8108c4c) ## post wrap_isatest::meh returning: void context ## post wraptest::cani returning: void context ## post main::foo returning: void context but *I* was called by: main::ha

split an array into 2 given a delimiter (for Thathom)
@orig = qw/ foo bar xx baz quux /; push @{/xx/ .. 0 ? /xx/ ? next : \@a2 : \@a1}, $_ for @orig; print "a1: @a1\n"; print "a2: @a2\n"; __output__ a1: foo bar a2: baz quux

call END blocks when execing (the useful code from diotalevi)
use B; BEGIN { *CORE::GLOBAL::exec = sub { $_->object_2svref->() for B::end_av->ARRAY; CORE::exec @_; }; } END { print "last one\n" } END { print "I'm ending this right now!\n" } exec qw/ echo these arguments here /; __output__ I'm ending this right now! last one these arguments here

$dhcp140.dan(0.1485, "perl") cat MyObj.pm package MyObj; my $obj = bless {} => __PACKAGE__; sub test { my($self => @args) = @_; print "I am $self", ( @args ? ", with '@args'" : () ), $/; } ## will allow multiple requires(), but is nah-stee delete $INC{'MyObj.pm'}; $obj; $dhcp140.dan(0.1486, "perl") perl -e 'my $o = require MyObj; $o->test( +"a list of args")' I am MyObj=HASH(0x80fba1c), with 'a list of args' $dhcp140.dan(0.1490, "perl") perl -MMyObj -MMyObj -e 'my $o = require +MyObj; $o->test("a list of args")' I am MyObj=HASH(0x80fbc38), with 'a list of args'

correct quoting for Win32 system commands (for demerphq)
#include <stdio.h> #include <string.h> #include <stdlib.h> #define IS_SPECIAL(c) (c == ' ' ? 1 : \ c == '&' ? 1 : \ c == '<' ? 1 : \ c == '|' ? 1 : \ c == '"' ? 1 : 0) static char * escape_quoting(const char* arg) { char dq_on, seen_bs; char *ptr, *ret, *ret_ptr; /* New(1310, ret, strlen(ptr) + 1, char); */ ret = (char*) malloc(strlen(ptr) + 1); ret_ptr = ret; for(dq_on = 0, seen_bs = 0, ptr = (char*)arg; *ptr != '\0'; ptr++) + { if('\\' == *ptr && 0 == seen_bs) { seen_bs = 1; continue; } if('\\' == *ptr && 1 == seen_bs) seen_bs = 0; if('"' == *ptr && 0 == seen_bs && 0 == dq_on) { dq_on = 1; continue; } if(1 == dq_on && IS_SPECIAL(*ptr)) { if(*(ptr + 1) != '\0' && '"' == *(ptr + 1)) *ret_ptr++ = *ptr++; dq_on = 0; continue; } *ret_ptr++ = *ptr; dq_on = seen_bs = 0; } *ret_ptr = '\0'; return ret; } int main(void) { char arg1[] = "print\"\"\"foo\" \"bar\"\"\""; char arg2[] = "print\"\"\"\"foo bar\"\"\"\""; char arg3[] = "\"print\\\"foo bar\\\""; char arg4[] = "\"print\\\"foo bar\\\"\""; char arg5[] = "print\\\"foo\" \"bar\\\""; char arg6[] = "print'\"\"\"\"\"\"\"\"'"; char arg7[] = "\"print \\\"\\\\\\\"\\\\\\\"\\\""; char *quoted; quoted = escape_quoting(arg1); printf("%s\n", quoted); free(quoted); quoted = escape_quoting(arg2); printf("%s\n", quoted); free(quoted); quoted = escape_quoting(arg3); printf("%s\n", quoted); free(quoted); quoted = escape_quoting(arg4); + printf("%s\n", quoted); free(quoted); quoted = escape_quoting(arg5); printf("%s\n", quoted); free(quoted); quoted = escape_quoting(arg6); printf("%s\n", quoted); free(quoted); quoted = escape_quoting(arg7); printf("%s\n", quoted); free(quoted); return 0; }

As linked from Re: Re: explain obfu code
>+++++++++[<++++++++++> -]<+>>+++++++++[<++++ ++++++>-]<+++>>++++ ++[<++++++++++>-] <>>++++++[<++++ ++++++>-]<++> >++++[<++++ ++++++>-] <+++>>+ +++[< +++ + +++ +++>- ]<++++> >++++[<++ ++++++++>-] <+++++>>++++[ <++++++++++>-]< ++++++>>+[->,+[>+ [<-<+>>-]]<[<<<<<<. >>>>>>-]<<<.<<<<.>>>> >>><]>>>>++[<+++++>-]<.

Re: Re: Re: Find file name
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (10)
As of 2014-09-16 22:32 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (51 votes), past polls