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";
|
