Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
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 cooling their heels in the Monastery: (2)
As of 2014-07-10 05:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    When choosing user names for websites, I prefer to use:








    Results (199 votes), past polls