-------------------------
 use aliased 'Strasznie::Duga::Nazwa::Pakietu::Ktr::Nie::Sposb::Zapamita';

 my $rem = Zapamita->new( );
-------------------------
 use aliased 'Strasznie::Duga::Nazwa::Pakietu::Ktr::Nie::Sposb::Zapamita';

 my $rem = Strasznie::Duga::Nazwa::Pakietu::Ktr::Nie::Sposb::Zapamita->new(  );
-------------------------
 use aliased 'My::App::Contact';
 use aliased 'My::App::Type::Contact' => 'ContactType';

 my $contact_type = ContactType->new(  );
 my $contact      = Contact->new({ type => $contact_type });
-------------------------
use aliased 'My::App::Contact' => 'Contact', qw( EMAIL PHONE );

 my $contact = Contact->new({
     kind  => EMAIL,
     value => 'perlhacks@oreilly.com',
 });
-------------------------
 use lib 'lib';
 use Site::User;
-------------------------
 no lib 'badlib';
 use Site::User;
-------------------------
$ perl -Mlib=lib show_users.pl
-------------------------
$ perl -M-lib=badlib show_users.pl
-------------------------
$ export PERL5LIB=/home/user/work/lib:/home/user/work_test/lib:$PERL5LIB

% setenv PERL5LIB /home/user/work/lib:/home/user/work_test/lib:$PERL5LIB
-------------------------
 Enter a colon-separated set of extra paths to include in perl's @INC
 search path, or enter 'none' for no extra paths.

 Colon-separated list of additional directories for perl to search? [none]
-------------------------
package Module::Reloader;

 use strict;
 use warnings;

 my %module_times;

 INIT
 {
     while (my ($module, $path) = each %INC)
     {
         $module_times{ $module } = -M $path;
     }
 }

 sub reload
 {
     while (my ($module, $time) = each %module_times)
     {
         my $mod_time   = -M $INC{$module};
         next if $time =  = $mod_time;

         no warnings 'redefine';
         require ( delete $INC{  $module } );
         $module_times{ $module } = $mod_time;
     }
 }

 1;
-------------------------
use Nasz::Ulubiony::Modul;
Nasz::Ulubiony::Modul ->pozmywaj_prosze_naczynia(  );
-------------------------
Can't locate Nasz/Ulubiony/Modul.pm in @INC (@INC contains ...
-------------------------
package Zestaw::Osobisty::Moje;

 $VERSION = '0.42';

 1;

 _ _END_ _

 =head1 NAME

 Zestaw::Osobisty::Moje - Moje ulubione moduy testujce

 =head1 SYNOPSIS

 perl -MCPAN -e 'install Zestaw::Osobisty::Moje'

 =head1 CONTENTS

 Test::Class

 Test::Differences

 Test::Exception

 Test::MockModule

 Test::Pod

 Test::Pod::Coverage

 Test::WWW::Mechanize

 =head1 DESCRIPTION

 Moje ulubione moduy.

 ... reszta POD, jeli jest ...
-------------------------
$ cpan

 cpan shell -- CPAN exploration and modules installation (v1.7601)
 ReadLine support enabled

 cpan> autobundle

 # upywa troch czasu...

 Wrote bundle file
   /usr/src/.cpan/Bundle/Snapshot_2005_11_13_00.pm
-------------------------
$ cpan

 cpan shell -- CPAN exploration and modules installation (v1.7601)
 ReadLine support enabled

 cpan> install Bundle::Snapshot_2005_11_13_00

 # upywa sporo czasu...
-------------------------
use Module::CoreList;

 my ($bundle, $version) = @ARGV;
 $version             ||= $];
 @ARGV                  = $bundle;
 my $core_list          = $Module::CoreList::version{ $version };
 die "Nieznana wersja $version\n" unless $core_list;

 # odnajdujemy list moduw
 while (<>)
 {
     print;
     last if $_ eq "=head1 CONTENTS\n";
 }

 print "\n";

 # przetwarzamy tylko wiersze moduu/wersji 
 while (<>)
 {
     if ( $_ eq "=head1 CONFIGURATION\n" )
     {
         print;
         last;
     }

     chomp;
     next unless $_;

     my ($module, $version) = split( /\s+/, $_ );
     $version = 0 if $version eq 'undef';

     next if exists $core_list->{ $module }
                and $core_list->{ $module } >= $version;

     print "$module $version\n\n";
 }

 # wywietlamy ca reszt 
 print while <>;
