-------------------------
 use Scalar::Util 'dualvar';

 my $width   = dualvar( 800, 'Szeroko ekranu'     );
 my $height  = dualvar( 600, 'Wysoko ekranu'      );
 my $colors  = dualvar(  16, 'Gbia kolorw'       );

 # jaki kod
 sub debug_variable
 {
     my $constant = shift;
     printf STDERR "%s to %d\n", $constant, $constant;
 }
-------------------------
 Szeroko ekranu to 800
 Wysoko ekranu to 600
 Gbia kolorw to 16
-------------------------
 use constant AUTHOR => dualvar( 006, 'chromatic autor-superszpieg' );
-------------------------
 use Readonly;
 Readonly::Scalar my $colors => dualvar(  16, 'Gbia kolorw' );
-------------------------
 use strict;
 use warnings;

 my ($books_total, $movies_total, $candy_total, $certificates_total, $total);

 create_report(  );
 print_report(  );
 exit(  );

 sub print_report
 {
     print <<END_REPORT;
 SALES
     Books:             $books_total
     Movies:            $movies_total
     Candy;             $candy_total
     Gift Certificates: $certificates_total

 TOTAL:                 $total
 END_REPORT
 }

 sub create_report
 {
     # tutaj tworzymy nasz kod
 }

 sub get_row
 {
     return unless defined( my $line = <DATA> );
     chomp( $line );
     return split( ':', $line );
 }

 _ _DATA_ _
 books:10.00
 movies:15.00
 candy:7.50
 certificates:8.00
-------------------------
 sub create_report
 {
     my %totals;
     @totals{ qw( books movies candy certificates total )} =
     \( $books_total, $movies_total, $candy_total,
        $certificates_total, $total
      );

     while (my ($category, $value)  = get_row(  ))
     {
         ${ $totals{ $category } } += $value;
         ${ $totals{total}       } += $value;
     }
 }
-------------------------
 print "Pokazuj pierwszy ", @results / 2, " z ", scalar @results, "\n";

 for (@results[ 0 .. @results / 2 - 1 ])
 {
     if (m/($IDENT): \s* (.*?) \s* $/x)
     {
         print "$1 -> ", normalize($2), "\n";
     }
     else
     {
         print "Dziwny wynik: ", substr( $2, 0, 10 ), "\n";
     }
 }
-------------------------
 sub say { print @_, "\n" }

 # i ju zawsze...

 say "Pokazuj pierwszy ", @results / 2, " z ", scalar @results;

 for (@results[ 0 .. @results / 2 - 1 ])
 {
     if (m/($IDENT): \s* (.*?) \s* $/x)
     {
         say "$1 -> ", normalize($2);
     }
     else
     {
         say "Dziwny wynik: ", substr( $2, 0, 10 );
     }
 }
-------------------------
 open my $fh, '<', $filename or die "Nie mog otworzy 'filename'";
 my $contents = do { local $/; <$fh> };
-------------------------
 sub slurp
 {
     my ($file) = @_;
     open my $fh, '<', $file or croak "Nie mog otworzy '$file'";
     local $/;
     return <$fh>;
 }

 # i nastpnie:

 my $contents = slurp $filename;
-------------------------
 use Test::More tests => 2;
 use Hash::Util 'lock_keys';

 my %locked   = ( foo => 1, bar => 2 );
 my %unlocked = ( foo => 1, bar => 2 );
 lock_keys( %locked );

 eval {   $locked{fool} = 1 };
 eval { $unlocked{fool} = 1 };

 is( keys %locked,   2, 'zablokowana tablica asocjacyjna powinna odrzuca nieznane klucze' );
 is( keys %unlocked, 3, '... natomiast niezablokowana tablica asocjacyjna przeciwnie' );
-------------------------
Attempt to access disallowed key 'fool' in a restricted hash...
-------------------------
 use Scope::Guard;

 sub process_records
 {
     my $records  = fetch_records(  );
     my $last_rec = 0;
     my $cleanup  = sub { cleanup( $last_rec ) if $last_rec };
     my $guard    = Scope::Guard->new( $cleanup );

     for my $record ( @$records )
     {
         process_record( $record );
         $last_rec = $record;
     }
 }

 sub cleanup
 {
     my $record = shift;

     # zaznaczamy ostatni w peni rozpatrzony rekord
 }
-------------------------
 use Cwd;

 sub change_directory
 {
     my $newdir = shift;
     my $curdir = cwd(  );
     chdir( $newdir );
     return Scope::Guard->new(  sub { chdir $curdir } );
 }
-------------------------
 sub foo
 {
     ...jaki kod funkcji....
 }
-------------------------
sub foo;   # predefiniowanie funkcji 'foo'
-------------------------
 sub foo (  )
 {
     ...jaki kod funkcji....
 }
-------------------------
sub foo (  );
-------------------------
 my $x = time;
 my $x = time(  );
-------------------------
 sub time_days (  )
 {
   return time(  ) / (24 * 60 * 60);
 }

 my $xd = time_days;
-------------------------
 use Date::Format 'time2str';

    sub ymd_now ( ) 
    { 
       time2str('%Y-%m-%d', time) 
    }
 print "Mamy teraz ", ymd_now, "!!\n";
