Transient's scratchpad

Public Scratchpad

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

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

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

#!/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";
[download]

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

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

#!/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";
[download]