-------------------------
 $ perl prune_bundle.pl Snapshot_2005_11_03_00.pm > PrunedSnapshot.pm
 $
-------------------------
package Devel::Presolve;

 use strict;
 use warnings;

 my @track;

 BEGIN { unshift @INC, \&resolve_path }

 sub resolve_path
 {
     my ($code, $module) = @_;
     push @track, $module;
     return;
 }

 INIT
 {
     print "BEGIN\n{\n";

     for my $tracked (@track)
     {
         print "\trequire( \$INC{'$tracked'} = '$INC{$tracked}' );\n";
     }

     print "}\n1;\n";
     exit;
 }

 1;
-------------------------
$ perl -MDevel::Preload slow_program.pl > preload.pm
-------------------------
BEGIN
 {
     require( $INC{'CGI.pm'}      = '/usr/lib/perl5/5.8.7/CGI.pm' );
     require( $INC{'CGI/Util.pm'} = '/usr/lib/perl5/5.8.7/CGI/Util.pm' );
     require( $INC{'vars.pm'}     = '/usr/lib/perl5/5.8.7/vars.pm' );
     require( $INC{'constant.pm'} = '/usr/lib/perl5/5.8.7/constant.pm' );
     require( $INC{'overload.pm'} = '/usr/lib/perl5/5.8.7/overload.pm' );
 }

 1;
-------------------------
#! /usr/bin/perl

 use strict;
 use warnings;
 use Carp;
 use Smart::Comments;
 use XML::Parser;
 use File::Spec;
 use IO::Prompt qw( prompt );
 use File::Spec::Functions;
 use File::Slurp qw( slurp );
 use DateTime;
 use DateTime::Duration;
 use DateTime::TimeZone;
 use DateTime::TimeZone::Antarctica::Mawson;
 # itd.
 # itd.
-------------------------
package Std::Modules;

 use strict;
 use warnings;
 use Carp;
 use Smart::Comments;
 use XML::Parser;
 use File::Spec;
 use IO::Prompt qw( prompt );
 use File::Spec::Functions;
 use File::Slurp qw( slurp );
 use DateTime;
 use DateTime::Duration;
 use DateTime::TimeZone;
 use DateTime::TimeZone::Antarctica::Mawson;
 # itd.

 1;
-------------------------
#! /usr/bin/perl

use Std::Modules;
-------------------------
package Std::Modules;
 use Filter::Macro;     # <-- Tu zachodzi caa magia

 use strict;
 use warnings;
 use Carp;
 use Smart::Comments;
 use XML::Parser;
 use File::Spec;
 use IO::Prompt qw( prompt );
 use File::Spec::Functions;
 use File::Slurp qw( slurp );
 use DateTime;
 use DateTime::Duration;
 use DateTime::TimeZone;
 use DateTime::TimeZone::Antarctica::Mawson;
 # itd.
 # itd.

 1;
-------------------------
#! /usr/bin/perl

use Std::Modules;
-------------------------
#! /usr/bin/perl

use Toolkit;
-------------------------
use IO::Prompt qw( prompt );
use File::Slurp qw( slurp );
-------------------------
 use SDL::App;

 # zmie te wartoci, jeli trzeba 
 my  $title                   = 'My SDL App';
 my ($width, $height, $depth) = ( 640, 480, 16 );

 my $app = SDL::App->new(
     -width  => $width,
     -height => $height,
     -depth  => $depth,
     -title  => $title,
 );

 # tu idzie twj kod; usu ostatni wiersz
 sleep 2;
-------------------------
$ perl -MSDL::Tutorial=sdl_demo.pl -e 1
-------------------------
my @command = caller( 3 );

return if @command and $command[1] ne '-e';
-------------------------
package Parser;

 sub parse
 {
     my ($class, $text) = @_;
     validate_text( $shift );
     bless \$text, $class;
 }	

 sub validate_text
 {
     my $text = shift;
     exit 1 unless $text =~ /^</;
 }

 1;
-------------------------
 use Parser;

 my $parser = eval { Parser->parse( 'jaki przykadowy tekst' ) };
 die "Dane nieodpowiednie dla parsera: $@\n" if $@;
-------------------------
 package Parser;
 use subs 'exit';
 package main;

 use Parser;
 sub Parser::exit{die shift;}
-------------------------
 use Parser;
 local *Parser::validate_text;
 *Parser::validate_text = sub
 {
     my $text = shift;
     die "Nieprawidowy tekst '$text'\n" unless $text =~ /^</;
 };