-------------------------
{
     package TimeVar_YMDhms;

     use Tie::Scalar (  );
     use base 'Tie::StdScalar';
     use Date::Format 'time2str';

     sub FETCH { time2str('%Y-%m-%dT%H:%M:%S', time) }
 }

 tie my $TIME, TimeVar_YMDhms;

 print "Mamy teraz $TIME\n";
 sleep 3;
 print "Mamy teraz $TIME\n";
-------------------------
 Mamy teraz 2006-09-03T16:04:17
 Mamy teraz 2006-09-03T16:04:20
-------------------------
 {
     package Tie::ScalarFnParams;
     sub TIESCALAR
     {
         my($class, $fn, @params) = @_;
         return bless sub { $fn->(@params) }, $class;
     }

     sub FETCH { return shift(  )->(  ) }
     sub STORE { return } #  wywoywana dla $var = jakawarto;
 }

 use Date::Format 'time2str';

 tie my $TIME, Tie::ScalarFnParams,
  # A teraz dowolna funkcja i opcjonalny parametr(y):
    sub { time2str(shift, time) }, '%Y-%m-%dT%H:%M:%S';

 print "Mamy teraz $TIME\n";
 sleep 3;
 print "Mamy teraz $TIME\n";
-------------------------
 use Lingua::EN::Numbers::Ordinate 'ordinate';
 print ordinate(4), "!\n";
-------------------------
 {
     package Tie::Ordinalize;

     use Lingua::EN::Numbers::Ordinate 'ordinate';
     use base 'Tie::Array';

     sub TIEARRAY  { return bless {  }, shift } # obiekt-atrapa 
     sub FETCH     { return ordinate( $_[1] ) }
     sub FETCHSIZE { return 0 }
 }

 tie my @TH, Tie::Ordinalize;
 print $TH[4], "!\n";
-------------------------
 {
     package Tie::TimeFormatty;
     use Tie::Hash (  );
     use base 'Tie::StdHash';
     use Date::Format 'time2str';
     sub FETCH { time2str($_[1], time) }
 }

 tie my %NowAs, Tie::TimeFormatty;

 print "Mamy teraz $NowAs{'%Y-%m-%dT%H:%M:%S'}\n";
 sleep 3;
 print "Mamy teraz $NowAs{'%c'}\n";
-------------------------
 Mamy teraz 2006-02-03T18:28:06
 Mamy teraz 02/03/06 18:28:09
-------------------------
 use Date::Format 'time2str';
 use Interpolation  NowAs => sub { time2str($_[0],time) };

 print "Mamy teraz $NowAs{'%Y-%m-%dT%H:%M:%S'}\n";
 sleep 3;
 print "Mamy teraz $NowAs{'%c'}\n";
-------------------------
open $fh, '>: warstwa:innawarstwa:jeszczeinna', 'file.dat' 
-------------------------
 open( $out, '>:utf8', 'resume.utf' ) or die "Nie mog odczyta resume: $!\n";
 print {$out} "\x{2605} My R\xE9sum\xE9 \x{2605}\n";
 close( $out );  # ^^-- znak gwiazdki
-------------------------
 package Function_IO_Layer;

 # Bazowa klasa-atrapa dla prostych warstw PerlIO::via::*.
 # W module PerlIO::via::dynamic mona znale sprytniejsz wersj tego kodu.

 sub PUSHED { bless {  }, $_[0] } # our dumb ctor

 # podczas odczytywania
 sub FILL
 {
     my($this, $fh) = @_;
     defined(my $line = readline($fh)) or return undef;
     return $this->change($line);
 }

 sub WRITE
 {
     my($this,$buf,$fh) = @_;
     print {$fh} $this->change($buf)  or return -1;
     return length($buf);
 }

 sub change { my($this,$str) = @_;  $str; } #pokrywanie!

 # Zmienia cao na wielkie litery.
 package PerlIO::via::Scream;

 use base 'Function_IO_Layer';

 sub change
 {
     my($this, $str) = @_;
     return uc($str);
 }

 # Zmienia "I" na "me".
 package PerlIO::via::Cookiemonster;

 use base 'Function_IO_Layer';

 sub change
 {
     my($this, $str) = @_;
     $str =~ s<\bI\b><me>g;
     return $str;
 }
-------------------------
 open my $fh, '>:via(Scream):via(Cookiemonster)',
    'author_bio.txt' or die $!;

 print $fh "I eat cookies without cease or restraint.\n",
    "I like cookies.\n";

 close($fh);
-------------------------
 ME EAT COOKIES WITHOUT CEASE OR RESTRAINT.
 ME LIKE COOKIES.
-------------------------
 open my $ls, '-|:via(Scream)', 'ls -C /usr' or die $!;
 print <$ls>;
-------------------------
 BIN  GAMES    KERBEROS  LIBEXEC  SBIN   SRC  X11R6
 ETC  INCLUDE  LIB       LOCAL    SHARE  TMP
-------------------------
 bin  games    kerberos  libexec  sbin   src  X11R6
 etc  include  lib       local    share  tmp
