Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

Transient's scratchpad

by Transient (Hermit)
on Jun 14, 2005 at 17:43 UTC ( #466652=scratchpad: print w/replies, xml ) Need Help??

OP * Perl_ck_require(pTHX_ OP *o) { GV* gv; if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .p +m? */ SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_B +ARE)) { char *s; for (s = SvPVX(kid->op_sv); *s; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; Move(s+2, s+1, strlen(s+2)+1, char); --SvCUR(kid->op_sv); } } if (SvREADONLY(kid->op_sv)) { SvREADONLY_off(kid->op_sv); sv_catpvn(kid->op_sv, ".pm", 3); SvREADONLY_on(kid->op_sv); } else sv_catpvn(kid->op_sv, ".pm", 3); } } /* handle override, if any */ gv = gv_fetchpv("require", FALSE, SVt_PVCV); if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { OP *kid = cUNOPo->op_first; cUNOPo->op_first = 0; op_free(o); return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, kid, scalar(newUNOP(OP_RV2CV, 0 +, newGVOP(OP_ +GV, 0, gv) +))))); } return ck_fun(o); }

#!/usr/bin/perl use strict; package Obj; sub new { my $class = shift; my $id = shift; return bless { id => $id }, $class; } sub method1 { my $self = shift; print "Object $self->{'id'}: Method 1\n"; } sub method2 { my $self = shift; print "Object $self->{'id'}: Method 2\n"; } package main; my $object1 = new Obj(1); my $object2 = new Obj(2); $object1->method1; $object1->method2; $object2->method1; $object2->method2; foreach my $var ( keys %{*Obj::} ) { no strict 'refs'; my $typeglob = *{"Obj::".$var}; next unless *$typeglob{CODE}; print $typeglob, " - ", ref $typeglob, "\n"; *$typeglob = sub { print "Blah!" }; } use Data::Dumper; print Dumper(%Obj::), "\n"; $object1->method1; $object1->method2; $object2->method1; $object2->method2;
outputs
Object 1: Method 1 Object 1: Method 2 Object 2: Method 1 Object 2: Method 2 *Obj::method2 - *Obj::new - *Obj::method1 - $VAR1 = 'method2'; $VAR2 = *Obj::method2; $VAR3 = 'new'; $VAR4 = *Obj::new; $VAR5 = 'method1'; $VAR6 = *Obj::method1; Object 1: Method 1 Object 1: Method 2 Object 2: Method 1 Object 2: Method 2

#!/usr/bin/perl use HTML::TreeBuilder; my $html = qq{ <html> <body> <table> <tr><td></td></tr> </table> <font></font> <span>Hi THere</span> </body> </html>}; sub remove_empty_tags { my $parser = shift; my $tags = shift; my @children = $parser->content_list(); if ( !@children and grep { uc($_) eq uc($parser->tag()) } @$tags ) +{ $parser->detach(); } &remove_empty_tags( $_, $tags ) foreach @children; } my $parser = HTML::TreeBuilder->new_from_content( $html ); $parser->objectify_text(); remove_empty_tags( $parser, ['FONT','SPAN'] ); print $parser->as_HTML, "\n";

#!/usr/bin/perl use warnings; use strict; use IO::Handle; use IO::Select; use Win32::SelectablePipe qw( winpipe ); local ( *PIPE_READ, *PIPE_WRITE ); Win32::SelectablePipe::winpipe( *PIPE_READ, *PIPE_WRITE ); #pipe( *PIPE_READ, *PIPE_WRITE ); PIPE_READ->autoflush(1); PIPE_WRITE->autoflush(1); print "Pipes open\n"; if ( defined( my $pid = fork() ) ) { if ( $pid ) { my $io = new IO::Select(*PIPE_READ ); while( 1 ) { if ( $io->can_read( 0 ) ) { print "Reading from handle\n"; my $data = <PIPE_READ>; print "Got $data\n"; } else { print "No data, sleeping\n"; sleep 1; } } } else { print PIPE_WRITE "just some junk\n"; sleep 10; print PIPE_WRITE "more junk!\n"; } }

Not saying this is good form, but it gives me
Can't use string ("") as a subroutine ref
#!/usr/bin/perl use warnings; use strict; &second( "Hello" ); sub first { my $sub = shift; $sub->( 3 ); } sub third { } my $hash = { a1 => \&third }; sub second { my $test = shift; first ( sub { $hash->{a1}->( $test ) } ); }

#!/usr/bin/perl use warnings; use strict; package Class; sub new { bless {}, $_[0] }; 1; package Class::SubclassA; sub new { bless {}, $_[0]; }; 1; package Class::SubclassB; sub new { return bless {}, $_[0]; }; 1; package ClassFactory; my %creation_hash = ( SubclassA => sub { Class::SubclassA->new() }, SubclassB => sub { Class::SubclassB->new() } ); sub create { shift; print $creation_hash{$_[0]}, "\n"; return $creation_hash{$_[0]}->(); } 1; package main; my $a = ClassFactory->create( "SubclassA" ); my $b = ClassFactory->create( "SubclassB" ); print $a, "\n"; print $b, "\n";
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 rifling through the Monastery: (3)
As of 2020-04-10 00:24 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    The most amusing oxymoron is:
















    Results (49 votes). Check out past polls.

    Notices?