-------------------------
 use File::Exception;

 sub open_file
 {
     my ($name, $mode) = @_;

     open my $fh, $mode, $name or
         File::Exception->throw( file => $name, mode => $mode, error => $! );

     return $fh;
 }
-------------------------
package File::Exception;

 use SUPER;
 use Exception::Class;
	
 use base 'Exception::Class::Base';

 sub Fields
 {
     my $self = shift;
     return super(  ), qw( file mode );
 }

 sub file { $_[0]->{file} }
 sub mode { $_[0]->{mode} }

 sub full_message
 {
     my $self = shift;
     my $msg  = $self->message(  );

     my $file = $self->file(  );
     my $mode = $self->mode(  );

     return "Wyjtek '$msg' podczas otwierania pliku '$file' w trybie '$mode'";
 }

 1;
-------------------------
 my $fh;
 $fh = eval { open_file( '/dev/null', '<' ) };
 warn $@ if $@;

 $fh = eval { open_file( '/dev', '>' ) };
 warn $@ if $@;
-------------------------
Wyjtek 'Is a directory' podczas otwierania pliku '/dev' w trybie '>'
     at directory_whacker.pl line 10.
-------------------------
 $fh = eval { open_file( '/dev', '>' ) };

 if (my $error = $@)
 {
     warn sprintf "Prba otwarcia %s '%s' jako uytkownik %s czas %s: %s\n",
         $error->mode(  ), $error->file(  ), $error->uid(  ),
         scalar( localtime( $error->time(  ) ) ),
         $error->error(  );
 }
-------------------------
Prba otwarcia > '/dev' jako uytkownik 1000 czas Tue Jan 17 21:58:00 2006:
     Is a directory
-------------------------
#!perl -w

 # importujemy radonie
 use strict;
 use IO::Zlib;
 use Parse::CPAN::Modlist;

 # pobieramy wzorzec przeszukiwania
 my $pattern    = shift || die "Musisz przesa wzorzec\n";
 my $pattern_re = qr/$pattern/;

 # przerabiamy nasz nazw
 my $self       = $0; $self =~ s!^.*[\\/]!!;

 # dla niezorientowanych uytkownikw
 die ("skadnia : $self <zapytanie>\n") unless defined $pattern;

 # pobieramy lokaln list moduw z CPAN(PLUS?)::Config
 my $base;
 eval { require CPANPLUS::Config; CPANPLUS::Config->import(  ); };
 unless ($@)
 {
     my $conf = CPANPLUS::Config->new(  );
     # rne wersje przechowuj plik konfiguracyjny w rnych miejscach 
     for (qw(conf _build))
     {
         $base = $conf->{$_}->{base} if exists $conf->{$_};
     }
 }

 goto SKIP if defined $base;

 eval { require CPAN::Config; CPAN::Config->import(  ) };

 unless ($@)
 {
     local $CPAN::Config;
     $base = $CPAN::Config->{'keep_source_where'}."/modules/";
 }

 goto SKIP if defined $base;

 die "Nie mog ustali, gdzie trzymasz swoj list moduw CPAN \n";

 SKIP:
 my $file     = "${base}/03modlist.data.gz";

 # otwieramy plik i przesyamy mechanizmu analizujcego list moduw 
 my $fh       = IO::Zlib->new($file, "rb")  or die "Nie mona otworzy $file\n";
 my $ml       = Parse::CPAN::Modlist->new(join "", <$fh>);

 # domylnie potrzebujemy koloru
 my $colour   = 1;

 # sprawdzamy, czy mamy zainstalowany modu Term::ANSIColor 
 eval { require Term::ANSIColor };

 # jeli jednak go nie mamy, to nie bdziemy z niego korzysta 
 $colour      = 0 if $@;

 # teraz waciwe sprawdzanie 

 my $first    = 0;

 # sprawdzamy kady modu
 for my $module (map { $ml->module($_) } $ml->modules(  ))
 {
     my $name = $module->name(  );
     my $desc = $module->description(  );

     # sprawd, czy wzorzec pasuje do nazwy $name lub opisu $desc  
     next unless  $name =~ /$pattern_re/i or $desc =~ /$pattern_re/i;

     # estetyka
     print "\n-- Wyniki dla '$pattern' --\n\n" unless $first++;

     # sprawd, czy jest zainstalowany 
     eval  "require $name";

     # wywietl tytu - jeli mona w kolorze 
     if ( $colour && !$@ )
     {
           print Term::ANSIColor::color('red'),
               "$name\n",
               Term::ANSIColor::color('reset');
     }
     elsif (!$@)
     {
         print "!! $name\n";
     }
     else
     {
         print "$name\n";
     }

     # wywietl nazw i opis
     print "- $desc\n\n";
 }

 exit 0;