-------------------------
@count_up = 0..100;
-------------------------
 my $input = <$fh>;      # skrt dla: readline($fh)

 my @files = <*.pl>;     # skrt dla: glob("*.pl")
-------------------------
@prime_countdown = grep { is_prime($_) } map { 100-$_ } 0..99;
-------------------------
@prime_countdown = <100..1 : is_prime(X)>;
-------------------------
 package Glob::Lists;

 use Carp;

 # Wyraenia regularne suce do analizy rozbudowanej listy... 
 my $NUM    = qr{\s* [+-]? \d+ (?:\.\d*)? \s* }xms;
 my $TO     = qr{\s* \.\. \s*}xms;
 my $FILTER = qr{ (?: : (.*) )? }xms;
 my $ABtoZ  = qr{\A ($NUM) (,) ($NUM) ,? $TO ($NUM) $FILTER \Z}xms;
 my $AZxN   = qr{\A ($NUM) $TO ($NUM) (?:x ($NUM))? $FILTER \Z}xms;

 # Instalujemy now funkcj glob(  )...
 no warnings 'redefine';
 *CORE::GLOBAL::glob = sub
 {
     my ($listspec) = @_;

     # Czy ta specyfikacja pasuje do ktrej z akceptowalnych form? 
     croak "Niepoprawna specyfikacja listy: <$listspec>"
         if $listspec !~ $ABtoZ && $listspec !~ $AZxN;

     # Pobieramy zakres wartoci i dowolny filtr...
     my ($from, $to, $incr, $filter) =  $2 eq ',' ? ($1, $4, $3-$1, $5)
                                     :              ($1, $2, $3,    $4);

     # Rcznie zwikszamy przyrost, jeli nie zosta zdefiniowany...
     $incr = $from > $to ? -1 : 1 unless defined $incr;

     # Sprawdzamy, czy nie ma bezsensownych przyrostw (zero lub zy znak)...
     my $delta = $to - $from;
     croak sprintf "Cig <%s, %s, %s...> nigdy nie osignie %s",
         $from, $from+$incr, $from+2*$incr, $to
             if $incr =  = 0 || $delta * $incr < 0;

     # Generujemy list wartoci (i zwracamy j, jeli nie ma filtra)...
     my @vals = map { $from + $incr * $_ } 0..($delta/$incr);
     return @vals unless defined $filter;

     # Przed zwrceniem wartoci stosujemy filtr...
     $filter =~ s/\b[A-Z]\b/\$_/g;
     return eval "grep {package ".caller."; $filter } \@vals";
 };
-------------------------
<from, then,..to>
-------------------------
<from..to x increment>
-------------------------
 <from, then,..to : filtr>
 <from..to x incr : filtr>
-------------------------
 use Glob::Lists;

 for ( <1..100 x 7> ) {...}           # 1, 8, 15, 22,...85, 92, 99

 my @even_countdown  = <10,8..0>;     # 10, 8, 6, 4, 2, 0

 my @fract_countdown = <10,9.5,..0>;  # 10, 9.5, 9,...1, 0.5, 0

 my @some_primes = <1..100 x 3 : /7/ && is_prime(N)>;
                                      # 7, 37, 67, 73, 79, 97
-------------------------
 use Fatal qw( open close );

 open( my $fh, '>', '/invalid_directory/invalid_file' );
 print {$fh} "Halo!\n";
 close $fh;
-------------------------
Nie mog otworzy(GLOB(0x10159d74), >, /nodirectory/nofile.txt): Nie ma takiego pliku 
   ani katalogu (eval 1) wiersz 3
   main::_ _ANON_ _('GLOB(0x10159d74)', '>', '/nodirectory/nofile.txt') wywoana
       w fatal_io.pl wiersz 8
-------------------------

use Fatal qw( open close );
 eval{
     open( my $fh, '>', '/invalid_directory/invalid_file' );
     print {$fh} "Halo!\n";
     close $fh;
 };

 die "Bd pliku: $!" if $@;
-------------------------
 package MyCode;

 sub succeed { 1 }
 sub fail    { 0 }

 use Fatal qw( :void succeed fail );

 succeed(  );
 fail(  );

 1;
-------------------------
 package MyCode;
 use base 'Exporter';
 our @EXPORT = qw( succeed fail );

 sub succeed { 1 }
 sub fail    { 0 }

 use Fatal qw( :void succeed fail );

 1;
-------------------------
 if (wantarray)                # wantarray true      --> kontekst listy
 {
     return @some_list;
 }
 elsif (defined wantarray)     # wantarray zdefiniowana   --> kontekst skalarny
 {
     return $some_scalar;
 }
 else                          # wantarray niezdefiniowana --> kontekst void 
 {
     do_something(  );
     return;
 }
-------------------------
 return
     LIST   { @some_list     }
     SCALAR { $some_scalar   }
     VOID   { do_something(  ) };
