-------------------------
 #!/usr/bin/perl

 my $age = 10;
 print $aeg;
-------------------------
 #!/usr/bin/perl
 use strict;

 my $age = 10;
 print $aeg;
-------------------------
 BEGIN
 {
     require 'strict';
     strict->import(  ) if strict->can( 'import' );
 }
-------------------------
 my $name = 'Spot';

 BEGIN { print "Witam, $name!\n" }
-------------------------
 #!/usr/bin/perl

 BEGIN { print "Pierwszy!\n"  }
 CHECK { print "Trzeci!\n"  }
 CHECK { print "Drugi!\n" }
-------------------------
 Pierwszy! 
 Drugi! 
 Trzeci! 
-------------------------
 #!/usr/bin/perl

 BEGIN { print "Pierwszy!\n"  }
 INIT  { print "Czwarty\n" }
 CHECK { print "Trzeci!\n"  }
 CHECK { print "Drugi!\n" }
 INIT  { print "Pity!\n"  }
-------------------------
 Pierwszy! 
 Drugi! 
 Trzeci! 
 Czwarty! 
 Pity!
-------------------------
 #!/usr/bin/perl

   BEGIN { print "Pierwszy!\n"  }
   INIT  { print "Czwarty!\n" }
   CHECK { print "Trzeci!\n"  }
   CHECK { print "Drugi!\n" }
   INIT  { print "Pity!\n"  }

   eval  <<END_EVAL;
   BEGIN { print "BEGIN w eval\n!" }
   CHECK { print "CHECK w eval\n!" }
   INIT  { print "INIT w eval\n!"  }
   END_EVAL
-------------------------
 Pierwszy!
 Drugi! 
 Trzeci!
 Czwarty!
 Pity!
 BEGIN w eval!
-------------------------
 #!/usr/bin/perl

   BEGIN { print "Pierwszy!"  }
   INIT  { print "Czwarty!\n" }
   CHECK { print "Trzeci!\n"  }
   CHECK { print "Drugi!\n" }
   INIT  { print "Pity!\n"  }

   eval <<END _EVAL;
   BEGIN { print "BEGIN w eval\n!" }
   CHECK { print "CHECK w eval\n!" }
   INIT  { print "INIT w eval\n!"  }
   END   { print "Szsty!\n"         }
   END_EVAL

   END   { print "smy!\n"       }
   END   { print "Sidmy!\n"        }
-------------------------
 Pierwszy!
 Drugi!
 Trzeci!
 Fourth!
 Fifth!
 BEGIN  w eval!
 Szsty!
 Sidmy! 
 smy!
-------------------------
 use strict;
 use Dumpvalue;

 my $d    = Dumpvalue->new(  );
 my $hash =
 {
      first_name => 'Tim',
      last_name  => 'Allwine',
      friends    => [ 'Jon','Nat','Joe' ],
 };
 $d->dumpValue(\$hash);
-------------------------
 -> HASH(0x80a190)
     'first_name' => 'Tim'
     'friends' => ARRAY(0x800368)
        0  'Jon'
        1  'Nat'
        2  'Joe'
     'last_name' => 'Allwine'
-------------------------
 use Dumpvalue;
 my $d = Dumpvalue->new(  );
-------------------------
 $d->dumpValue(\$someref);
-------------------------
 open my $fh, '>dump.out';
 my $old_fh = select($fh);
 $d->dumpValue(\$ref);
 close $fh;
 select($old_fh);
-------------------------
 use IO::Scalar;

 my $dump_str;
 my $io  = IO::Scalar->new(\$dump_str);
 my $oio = select($io);

 print '<pre>',"\n";       # idzie do $dump_str
 $d->dumpvalue(\$someref); # podobnie jak to
 print '</pre>';           # i to take

 select($oio);             # stary uchwyt pliku
 print $dump_str;          # ponownie do strumienie stdout, jeli chcemy 
-------------------------
 sub dispatch_request
 {
     my ($self, $q) = @_;
     my $action     = $q->param( 'action' );
     $self->$action(  );
 }
-------------------------
 sub dispatch_request
 {
     my ($self, $q) = @_;
     my $action     = $q->param( 'action' );
     return unless $self->can( $action );
     $self->$action(  );
 }
