{
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);
}