-------------------------
 use Time::HiRes qw( time );
 use Contextual::Return;

 my $elapsed       = 0;
 my $started_at    = 0;
 my $is_running    = 0;

 # Konwertujemy czas w sekundach na acuch to HH::MM::SS string...
 sub _HMS
 {
     my ($elapsed) = @_;
     my $hours     = int($elapsed / 3600);
     my $mins      = int($elapsed / 60 % 60);
     my $secs      = int($elapsed) % 60;
     return sprintf "%02d:%02d:%02d", $hours, $mins, $secs;
 }

 sub stopwatch
 {
     my ($run)     = @_;

     # Aktualizujemy czas, ktry upyn...
     my $now       =  time(  );
     $elapsed     += $now - $started_at if $is_running;
     $started_at   =  $now;

     # Zdefiniowany argument wcza lub wycza stoper, niezdefiniowany zeruje go...
     $is_running   =  $run if @_;
     $elapsed      =  0 if @_ && !defined $run;

     # Obsugujemy rne konteksty skalarne...
     return
          NUM { $elapsed         }
          STR { _HMS( $elapsed ) }
         BOOL { $is_running      }
 }
-------------------------
 print "Zegar ju tyka\n"
     if stopwatch(  );                              # traktuj jak warto logiczn
 stopwatch(1);                                    # start
 do_stuff(  );
 stopwatch(0);                                    # stop
 print "Praca trwaa ", stopwatch(  ), "\n";        # raportuj jako acuch

 stopwatch(undef);                                # zeruj
 stopwatch(1);                                    # start
 do_more_stuff(  );
 print "Kolejna praca trwaa ", stopwatch(0), "\n";  # zastopuj i raportuj

 print "Przepraszam za opnienie\n"
     if stopwatch(  ) > 5;                          # traktuj jako liczb
-------------------------
$stopwatch_running = !!stopwatch(  );      # !! --> kontekst logiczny
-------------------------
 $stopwatch_running = stopwatch->{running};

 print "Stoper uruchomiony o ", stopwatch->{started}, "\n";
-------------------------
# Obsugujemy rne konteksty skalarne...
 return
         NUM { $elapsed         }
         STR { _HMS( $elapsed ) }
        BOOL { $is_running      }
     HASHREF { { elapsed = $elapsed,
                 started   => $now - $elapsed,
                 running   => $is_running,
               }
             }
-------------------------
${ stopwatch(  ) }    # Wywoaj stopwatch(  ) i traktuj wynik jako odwoanie do skalara
-------------------------
 # Obsugujemy rne konteksty skalarne...
 return
         NUM { $elapsed         }
         STR { _HMS($elapsed)   }
   SCALARREF { \ _HMS($elapsed) }
        BOOL { $is_running      }
     HASHREF { {   elapsed => $elapsed,
                   started => $now - $elapsed,
                   running => $is_running,
               }
             }
-------------------------
print "Praca trwaa ", stopwatch(  ), "\n";
-------------------------
print "Praca trwaa ${stopwatch(  )}\n";
-------------------------
 use Contextual::Return;
 use Time::HiRes qw( sleep time );      # Pozwala na mierzenie uamkw sekundy

 # Procedura zwraca warto aktywnego licznika czasu...
 sub timer
 {
     my $start = time;                  # Ustaw pocztkowy czas startu

     return VALUE                       # Zwr aktywn warto, ktra...
     {
         my $elapsed = time - $start;   #    1. wylicza czas, ktry upyn
         $start      = time;            #    2. zeruje czas startu
         return $elapsed;               #    3. zwraca czas, ktry upyn
     }
 }

 # Utwrz aktywn warto...
 my $process_timer = timer(  );

 # Uyj aktywnej wartoci...
 while (1)
 {
     do_some_long_process(  );
     print "Proces trwa $process_timer seconds\n";
 }
-------------------------
 my $task_timer    = timer(  );
 my $subtask_timer = timer(  );

 for my $task (@tasks)
 {
     print "Wykonuj $task...\n";
     for my $subtask ($task->get_subtasks(  ))
     {
         $subtask->perform(  );
         print "\t$subtask trwao $subtask_timer sekund\n";
     }
     print "Zakoczyem $task w czasie $task_timer sekund\n\n";
 }
-------------------------
 $ perl do_tasks.pl

 Wykonuj set-up...
     Finding files trwao 0.775737047195435 sekund
     Reading files trwao 0.985733032226562 sekund
     Verifying data trwao 0.137604951858521 sekund
 Zakoczyem set-up w czasie 1.98483791351318 sekund

 Wykonuj initialization...
     Creating data structures trwao 0.627048969268799 sekund
     Cross-correlating trwao 2.756386041641235 sekund
 Zakoczyem initialization w czasie 3.45225400924683 sekund

itd.
-------------------------
 use Contextual::Return;

 sub safe_open
 {
     my ($mode, $filename) = @_;
     my $user_has_tested   = 0;

     # Otwieramy uchwyt pliku i zapamitujemy, gdzie zosta otwarty...
     open my($filehandle), $mode, $filename;
     my $where = sprintf("'%s' wiersz %s", (caller)[1,2]);

     # Zwracamy warto aktywn, ktrej mona uywa dopiero po przetestowaniu...
     return (
         BOOL
         {
             $user_has_tested = 1;
             return defined $filehandle;
         }
         DEFAULT
         {
             croak "Prba uycia niesprawdzonego uchwytu pliku (otwierany dla $where)"
                 unless $user_has_tested;
             return $filehandle;
         }
     )
 }