-------------------------
 sub dispatch_request
 {
     my ($self, $q) = @_;
     my $action     = 'action_' . $q->param( 'action' );
     return unless $self->can( $action );
     $self->$action(  );
 }
-------------------------
 my $register_subref = Logger->can( 'register ');
 $register_subref->(  ) if $register_subref;
-------------------------
 my $register_subref = $plugin->can( 'register ');
 $register_subref->(  ) if $register_subref;
-------------------------
 my $register_subref = eval { $plugin->can( 'register ') };
 $register_subref->(  ) if $register_subref;
-------------------------
 $ perl -MModule::CoreList -e 'print Module::CoreList->first_release(
     "File::Spec" ), "\n"'
 5.005
-------------------------
$ perl -MModule::CoreList -e 'print Module::CoreList->first_release(
       "Test::Simple", '0.30' ), "\n"'
 5.007003
-------------------------
 package Devel::TraceUse;

 use Time::HiRes qw( gettimeofday tv_interval );

 BEGIN
 {
     unshift @INC, \&trace_use unless grep { "$_" eq \&trace_use . '' } @INC;
 }

 sub trace_use
 {
     my ($code, $module) = @_;
     (my $mod_name       = $module) =~ s{/}{::}g;
     $mod_name           =~ s/\.pm$//;
     my ($package, $filename, $line) = caller(  );
     my $elapsed         = 0;

     {
         local *INC      = [ @INC[1..$#INC] ];
         my $start_time  = [ gettimeofday(  ) ];
         eval "package $package; require '$mod_name';";
         $elapsed        = tv_interval( $start_time );
     }
     $package            = $filename if $package eq 'main';
     push @used,
     {
         'file'   => $package,
         'line'   => $line,
         'time'   => $elapsed,
         'module' => $mod_name,
     };

     return;
 }

 END
 {
     my $first = $used[0];
     my %seen  = ( $first->{file} => 1 );
     my $pos   = 1;

     warn "Moduy adowane z $first->{file}:\n";

     for my $mod (@used)
     {
         my $message = '';

         if (exists $seen{$mod->{file}})
         {
             $pos = $seen{$mod->{file}};
         }
         else
         {
             $seen{$mod->{file}} = ++$pos;
         }

         my $indent = '  ' x $pos;
         $message  .= "$indent$mod->{module}, line $mod->{line}";
         $message  .= " ($mod->{time})" if $mod->{time};
         warn "$message\n";
     }
 }

 1;
-------------------------
 $ perl -MDevel::TraceUse /usr/bin/prove
 Modules used from /usr/bin/prove:
   Test::Harness, line 8 (0.000544)
     Test::Harness::Straps, line 6 (0.000442)
       Test::Harness::Assert, line 9 (0.000464)
       Test::Harness::Iterator, line 10 (0.000581)
       Test::Harness::Point, line 11 (0.000437)
       POSIX, line 313 (0.000483)
         XSLoader, line 9 (0.000425)
     Benchmark, line 9 (0.000497)
       Exporter::Heavy, line 17 (0.000502)
   Getopt::Long, line 9 (0.000495)
     constant, line 221 (0.000475)
   Pod::Usage, line 10 (0.000486)
     File::Spec, line 405 (0.000464)
       File::Spec::Unix, line 21 (0.000432)
     Pod::Text, line 411 (0.000471)
       Pod::ParseLink, line 30 (0.000475)
       Pod::Select, line 31 (0.000447)
         Pod::Parser, line 242 (0.000461)
           Pod::InputObjects, line 205 (0.000444)
           Symbol, line 210 (0.000469)
   File::Glob, line 82 (0.000521)
-------------------------
 my %types =
 (
     '$' => 'SCALAR',
     '@' => 'ARRAY',
     '%' => 'HASH',
     '*' => 'IO',
     '&' => 'CODE',
 );

 sub UNIVERSAL::contains_symbol
 {
     my ($namespace, $symbol) = @_;
     my @keys                 = split( /::/, $namespace );
     my $type                 = $types{ substr( $symbol, 0, 1, '' ) }
                             || 'SCALAR';

     my $table = \%main::;

     for my $key (@keys)
     {
         $key .= '::';
         return 0 unless exists $table->{$key};
         $table = $table->{$key};
     }

     return 0 unless exists $table->{$symbol};
     return *{ $table->{$symbol} }{ $type } ? 1 : 0;
 }
-------------------------
 print "Znalazem!\n" if UNIVERSAL->contains_symbol( '&contains_symbol' );
-------------------------
 sub make_counter
 {
     my ($start, $end, $step) = @_;

     return sub
     {
         return if $start == $end;
         $start += $step;
     };
 }
-------------------------
 use Data::Dumper;
 use PadWalker 'closed_over';

 my $hundred_by_nines = make_counter( 0, 100, 9 );

 while ( my $item = $hundred_by_nines->(  ) )
 {
     my $vars = closed_over( $hundred_by_nines );
     warn Dumper( $vars );
 }
-------------------------
$VAR1 = {
           '$start' => \9,
           '$step' => \9,
           '$end' => \100
         };
 $VAR1 = {
           '$start' => \18,
           '$step' => \9,
           '$end' => \100
         };

 # ...

 $VAR1 = {
           '$start' => \6966,
           '$step' => \9,
           '$end' => \100
         };

 # ...
-------------------------
 while ( my $item = $hundred_by_nines->(  ) )
 {
     my $vars  = closed_over( $hundred_by_nines );
     my $start = $vars->{'$start'};
     my $end   = $vars->{'$start'};
     my $step  = $vars->{'$step'};

     if ( $$start > $$step )
     {
         $$start = $$end - $$step;
     }
 }
-------------------------
use Data::Dump::Streamer;
my $hundred_by_nines = make_counter( 0, 100, 9 );
1 while 100 > $hundred_by_nines->(  );
Dump( $hundred_by_nines );
-------------------------
my ($end,$start,$step);
$end = 100;
$start = 108;
$step = 9;
$CODE1 = sub {
           return if $start =  = $end;
           $start += $step; 
        };
-------------------------
use vars qw( $frog $toad );

 sub wear_bunny_costume
 {
     my $bunny = shift;
     $frog     = $bunny;
     print "\$bunny to $bunny\n\$frog to $frog\n\$toad to $toad";
 }
-------------------------
 $ perl -MO=Concise,wear_bunny_costume friendly_animals.pl
 examples/friendly_animals.pl syntax OK
 main::wear_bunny_costume:
 n  <1> leavesub[1 ref] K/REFC,1 ->(end)
 -     <@> lineseq KP ->n
 1        <;> nextstate(main 35 friendly_animals.pl:5) v ->2
 6        <2> sassign vKS/2 ->7
 4           <1> shift sK/1 ->5
 3              <1> rv2av[t2] sKRM/1 ->4
 2                 <$> gv(*_) s ->3
 5           <0> padsv[$bunny:35,36] sRM*/LVINTRO -6
 7        <;> nextstate(main 36 friendly_animals.pl:6) v ->8
 a        <2> sassign vKS/2 ->b
 8           <0> padsv[$bunny:35,36] s ->9
 -           <1> ex-rv2sv sKRM*/1 ->a
 9              <$> gvsv(*frog) s -a
 b        <;> nextstate(main 36 friendly_animals.pl:7) v ->c
 m        <@> print sK ->n
 c           <0> pushmark s ->d
 -           <1> ex-stringify sK/1 ->m
 -              <0> ex-pushmark s ->d
 l              <2> concat[t6] sKS/2 ->m
 j                 <2> concat[t5] sKS/2 ->k
 h                    <2> concat[t4] sKS/2 ->i
 f                       <2> concat[t3] sK/2 ->g
 d                          <$> const(PV "$bunny is ") s ->e
 e                          <0> padsv[$bunny:35,36] s -f
 g                       <$> const(PV "\n$frog is ") s ->h
 -                    <1> ex-rv2sv sK/1 ->j
 i                       <$> gvsv(*frog) s -j
 k                 <$> const(PV "\n") s ->l
-------------------------
 use B::XPath;

 my $node = B::XPath->fetch_root( \&wear_bunny_costume );

 for my $global ( $node->match( '//gvsv' ) )
 {
     my $location = $global->find_nextstate(  );
     printf( "Zmienna globalna %s znaleziona w %s:%d\n",
     $global->NAME(  ), $location->file(  ), $location->line(  ) );
 }
-------------------------
 $ perl friendly_animals.pl
 Zmienna globalna frog znaleziona w friendly_animals.pl:8
 Zmienna globalna frog znaleziona w friendly_animals.pl:9
-------------------------
$node->match( '//gvsv[@NAME="toad"]' ))
-------------------------
 use B;

 sub introspect_sub
 {
     my $sub      = shift;
     my $cv       = B::svref_2object( $sub );

     return join( ':',
         $cv->STASH->NAME(  ), $cv->FILE(  ), $cv->GV->LINE(  ) . "\n"
     );
 }
-------------------------
use Devel::Peek 'CvGV';

sub Foo::bar {  }

print CvGV( \&Foo::bar );
-------------------------
 use Data::Dumper;

 package Foo;

 sub foo {  }

 package Bar;

 sub bar {  }
 *foo = \&Foo::foo;

 package main;

 warn introspect_sub( \&Foo::foo );
 warn introspect_sub( \&Bar::bar );
 warn introspect_sub( \&Bar::foo );
 warn introspect_sub( \&Dumper );

 # introspect_sub(  ) jak poprzednio...
-------------------------
 $ perl introspect.pl
 Foo:examples/introspect.pl:14
 Bar:examples/introspect.pl:18
 Foo:examples/introspect.pl:14
 Data::Dumper:/usr/lib/perl5/site_perl/5.8.7/powerpc-linux/Data/Dumper.pm:495
-------------------------
 sub introspect_sub
 {
     my $sub      = shift;
     my $cv       = B::svref_2object( $sub );
     my ($names)  = $cv->PADLIST->ARRAY(  );

     my $report   = join( ':',
         $cv->STASH->NAME(  ), $cv->FILE(  ), $cv->GV->LINE(  ) . "\n"
     );

     my @lexicals = map { $_->can( 'PV' ) ? $_->PV(  ) : (  ) } $names->ARRAY(  );

     return $report unless @lexicals;

     $report .= "\t(" . join( ', ', @lexicals ) . ")\n";
     return $report;
 }
-------------------------
use Data::Dumper;

 package Foo;

 sub foo{
     my ($foo, $bar, $baz) = @_;
}

 package Bar;

 sub bar {  }
 *foo = \&Foo::foo;

 package main;

 warn introspect_sub( \&Foo::foo );
 warn introspect_sub( \&Bar::bar );
 warn introspect_sub( \&Bar::foo );
 warn introspect_sub( \&Dumper );

 # introspect_sub(  ) po modyfikacjach...
-------------------------
$ perl introspect_lexicals.pl
 Foo:examples/introspect.pl:14
     ($foo, $bar, $baz)
 Bar:examples/introspect.pl:18
 Foo:examples/introspect.pl:14
     ($foo, $bar, $baz)
 Data::Dumper:/usr/lib/perl5/site_perl/5.8.7/powerpc-linux/Data/Dumper.pm:495
-------------------------
 use Devel::Symdump;
 my $symbols   = Devel::Symdump->new( 'main' );
 my @functions = $symbols->functions(  );
-------------------------
use Devel::Symdump;

 my %existing;

 BEGIN
 {
     my $symbols = Devel::Symdump->new( 'main' );
     @existing{ $symbols->functions(  ) } = (  );
 }

 use File::Spec::Functions;

 BEGIN
 {
     my $symbols   = Devel::Symdump->new( 'main' );
     my @new_funcs =
         map { s/main:://; $_ }
         grep { not exists $existing{ $_ } } $symbols->functions(  );
     local $" = "\n  ";
     warn qq|Importowane:$"@new_funcs\n|;
 }
-------------------------
 $ perl show_fsf_symbols.pl
 Importowane:
   catfile
   curdir
   updir
   path
   file_name_is_absolute
   no_upwards
   canonpath
   catdir
   rootdir
 $
-------------------------
 use B::TerseSize;

 sub report_largest_sub
 {
     my $package                  = shift;
     my ($symbols, $count, $size) = B::TerseSize::package_size( $package );
     my ($largest)                =
         sort { $symbols->{$b}{size} <=> $symbols->{$a}{size} }
         grep { exists $symbols->{$_}{count} }
         keys %$symbols;

     print "Cakowity rozmiar pakietu $package to $size dla $count operacji.\n";
     print "Raportuj $largest.\n";
     B::TerseSize::CV_walk( 'root', $package . '::' . $largest );
-------------------------
 Cakowity rozmiar pakietu Text::WikiFormat to 92078 dla 1970 operacji.
 Raportuj find_list.
 UNOP   leavesub      0x10291e88 {28 bytes} [targ 1 - $line]
     LISTOP lineseq       0x10290050 {32 bytes}

 ------------------------------------------------------------
         COP    nextstate     0x10290010 {24 bytes}
         BINOP  aassign       0x1028ffe8 {32 bytes} [targ 6 - undef]
             UNOP   null          0x1028fd38 {28 bytes} [list]
                 OP     pushmark      0x1028ffc8 {24 bytes}
                 UNOP   rv2av         0x1028ffa8 {28 bytes} [targ 5 - undef]
                     SVOP   gv            0x1028ff88 {96 bytes}  GV *_
             UNOP   null          0x1028d660 {28 bytes} [list]
                 OP     pushmark      0x1028fec0 {24 bytes}
                 OP     padsv         0x1028fe68 {24 bytes} [targ 1 - $line]
                 OP     padsv         0x1028fea0 {24 bytes} [targ 2 -
                                                                $list_types]
                 OP     padsv         0x1028fee0 {24 bytes} [targ 3 - $tags]
                 OP     padsv         0x1028ff10 {24 bytes} [targ 4 - $opts]

 [line 317 size: 380 bytes]

 ------------------------------------------------------------

 (snip 234 more lines)
-------------------------
 315: sub find_list
 316: {
 317:     my ( $line, $list_types, $tags, $opts ) = @_;
 318:
 319:     for my $list (@$list_types)
-------------------------
#!/usr/bin/perl -w
-------------------------
#!/usr/bin/pperl -w
-------------------------
alias svk='/usr/bin/pperl -- --anyuser /usr/bin/svk'
-------------------------
 package TraceGlobals;

 use strict;
 use warnings;

 use Runops::Trace \&trace_globals;

 my %globals;

 sub trace_globals
 {
     return unless $_[0]->isa( 'B::SVOP' ) && $_[0]->name(  ) eq 'gv';
     my $gv   = shift->gv(  );
     my $data = $globals{ $gv->SAFENAME(  ) } ||= {  };
     my $key  = $gv->FILE(  ) . ':' . $gv->LINE(  );
     $data->{$key}++;
 }

 END
 {
     Runops::Trace->unimport(  );

     for my $gv ( sort keys %globals )
     {
         my $gv_data = $globals{ $gv };
         my @counts  = keys %$gv_data;

         for my $line ( sort { $gv_data->{$b} <=> $gv_data->{$a} } @counts)
         {
             printf "%04d %s %-> s\n", $gv_data->{$line}, $gv, $line;

         }
     }
 }

 1;
-------------------------
 $ perl -MTraceGlobals find_package_symbols.pl
 Foo:find_package_symbols.pl:14
         ($foo, $bar, $baz)
 Bar:find_package_symbols.pl:18
 Foo:find_package_symbols.pl:14
         ($foo, $bar, $baz)
 Data::Dumper:/usr/lib/perl5/site_perl/5.8.7/powerpc-linux/Data/Dumper.pm:484
 0001 AddrRef -> /usr/lib/perl5/5.8.7/overload.pm:94
 0054 Bits -> /usr/lib/perl5/5.8.7/warnings.pm:189
 0003 Cache -> /usr/lib/perl5/5.8.7/Exporter.pm:13
 0002 DeadBits -> /usr/lib/perl5/5.8.7/warnings.pm:239
 0001 Dumper -> /usr/lib/perl5/5.8.7/Exporter.pm:65
 0001 EXPORT -> /usr/lib/perl5/site_perl/5.8.7/powerpc-linux/Data/Dumper.pm:24
 0001 EXPORT_OK -> /usr/lib/perl5/site_perl/5.8.7/powerpc-linux/
         Data/Dumper.pm:25
 0001 ISA -> /usr/lib/perl5/site_perl/5.8.7/powerpc-linux/Data/Dumper.pm:23
 0002 Offsets -> /usr/lib/perl5/5.8.7/warnings.pm:136
 0003 SIG -> /usr/lib/perl5/5.8.7/Exporter.pm:62
 0001 StrVal -> /usr/lib/perl5/site_perl/5.8.7/powerpc-linux/
         Data/Dumper.pm:104
 0037 _ -> :0
 <...>
-------------------------
 open my $fh, '>>', 'bad_style.txt'
     or die "Nie mog otworzy bad_style.txt by zaczy: $!\n";
 print $fh 'Witam!';
 close $fh;
-------------------------
 package B::Lint::VoidSyscalls;

 use strict;
 use warnings;

 use B 'OPf_WANT_VOID';
 use B::Lint;

 # Sprawiamy, by modu B::Lint akceptowa dodatki, jeli jeszcze tego nie robi.
 use if ! B::Lint->can('register_plugin'),
     B::Lint::Pluggable;

 # Rejestrujemy dodatek.
 B::Lint->register_plugin( _ _PACKAGE_ _, [ 'void_syscall' ] );

 # Sprawdzamy nastpujce kody operacji
 my $SYSCALL = qr/ ^ (?: open | print | close ) $ /msx;

 # Ponadto sprawdzamy, co znajduje si na samym kocu procedury 
 # sub foo { return print(  ) }
 my $TERM = qr/ ^ (?: leavesub ) $/msx;

 sub match
 {
     my ( $op, $checks ) = @_;

     if (     $checks->{void_syscall}
          and $op->name(  ) =~ m/$SYSCALL/msx )
     {
         if ( $op->flags() & OPf_WANT_VOID )
         {
             warn "Niesprawdzone wywoanie systemowe " .  $op->name(  )   
                 .  "w pliku " .  B::Lint->file(  ) .  " w wierszu " .
                 .  B::Lint->line(  ) .  "\n";
         }
         elsif ( $op->next->name(  ) =~ m/$TERM/msx )
         {
             warn "Potencjalnie niesprawdzone wywoanie systemowe " .  $op->name(  )   
                 .  "w pliku " .  B::Lint->file(  ) .  " w wierszu "
                 .  B::Lint->line(  ) .  "\n";
         }
     }
 }
-------------------------
$ perl -MB::Lint::VoidSyscalls -MO=Lint bad_style.pl
Niesprawdzone wywowanie systemowe print w pliku bad_style.pl w wierszu 3
Niesprawdzone wywowanie systemowe close w pliku bad_style.pl w wierszu 4
bad_style.pl sysntax OK
-------------------------
 sub match
 {
     my $op = shift;

     if ( $op->name(  ) eq 'entersub' )
     {
         my $class  = eval { $op->first->sibling->sv->PV };
         my $method = eval { $op->first->sibling->sibling->sv->PV };
         my $loc    = B::Lint->file(  ) . ' wiersz ' . B::Lint->line(  ) . '';

         if ( defined $class )
         {
             no strict 'refs';

             # sprawdzanie klas
             if ( not defined %{ $class . '::' } )
             {
                 warn "Klasa $class nie istnieje w $loc.\n";
             }
             # sprawdzanie metod klas
             elsif ( not $class->can($method) )
             {
                 warn "Klasa $class nie moe wykona metody $method w $loc.\n";
             }
         }
         elsif ( not grep { $_->can($method) } qw( Foo::Bar Foo::Baz ) )
         {
             warn "Obiekt nie moe wykona metody $method w $loc.\n";
         }
     }
 }
 use File::Slurp 'read_file';
 
 my %classes;
 sub classes
 {
    my $file = shift;
    $classes{$file} ||= scalar {
       map { $_ => 1 }
       grep { defined %{ $_ . ':: ' } }
       read_file($file) =~ m/( \w+ (?: (?:::|')\w+ ) * ) /msxg
    };
    return keys %{ $classes{$file} };
 }
-------------------------