-------------------------
 #!perl -w

 use PAR 'foo.par';
 use Foo;
 ...
-------------------------
 #!perl -w

 use PAR 'http://www.example.com/foo.par';
 use Foo;
 ...
-------------------------
#!perl -w

 use strict;
 use Tk;

 my $mw = MainWindow->new(  );

 $mw->Label(-text => 'Hello, world! - Witam wszystkich!')->pack(  );
 $mw->Button(-text => 'Koniec', -command => sub { exit })->pack(  );

 MainLoop(  );
-------------------------
% pp -o helloworld helloworld.pl
-------------------------
% zipinfo helloworld
 Archive:  helloworld   3013468 bytes   689 files
 drwxr-xr-x  2.0 unx        0 b- stor 23-Oct-05 14:21 lib/
 drwxr-xr-x  2.0 unx        0 b- stor 23-Oct-05 14:21 script/
 -rw-r--r--  2.0 unx    20016 b- defN 23-Oct-05 14:21 MANIFEST
 -rw-r--r--  2.0 unx      210 b- defN 23-Oct-05 14:21 META.yml
 -rw-r--r--  2.0 unx     4971 b- defN 23-Oct-05 14:21 lib/AutoLoader.pm
 -rw-r--r--  2.0 unx     4145 b- defN 23-Oct-05 14:21 lib/Carp.pm
 ... [snipped 679 lines] ...
 -rw-r--r--  2.0 unx    12966 b- defN 23-Oct-05 14:21 lib/warnings.pm
 -rw-r--r--  2.0 unx      787 b- defN 23-Oct-05 14:21 lib/warnings/register.pm
 -rw-r--r--  2.0 unx      186 t- defN 23-May-05 22:22 script/helloworld.pl
 -rw-r--r--  2.0 unx      262 b- defN 23-Oct-05 14:21 script/main.pl
 689 files, 2742583 bytes uncompressed, 1078413 bytes compressed:  60.7%
-------------------------
use warnings;

 # ... tutaj jaki kod...

 sub say
 {
     no warnings 'uninitialized';
     print join( $,, @_ ), "\n";
 }
-------------------------
if (warnings::enabled(  ))
 {
     warnings::warn( "UNIVERSAL::can(  ) przyzwano jako funkcj, a nie metod" );
 }
-------------------------
 # wczamy
 use warnings 'UNIVERSAL::can';

 # wyczamy
 no warnings 'UNIVERSAL::can';
-------------------------
sub yucky_function
 {
     my ($package, $filename, $line) = caller(  );

     warnings::warnif( 'deprecated',
         "yucky_function(  ) jest nieaktualna, patrz $filename:$line\n" );

     goto &yummy_function;
 }
-------------------------
package FooProxy;

 sub new
 {
     my $class = shift;
     my $foo   = Foo->new( @_ );
     bless \$foo, $class;
   }

 sub can
 {
     my $self = shift;
     return $$self->can( @_ );
 }

 1;
-------------------------
 # Tworzymy obiekt porednika proxy 
 my $proxy = FooProxy->new(  );

 # Upewniamy si ze porednik proxy dziaa jak Foo
 if($proxy->isa('Foo'))
 {
     print "Proxy jest Foo!\n";
 }
 else
 {
     die "Proxy nie jest Foo!";
 }
-------------------------
 package Foo;
 use UNIVERSAL::isa;

 sub new
 {
     my $class = shift;
     bless \my $foo, $class;
 }

 sub isa
 {
     1;
 }

 1;
-------------------------
# w istocie przekazuje wywoania do Foo
 {
     package FooProxy;

     sub new
     {
         my $class = shift;
         my $foo   = Foo->new( @_ );
         bless \$foo, $class;
     }

     sub can
     {
         my $self = shift;
         return $$self->can( @_ );
     }
 }

 my $proxy = FooProxy->new(  );
 isa_ok( $proxy, 'Foo' );
-------------------------
 $ prove -lv t/bugs.t
 # tu testujemy dane wyjciowe...
-------------------------
$ cp -r UNIVERSAL-isa-0.05 UNIVERSAL-isa
-------------------------
$ diff -ur UNIVERSAL-isa-0.05 UNIVERSAL-isa > isa_misbehaving.patch
-------------------------