-------------------------
my $fh = safe_open '<', $some_file;
-------------------------
 my $fh    = safe_open '<', $some_file;

 my $input = <$fh>;          # Uycie niesprawdzonej wartoci zwracanej 
                             # powoduje przywoanie bloku DEFAULT 
-------------------------
 $ perl demo.pl

 Prba uycia niesprawdzonego uchwytu pliku (otwierany dla 'demo.pl' wiersz 12) at demo.pl wiersz 14
-------------------------
 my $fh = safe_open '<', $some_file
     or croak "Nie mona otworzy $some_file";   # 'or' rozpatruje $fh w
                                            # kontekcie logicznym, tak wic 
                                            # przywouje blok BOOL 

 my $input = <$fh>;          # Przywouje domylny blok DEFAULT 
-------------------------
 my @NUMERAL_FOR    = (0..9,'A'..'Z');

 sub convert_to_base($base, $number)
 {
     my $converted  = "";
     while ($number > 0)
     {
         $converted = $NUMERAL_FOR[$number % $base] . $converted;
         $number    = int( $number / $base);
     }
     return $converted;
 }
-------------------------
 sub convert_to_base
 {
     my ($base, $number) = @_;   # <-- lista parametrw DIY 

     my $converted       = ''
     while ($number > 0)
     {
         $converted      = $NUMERAL_FOR[$number % $base] . $converted;
         $number         = int( $number / $base);
     }

     return $converted;
 }
-------------------------
 sub convert_to_base
 {
     my $converted  = '';

     while ($_[1] > 0)
     {
         $converted = $NUMERAL_FOR[$_[1] % $_[0]] . $converted;
         $_[1]      = int( $_[1] / $_[0]);
     }

     return $converted;
 }
-------------------------
 package My::Filter;
 use Filter::Simple;

 FILTER_ONLY code => sub
 {
     # Kod dowolnego programu korzystajcego z tego moduu
     # przesyany jest do tej procedury w zmiennej $_.
     # To co znajdzie si w zmiennej $_ na koniec tej procedury
     # zostanie przesane jako kod, ktry ma wykona kompilator. 
 };

 1;
