{ 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) #### { 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 #### 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 A key =E 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 hasn't been provided. It is passed the C<$info> hash as the first argument and 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 hasn't been provided. It is passed the C<$info> hash as the first argument and the rest of will contain the wrapped sub's return values, or 'void context' 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; 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 #### @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 #### 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' #### #include #include #include #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; } #### >+++++++++[<++++++++++> -]<+>>+++++++++[<++++ ++++++>-]<+++>>++++ ++[<++++++++++>-] <>>++++++[<++++ ++++++>-]<++> >++++[<++++ ++++++>-] <+++>>+ +++[< +++ + +++ +++>- ]<++++> >++++[<++ ++++++++>-] <+++++>>++++[ <++++++++++>-]< ++++++>>+[->,+[>+ [<-<+>>-]]<[<<<<<<. >>>>>>-]<<<.<<<<.>>>> >>><]>>>>++[<+++++>-]<. #### # done - $|++ # done - keys %{ {map {$_ => 1} @list} }; # done - ${\$obj->method}}, @{[sort @list]} # done - do { local $/; }; -- jeffa ACTION for grep CLAUSE, LIST; select ( (select (FH), $|=1)[0] ); !!grep CLAUSE, LIST; s/search/replace/ for LIST; (my $var = $str) =~ s/search/replace/; ## maybe too specific my @placeholders = join ',' => map '?' => @vals; #### int main(void) { char *a,b[]={0x1,0x9,0x12,0x12,0xc,0x16,0x0}; for(a=b;*a;a++) printf("%c",(*a)["pH3@r //.e foR 1 3l337\n"]); return(0); }