{
  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)
[download]

{
  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
[download]

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
[download]

@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
[download]

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
[download]

$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'
[download]

#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;
}
[download]

>+++++++++[<++++++++++>
 -]<+>>+++++++++[<++++
  ++++++>-]<+++>>++++
   ++[<++++++++++>-]
    <>>++++++[<++++
     ++++++>-]<++>
      >++++[<++++
       ++++++>-]
        <+++>>+
         +++[<
          +++
           +
          +++
         +++>-
        ]<++++>
       >++++[<++
      ++++++++>-]
     <+++++>>++++[
    <++++++++++>-]<
   ++++++>>+[->,+[>+
  [<-<+>>-]]<[<<<<<<.
 >>>>>>-]<<<.<<<<.>>>>
>>><]>>>>++[<+++++>-]<.
[download]