-------------------------
 package Sub::With::Params;
 use Filter::Simple;

 # Wyraenie regularne ktre dopasowuje prawidowy identyfikator Perla (np. nazw procedury)...
 my $IDENT = qr/[^\W\d]\w*/;

 # Stosujemy ten kod na kodzie kadego programu 
 # ktry uywa bdzie moduu Sub::With::Params...
 FILTER_ONLY code => sub
 {
     s{ ( sub \s* $IDENT \s* )   # Dopasuj wszelkie deklaracje nazwanych procedur
        (   \( .*? \)        )   # ...po ktrych nastpuje lista parametrw 
        (   \s* \{           )   # ...po ktrych nastpuje kod procedury
     }
     {$1$3 my $2 = \@_;}gxs;     # Nastpnie przenie list parametrw do wewntrz 
                                 # procedury, konwertujc j na list
                                 # zmiennych leksykalnych inicjowanych z tablicy @_
 };

 1;
-------------------------
 use Sub::With::Params;

 sub convert_to_base($base, $number)
 {
     my $converted  = '';
     while ($number > 0)
     {
         $converted = $NUMERAL_FOR[$number % $base] . $converted;
         $number    = int( $number / $base);
     }
     return $converted;
 }
-------------------------
 sub convert_to_base { my ($base, $number) = @_;
     my $converted  = '';
     while ($number > 0)
     {
         $converted = $NUMERAL_FOR[$number % $base] . $converted;
         $number    = int( $number / $base);
     }
     return $converted; {_Index {_EndRange_}syntax_}
 }
-------------------------
 sub usage
 {
     if ($::VERBOSE)
     {
         print <<"END_USAGE";
 Skadnia: $0 [opcje] <plik_wejciowy> <plik_wyjciowy>

 Opcje:
     -z       Zero tolerancji dla bdw formatowania 
     -o       Tylko przegld wyniku
     -d       Tryb debugowania (wyszukiwania bdw)
 END_USAGE
     }
 }
-------------------------
 sub usage
 {
     if ($::VERBOSE)
     {
         print <<"END_USAGE";
             Skadnia: $0 [opcje] <plik_wejciowy> <plik_wyjciowy>

             Opcje:
                 -z       Zero tolerancji dla bdw formatowania 
                 -o       Tylko przegld wyniku
                 -d      
             END_USAGE
     }
 }
-------------------------
 $ ksv -z filename

 Skadnia: $0 [opcje] <plik_wejciowy> <plik_wyjciowy>

  Opcje:
      -z       Zero tolerancji dla bdw formatowania 
      -o       Tylko przegld wyniku
      -d       Tryb debugowania (wyszukiwania bdw)
-------------------------
 package Heredoc::Indenting;

 use Filter::Simple;

 FILTER
 {
     # Odszukujemy...
     1 while
         s{ <<                     #     Znacznik heredoc 
            ( ['"]             )   # $1: Cudzysw terminatora
            ( (?:\\\1|[^\n])*? )   # $2: Specyfikacja terminatora
              \1                   #     Dopasowanie zamykajcego cudzysowu
            ( [^\n]*  \n       )   # $3: Reszta wiersza instrukcji
            ( .*? \n           )   # $4: Zawarto heredoc 
            ( [^\S\n]*         )   # $5: Wszelkie wcicia za pomoc spacji...
              \2 \n                #     ...sam terminator 
         }

         # ... i zastpujemy je za pomoc tego samego bloku heredoc, z odpowiednio
         # cofnitym terminatorem oraz zawartoci bloku przerobion przez procedur 
         # ktra usuwa wcicie z kadego wiersza...
         {Try::outdent(q{$1$2$1}, '$5',<< $1$2$1)\n$4$2\n$3}xms;
 };

 use Carp;

 # Usuwamy wcicia z acucha...
 sub outdent
 {
     my ($name, $indentation, $string) = @_;

     # Skarymy si, jeli aden wiersz nie ma okrelonego wcicia...
     if ($string =~ m/^((?:.*\n)*?)(?!$indentation)(.*\S.*)\n/m)
     {
         my ($good_lines, $bad_line) = ($1, $2);
         my $bad_line_pos = 1 + ($good_lines =~ tr/\n/\n/);
         croak "Ujemne wcicie w wierszu $bad_line_pos ",
               "bloku <<$name heredoc specified";
     }

     # W przeciwnym razie usuwamy wcicia z kadego wiersza...
     $string =~ s/^$indentation//gm;
     return $string;
 }

 1;
-------------------------
print <<"END_USAGE";
-------------------------
{Try::outdent(q{$1$2$1}, '$5',<< $1$2$1)\n$4$2\n$3}xms;
 #                               ^
 #                               |
-------------------------
{"<< $1$2$1\n" . Try::outdent($1.$2.$1, $5, $4) . "$2\n$3"}exms;
-------------------------
 use P5NCI::Library;

 my $lib = P5NCI::Library->new( library => 'm' );
 $lib->install_function( 'cbrt', 'dd' );

 print cbrt( 27 ), "\n";
 print cbrt( 31 ), "\n";
-------------------------
 # plik sshd_config 
 Port 22
 Port 443
-------------------------
SSH-2.0-OpenSSH_3.9p1
-------------------------
SSH-2.0-OpenSSH_4.2p1 Debian-5
-------------------------
 Klient: ....s...o......$.@]w#.U!..F.(.h..^.#y....D....[/.x.=...."..w.4..
 Serwer: ....J...F..C.B.....y..cY.}s......h\.qo.......9..8.i.|..7..
-------------------------
 #!/usr/bin/perl

 use strict;
 use warnings;

 use Net::Proxy;

 # zwracamy pewne informacje do strumienia bdw STDERR
 Net::Proxy->set_verbosity(1);

 # uruchamiamy proxy na serwerze, ktry powinien nasuchiwa pod portem 443
 my $proxy = Net::Proxy->new(
     {   in =>
         {
             type         => 'dual',
             host         => '0.0.0.0',
             port         => 443,
             client_first =>
             {
                 type => 'tcp',
                 port => 444,     # przenosimy serwer https na inny port
             },
             server_first =>
             {
                 type => 'tcp',
                 port => 22,      #  stary, dobry SSH
             },

             # odczekujemy 2 sekundy
             timeout      => 2,
         },
         out => { type => 'dummy' },
     }
 );

 $proxy->register(  );

 Net::Proxy->mainloop(  );
-------------------------
#!/usr/bin/perl

 use strict;
 use warnings;

 use Net::Proxy;

 # przesyamy informacje do strumienia bdw STDERR
 Net::Proxy->set_verbosity(1);

 # uruchamiamy proxy na naszej stacji roboczej
 my $proxy = Net::Proxy->new(
     {   in =>
         {
             # lokalny port dla lokalnego klienta SSH 
             port => 2222,
             type => 'tcp',
         },
         out =>
         {
             host        => 'home.example.com',
             port        => 443,
             proxy_host  => 'proxy.company.com',
             proxy_port  => 8080,
             proxy_user  => 'id23494',
             proxy_pass  => 's3kr3t',
             proxy_agent => 'Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)',
         },
     }
 );

 $proxy->register(  );

 Net::Proxy->mainloop(  );
-------------------------
 my %dispatch =
 (
     czerwony => sub { return qq{<font color="#ff0000">$_[0]</font>} },
     zielony  => sub { return qq{<font color="#00ff00">$_[0]</font>} },
     niebieski=> sub { return qq{<font color="#0000ff">$_[0]</font>} },
     czarny   => sub { return qq{<font color="#000000">$_[0]</font>} },
     bialy    => sub { return qq{<font color="#ffffff">$_[0]</font>} },
 );
-------------------------
print $dispatch{czarny}->('rycerz');
-------------------------
 my %dispatch =
 (
   # warto zauway, e lewe ukoniki s "podwojone"
   '\\d'   => sub { return "znalazem liczb" },
   '[a-z]' => sub { return "znalazem ma liter" },
 );
-------------------------
my $re = Regexp::Assemble->new->track->add(keys %dispatch);
-------------------------
 while (<>)
 {
     $re->match($_) and print $dispatch{$re->matched}->(  );
 }
-------------------------
 use DispatchBot;

 my $bot = DispatchBot->new(
     server   => "irc.perl.org",
     port     => "6667",
     channels => ["#bottest"],
     nick     => 'rebot',
 );
 $bot->run(  );
-------------------------
 package DispatchBot;

 use strict;
 use Regexp::Assemble;
 use Bot::BasicBot;
 use YAML qw(LoadFile DumpFile);

 use vars qw( $VERSION @ISA );
 $VERSION    = '0.03';
 @ISA        = 'Bot::BasicBot';

 my $factoid = _load( 'factoid.dat' ); # "foo" to faktoidy "bar" 
 my $karma   = _load( 'karma.dat' );   # ledzimy foo++ i foo--

 sub _load
 {
     my $file = shift;
     return -e $file ? LoadFile($file) : {  };
 }

 sub _save
 {
     my ($dictionary, $file) = @_;
     DumpFile( $file, $dictionary );
 }

 sub _flush
 {
     _save( $factoid, 'factoid.dat' );
     _save( $karma,   'karma.dat' );
 }

 END { _flush }

 my %dispatch =
 (
     # definiujemy faktoid
     '(\\S+) is (.*)$' => sub { $factoid->{$_[0]} = $_[1]; _flush; return },

     # przepytujemy faktoid
     '(\\S+)\s*\\?$' => sub
     {
         exists $factoid->{$_[0]}
             and return "Uwaam, e $_[0] to $factoid->{$_[0]}"
     },

     # porzucamy faktoid
     'forget (\\S+)$'=> sub
     {
         if (exists $factoid->{$_[0]})
         {
             my $message = "Zapomniaem o $_[0]";
             delete $factoid->{$_[0]};
             _flush;
             return $message;
         }
     },

     # zmiany karmy
     '(\\S+)\\+\\+' => sub { $karma->{$_[0]}++; _flush; return },
     '(\\S+)--'     => sub { $karma->{$_[0]}--; _flush; return },

     # odpytywanie karmy
     '^karma (\\S+)$' => sub
     {
         return exists $karma->{$_[0]}
             ? "$_[0] ma karm $karma->{$_[0]}"
             : "$_[0] ma neutraln karm"
     },

     # pora koczy...
     '^!quit$' => sub { exit },
 );

 my $re = Regexp::Assemble->new->track->add(keys %dispatch);

 sub said
 {
     my ($self, $arg) = @_;
     $re->match($arg->{body})
         and return $dispatch{$re->matched}->($re->capture);
     return; 
 }
-------------------------
 my $dx   = 21123000000000000000000000000000000000000000000000000;
 my $rate = 1.23e12;

 my $end  = ( 23 * $dx - $rate * 230 - 2.34562516 ** 2 - 0.5 ) ** 0.33;
-------------------------
sqrt( [1.2, 1.3] )
-------------------------
[1.095445, 1.140175]
-------------------------
[1.2, 1.3] * [-1, 0.9]
-------------------------
[-1.3, 1.17]
-------------------------
 1.2 *  -1 --> -1.2
 1.3 *  -1 --> -1.3   (warto minimalna)
 1.2 * 0.9 -->  1.08
 1.3 * 0.9 -->  1.17  (warto maksymalna)
-------------------------
[1.2, 1.3] * [-1, 0.9]  -->  [-1.3, 1.17]
-------------------------
1.25(0.05) * -0.05(0.95)  -->  -0.065(1.235)
-------------------------
package Number::Intervals;

 # Wyliczamy maksymalny bd reprezentacji danej liczby...
 sub _eps_for
 {
     my ($num, $epsilon) = (shift) x 2;              # kopiujemy argumenty do obu zmiennych
     $epsilon /= 2 while $num + $epsilon/2 != $num;  # stopniowo zmniejszamy epsilon 
     return $epsilon;
 }

 # Tworzymy obiekt przedziau, pozwalajc na reprezentowanie bdw... 
 sub _interval
 {
     use List::Util qw( min max );
     my ($min, $max) = ( min(@_), max(@_) );
     return bless [$min - _eps_for($min), $max + _eps_for($max)], _ _PACKAGE_ _;
 }

 # Konwertujemy wszystkie zmiennoprzecinkowe stae na obiekty przedziaw... 
 sub import
 {
     use overload;

     overload::constant(
         float => sub
         {
             my ($raw, $cooked) = @_;
             return _interval($cooked);
         },
     );
 }
-------------------------
use Number::Intervals;
-------------------------
 use Number::Intervals;

 my $avogadro    = 6.02214199e23;   # staa fizyczna, liczba Avogadro
 my $atomic_mass = 55.847;          # masa atomowa elaza
 my $mass        = 100;             # masa w gramach

 my $count       = int( $mass * $avogadro/$atomic_mass );

 print "Liczba atomw w $mass gramach elaza = $count\n";
-------------------------
 $ perl count_atoms.pl

 Liczba atomw w 100 gramach elaza = 99
-------------------------
 $mass * $avogadro / $atomic_mass
-------------------------
 100 * 0x1808248 / 0x182dc10
-------------------------
 100 * 25199176 / 25353232
-------------------------
 # Przecianie operatorw arytmetycznych dla obiektw Number::Intervals...
 use overload
 (
     # Dodajemy dwa przedziay niezalenie sumujc ich dolne i grne granice...
     q{+} => sub
     {
         my ($x, $y) = _check_args(@_);
         return _interval($x->[0] + $y->[0], $x->[1] + $y->[1]);
     },

     # Odejmujemy przedziay niezalenie odejmujc ich dolne i grne granice...
     q{-} => sub
     {
         my ($x, $y) = _check_args(@_);
         return _interval($x->[0] - $y->[1], $x->[1] - $y->[0]);
     },

     # Mnoymy przedziay wybierajc z czterech iloczynw najmniejszy i najwikszy...
     q{*} => sub
     {
         my ($x, $y) = _check_args(@_);
         return _interval($x->[0] * $y->[0], $x->[1] * $y->[0],
                          $x->[1] * $y->[1], $x->[0] * $y->[1],
                         );
     },

     # Dzielimy przedziay wybierajc z czterech ilorazw najmniejszy i najwikszy... 
     q{/} => sub
     {
         my ($x, $y) = _check_args(@_);
         return _interval($x->[0] / $y->[0], $x->[1] / $y->[0],
                          $x->[1] / $y->[1], $x->[0] / $y->[1],
                         );
     },

     # Potgujemy przedziay wybierajc najmniejszy i najwikszy wynik...
     q{**} => sub
     {
         my ($x, $y) = _check_args(@_);
         return _interval($x->[0] ** $y->[0], $x->[1] ** $y->[0],
                          $x->[1] ** $y->[1], $x->[0] ** $y->[1],
                         );
     },

     # Wartoci cakowit przedziau s liczby cakowite wyznaczajce jego granice...
     q{int} => sub
     {
         my ($x) = @_;
         return _interval(int $x->[0], int $x->[1]);
     },

     # Pierwiastek kwadratowy z przedziau to pierwiastki kwadratowe z jego granic...
     q{sqrt} => sub
     {
         my ($x) = @_;
         return _interval(sqrt $x->[0], sqrt $x->[1]);
     },

     # Odwrcenie znaku: odwracamy znaki granic i wymieniamy miejscami mniejsz z wiksz:
     q{neg} => sub
     {
         my ($x) = @_;
         return _interval(-$x->[1], -$x->[0]);
     },

     # itd., itd. dla pozostaych operatorw arytmetycznych...
 );
-------------------------
 # W razie potrzeby zamieniamy argumenty i konwertujemy na przedziay... 
 sub _check_args
 {
     my ($x, $y, $reversed) = @_;

     return $reversed              ?  ( _interval($y), $x            )
          : ref $y ne _ _PACKAGE_ _  ?  ( $x,            _interval($y) )
          :                           ( $x,            $y            );
 }
-------------------------
 $ perl count_atoms_v2.pl

 Liczba atomw w 100 gramach elaza = Number::Intervals=ARRAY(0x182f89c)
-------------------------
use overload
 (
     # Zmieniamy przedziay na acuchy postaci: WARTO (MARGINES BDU)...
     q{""} => sub
     {
         my ($self) = @_;

         my $uncert = ($self->[1] - $self->[0]) / 2;

         use charnames qw( :full );
         return $self->[0]+$uncert . " (\N{PLUS-MINUS SIGN}$uncert)";
     },

     # Zmieniamy przedziay na liczby wyliczajc redni z ich granic (z ostrzeeniem)...
     q{0+} => sub
     {
         my ($self) = @_;
         carp "Przybliona wartoc przedziau jako pojedyncza (uredniona) liczba";
         return ($self->[0] + $self->[1]) /2;
     },
 );
-------------------------
 $ perl count_atoms_v3.pl

 Liczba atomw w 100 gramach elaza = 1.07832864612244e+24 (805306368)
-------------------------
 #!/usr/bin/perl                              # przykad (nad)uycia funkcji substr
 use warnings;
 use strict;

 my $pi='3.14159210535152623346475240375062163750446240333543375062';

      substr      ($^X,0)=
        substr    ($pi,-6);map{
          substr  ($^X,$.++,1)=chr(
           substr ($pi,21,2)+
           substr ($pi,$_,2))}(12,28,-18,-6,-10,14);map{$^O=$"x(
          substr  ($pi,-5,2));
        substr    ($^O,sin(++$a/8)*32+
      substr      ($pi,-2)/2+1,1)=$_;
    substr        ($^O,sin($a/4)*(
  substr          ($pi,2,2))+
 substr           ($pi,-7,-5)-1,1)=$_;print"$^O$/";eval($^X.('$b,'x3).
 substr           ($pi,-3,1).'.'.
  substr          ($pi,9,2));}(map{chr($_+
    substr        ($pi,21,2))}(
      substr      ($pi,8)x6)=~/../g);
-------------------------





