-------------------------
use YAML 'DumpFile';
 use POSIX 'strftime';

 local $YAML::UseBlock = 1;

 exit 1 unless -d 'posts';

 my @posts = <posts/*.yaml>;
 my $file  = 'posts/' . ( @posts + 1 ) . '.yaml';

 my $fields =
 {
     title => '',
     date  => strftime( '%d %B %Y', localtime(  ) ),
     text  => "\n\n",
 };

 DumpFile( $file, $fields );

 system( $ENV{EDITOR}, $file ) =  = 0
     or die "Bd podczas uruchamiania $ENV{EDITOR}: $!\n";
-------------------------
print "> ";
 while (my $next_cmd = <>)
 {
     chomp $next_cmd;
     process($next_cmd);
     print "> ";
 }
-------------------------
print "> " if -t *ARGV && -t select;
 while (my $next_cmd = <>)
 {
     chomp $next_cmd;
     process($next_cmd);
     print "> " if -t *ARGV && -t select;
 }
-------------------------
print "> " if -t *STDIN && -t *STDOUT;
-------------------------
print "> " if -t *ARGV && -t select;
-------------------------
use Scalar::Util qw( openhandle );

 sub is_interactive
 {
     # Nieinteraktywne, jeli dane nie s zwracane do terminala...
     return 0 if not -t select;

     # Jeli uchwyt *ARGV jest otwierany, dziaamy w trybie interaktywnym, o ile...
     if (openhandle *ARGV)
     {
         # ...uchwyt jest aktualnie otwarty na magiczny plik '-' 
         #    a standardowy strumie wejcia jest interaktywny...
         return -t *STDIN if defined $ARGV && $ARGV eq '-';

         # ...lub jest na kocu pliku (end-of-file), a kolejnym plikiem 
         #    jest magiczny plik '-'...
         return @ARGV>0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV;

         # ...lub jest bezporednio podczony do terminala 
         return -t *ARGV;
     }

     # Jeli uchwyt *ARGV nie jest otwarty, bdzie interaktywny jeli *STDIN jest
     # podpity do terminala i albo w wierszu polece nie zostay okrelone 
     # adne pliki albo te zostay okrelone jakie pliki a pierwszy z nich to 
     # magiczny plik '-' 
     else
     {
         return -t *STDIN && (@ARGV=  =0 || $ARGV[0] eq '-');
     }
 }
-------------------------
use IO::Interactive qw( is_interactive );

 print "> " if is_interactive;
 while (my $next_cmd = <>)
 {
     chomp $next_cmd;
     process($next_cmd);
     print "> " if is_interactive;
 }
-------------------------
use IO::Interactive qw( interactive );

 print {interactive} "> ";
 while (my $next_cmd = <>)
 {
     chomp $next_cmd;
     process($next_cmd);
     print {interactive} "> "; {_Index {_EndRange_}command line_}
 }
-------------------------
my $offset;
 print "Okrel przesunicie: " if is_interactive;
 GET_OFFSET:
 while (<>)
 {
     chomp;
     if (m/\A [+-] \d+ \z/x)
     {
         $offset = $_;
         last GET_OFFSET;
     }
     print " Okrel przesunicie: (prosz podaj liczb cakowit): "
         if is_interactive;
 }
-------------------------
use IO::Prompt;

my $offset = prompt( "Podaj przesunicie: ", -integer );
-------------------------
my $hex_num = prompt( "Podaj liczb szesnastkow> ",
           -req => { "Liczb *szesnastkow* prosz!> " => qr/^[0-9A-F]+$/i }
           );

 print "To daje ", hex($hex_num), " w systemie 10-tnym\n";
-------------------------
Podaj liczb szesnastkow> 2B|!2B
Liczb *szesnastkow* prosz!> C3P0
Liczb *szesnastkow* prosz!> 124C1
To daje 74945 w systemie 10-tnym
-------------------------
my $factor = prompt( "Wpisz liczb pierwsz: ",
                      -req => { "Sprbuj jeszcze raz: " => sub { is_prime($_) } }
                    );
-------------------------
if (prompt -YESNO, "Zakoczy? ")
 {
     save_changes($changes)
         if $changes && prompt -yes, "Zapisa zmiany? ";
     print "Zmiany: $changes\n";
     exit;
 }
-------------------------
Zakoczy? q
Zakoczy? (Please enter 'Y' or 'N') Y
Zapisa zmiany?  n
Zmiany: not saved
-------------------------
for my $file (@matching_files)
 {
     next unless prompt -one_char, -yes, "Skopiowa $file? ";
     copy($file, "$backup_dir/$file");
 }
-------------------------
my $drive = uc prompt "Wybierz dysk: ",
                       -one_char,
                       -req => { "Prosz wybierz A-F: " => qr/[A-F]/i };
-------------------------
my $passwd = prompt( "Pierwsze haso: ", -echo=>"" );
-------------------------
my $passwd = prompt( "Drugie haso: ", -echo=>"*" );
-------------------------
Pierwsze haso:
Drugie haso: ********
-------------------------
my $device = prompt 'Ktr bro aktywowa?',
                     -menu =>
                     [
                         'Rekiny z promieniami "lasera"',
                         'Paraliujce granaty gazowe',
                         'Promie mierci',
                         'Lustrzan kul',
                     ];

 print "Odliczanie rozpoczte. Aktywuj $device za 10:00 minut...\n";
-------------------------
Ktr bro aktywowa?
   a. Rekiny z promieniami "lasera"
   b. Paraliujce granaty gazowe
   c. Promie mierci
   d. Lustrzan kul 
 > q
 (Please enter a-d) > d
 Odliczanie rozpoczte. Aktywuj Lustrzan kul za 10:00 minut...
-------------------------
my $device = prompt 'Ktry z sekretnych planw aktywowa?',
                     -menu =>
                     {
                         Cousteau => 'Rekiny z promieniami "lasera"',
                         Libido   => 'Paraliujce granaty gazowe',
                         Zakonnik => 'Promie mierci',
                         Lnienie => 'Lustrzan kul',
                     };

 print "Odliczanie rozpoczete. Aktywuj $device za 10:00 minut...\n";
-------------------------
Ktry z sekretnych planw aktywowa?
  a. Cousteau
  b. Libido 
  c. Lnienie
  d. Zakonnik
 > c
 Odliczanie rozpoczete. Aktywuj Lustrzan kul za 10:00 minut... 
-------------------------
my $device = prompt 'Okrel swoj platform systemow:',
                     -menu =>
                     {
                         Windows => [ 'WinCE', 'WinME', 'WinNT' ],
                         MacOS   => {
                                      'MacOS 9' => 'Mac (Classic)',
                                      'MacOS X' => 'Mac (New Age)',
                                    },
                         Linux   => 'Linux',
                     };
-------------------------
Okrel swoj platform systemow:
  a. Linux
  b. MacOS
  c. Windows
 > b

 MacOS:
  a. MacOS 9
  b. Mac OS X
 > b

 Compiling for Mac (New Age)...
-------------------------
use Mac::Growl;

 Mac::Growl::RegisterNotifications(
     'growlalert', # nazwa aplikacji
     [ 'alert' ],  # powiadomienia wysyane przez aplikacj
     [ 'alert' ],  # wcz te powiadomienia
 );
-------------------------
Mac::Growl::PostNotification(
     'growlalert', # nazwa aplikacji
     'alert',      # typ powiadomienia
     "This is a title",
     "This is a description.",
 );
-------------------------
my %seconds_per =
 (
     's'   => 1,
     'm'   => 60,
     'h'   => 60*60,
 );

 my ( $period, @message ) = @ARGV;
 my ( $number, $unit )    = ( $period =~ m/^([\.\d]+)(.*)$/ )
       or die "skadnia: ga liczba[czas] komunikat\n";
 $unit ||= 's';

 my $growl_time = $number * $seconds_per{$unit};

 my $pid        = fork;
 die "nie udao si rozwidli procesu ($!)\n" unless defined $pid;

 unless ( $pid )
 {
     require Mac::Growl;
     sleep $growl_time;

     Mac::Growl::PostNotification(
         'growlalert', # nazwa aplikacji
         'alert',      # typ powiadomienia
         "@message",   # tytu
         "",           # brak opisu
         1,            # powiadomienie ma by trwae
     );
 }
-------------------------
$ ga 5m kawa
$ ga 2.5h 'stacja oxford - wysiadamy'
-------------------------
unless ( $pid )
 {
     sleep $growl_time;
     system( 'xmessage', @message );
 }
-------------------------
unless ( $pid )
 {
     sleep $growl_time;
     system( qw( cmd net send localhost ), @message );
 }
-------------------------
use SDL::App;

 # otwrz dla swojej aplikacji okno o wymiarach 640x480 
 our $app = SDL::App->new(-width => 640, -height => 480);

 # utwrz powierzchni na bazie pliku obrazka podanego w wierszu polece 
 our $img = SDL::Surface->new( -name => $ARGV[0] );

 # skopiuj bity powierzchni do okna swojej aplikacji 
 $img->blit( undef, $app, undef );

 # wyczy wszystkie oczekujce aktualizacje ekranu 
 $app->flip(  );

 # zaczekaj za pomoc sleep 3 sekundy, by uytkownik mg obejrze obraz
 sleep 3;
-------------------------
$img->blit( SDL::Rect->new(
     -width => 100, -height => 100, -x => 200, -y => 0
 ), $app, undef);
-------------------------
 use SDL;
 use SDL::App;
 use strict;

 # tu okrelamy docelow prdko animacji, mierzon jako odstp w milisekundach 
 # midzy dwiema klatkami; dla 50 klatek na sekund bdzie to 20 ms
 our $TARGET_ANIM_SPEED = 20;

 # definiujemy tablic, w ktrej midzy kolejnymi klatkami bd przechowywane 
 # wszystkie prostokty; pozwala to na szybsz aktualizacje ni z pomoc SDL::App#flip
 our @update_rects;

 # inicjujemy powierzchni ta wykorzystujc obrazek podany przez uytkownika 
 # w wierszu polece lub czyst powierzchni 

 our $background = SDL::Surface->new(-f $ARGV[0] ? (-name   => $ARGV[0])
                                                 : (-width  => 640,
                                                    -height => 480     ));
 # otwieramy dla aplikacji okno o wymiarach 640x480 
 our $app = SDL::App->new(-width => 640, -height => 480);

 # kopiujemy ca powierzchni ta do okna aplikacji 
 $background->blit(undef, $app, undef);

 # aktualizujemy okno aplikacji 
 $app->flip;

 # definiujemy tablic, ktra przechowywa bdzie wszystkie powierzchnie reprezentujce
 # barwne tzw. "duszki", o wszystkich moliwych poziomach koloru i przezroczystoci 
 our @imgs = map
 {
     # tworzymy powierzchni o wymiarze 30x20 dla jednego "duszka"
     my $surface = SDL::Surface->new(
         -width => 30, -height => 20, -depth => 32
     );

     # wypeniamy powierzchni jednolitym kolorem; niech blaknie z koloru
     # niebieskiego do biaego, gdy wykonywa bdziemy iteracj mapowanej wartoci 
     $surface->fill(undef,
         SDL::Color->new(-r => 128+$_*255/45, -g => 128+$_*255/45, -b => 255)
     );

     # definiujemy przezroczysto powierzchni(coraz bardziej przezroczysta)
     $surface->set_alpha(SDL_SRCALPHA, (15-$_)*255/15);

     # konwertujemy powierzchni do formatu wywietlania, by przypieszy kopiowanie
     # do okna aplikacji
     $surface->display_format(  );

 } (1..15);

 # definiujemy pomocnicz funkcj kopiujc powierzchni do okrelonej pozycji 
 # w oknie aplikacji, dodajc wykorzystywany prostokt do tablicy niezbdnych 
 # aktualizacji

 sub blit_at
 {
     my ($surface, $x, $y) = @_;
     my $dest_rect = SDL::Rect->new(
         -width => $surface->width(  ), -height => $surface->height(  ),
         -x => $x, -y => $y
     );
     $surface->blit(undef, $app, $dest_rect);
     push @update_rects, $dest_rect;
 }


 # definiujemy pomocnicz funkcj kopiujc kawaek ta podobny do obszaru 
 # powierzchni znajdujcego si w danym miejscu okna aplikacji, dodajc 
 # prostokt wykorzystywany w tablicy koniecznych aktualizacji; w ten sposb 
 # efektywnie "czycimy" powierzchni poprzednio tutaj skopiowan 
 sub erase_at
 {
     my ($surface, $x, $y) = @_;
     my $dest_rect = SDL::Rect->new(
         -width => $surface->width(  ), -height => $surface->height(  ),
         -x => $x, -y => $y
     );
     $background->blit($dest_rect, $app, $dest_rect);
     push @update_rects, $dest_rect;
 }

 # definiujemy tablic przechowujc pozycje "duszkw", licznik obliczajcy 
 # nowe pozycje "duszka", gdy jest animowany oraz warto logiczn, informujc, 
 # czy animacja ma zosta zatrzymana, czy nie 
 our (@pos, $counter, $stopped);

 # definiujemy instancj SDL::Event dla potrzeb monitorowania zdarze 
 our $event = SDL::Event->new(  );

 # tutaj zaczynamy gwn ptl 
 while (1)
 {
     # zachowujemy biec warto licznika milisekund sdlperl; koniec gwnej
     # ptli wykorzystuje go do synchronizacji animacji 
     my $synchro_ticks = $app->ticks(  );

     # wymazujemy wszystkie "duszki" w ich obecnych pozycjach (przechowywanych w @pos)
     for (my $i = 0; $i < @pos; $i++)
     {
         erase_at($imgs[$i], $pos[$i]{'x'}, $pos[$i]{'y'});
     }

     # sprawdzamy, czy s nowe zdarzenia 
     $event->pump(  );

     if ($event->poll != 0)
     {
         # jeli zdarzenie to wciniecie klawisza, zatrzymujemy animacj 
         if ($event->type(  ) =  = SDL_KEYDOWN)
         {
             $stopped = 1;
         }

         # jeli zdarzenie to zwolnienie klawisza, wznawiamy animacj
         if ($event->type(  ) =  = SDL_KEYUP)
         {
             $stopped = 0;
         }

         # jeli zdarzenie to "QUIT" (uytkownik klikn zamykajc ikon "close 
         # w oknie aplikacji) lub wcisn klawisz Escape, zakocz program
         if ($event->type =  = SDL_QUIT ||
             $event->type =  = SDL_KEYDOWN && $event->key_sym =  = SDLK_ESCAPE)
         {
             die "quit\n";
         }
     }

     # jeli animacja nie zostaa zatrzymana, zwiksz licznik
     $stopped or $counter++;

     # wstaw now pozycj na grze tablicy @pos; kolejne pozycje bd krzyw
     # sinusoidaln
     unshift @pos,
     {
         'x' => 320 + 200 * sin($counter/30),
         'y' => 240 +  80 * cos($counter/25),
     };

     # usuwamy zbyteczne pozycje 
     @pos > 15 and pop @pos;

     # rysujemy wszystkie "duszki" na ich nowych pozycjach 
     for (my $i = @pos - 1; $i >= 0; $i--)
     {
         blit_at($imgs[$i], $pos[$i]{'x'}, $pos[$i]{'y'});
     }

     # polecamy sdlperl oczyci wszystkie aktualizacje dla okrelonych prostoktw
     $app->update(@update_rects);

     # oprniamy tablic prostoktw potrzebujcych aktualizacji 
     @update_rects = (  );

     # odczekujemy przez zdefiniowany czas okrelajcy, przez ile milisekund ta
     # klatka ma by wywietlana. Dziki temu animacja bdzie bardziej pynna 
     my $to_wait = $TARGET_ANIM_SPEED - ($app->ticks - $synchro_ticks); 
     $to_wait > 0 and $app->delay($to_wait);
 }
-------------------------
package Module::Build::Configurator;

 use strict;
 use warnings;

 use base 'Module::Build';

 use SUPER;
 use File::Path;
 use Data::Dumper;
 use File::Spec::Functions;

 sub new
 {
     my ($class, %args) = @_;
     my $self           = super(  );
     my $config         = $self->notes( 'config_data' ) || {  };

     for my $question ( @{ $args{config_questions} } )
     {
         my ($q, $name, $default) = map { defined $_ ? $_ : '' } @$question;
         $config->{$name}         = $self->prompt( $q, $default );
     }

     $self->notes( 'config_module', $args{config_module} );
     $self->notes( 'config_data',   $config );
     return $self;
 }

 sub ACTION_build
 {
     $_[0]->write_config(  );
     super(  );
 }

 sub write_config
 {
     my $self      = shift;
     my $file      = $self->notes( 'config_module' );
     my $data      = $self->notes( 'config_data' );
     my $dump      = Data::Dumper->new( [ $data ], [ 'config_data' ] )->Dump;
     my $file_path = catfile( 'lib', split( /::/, $file . '.pm' ) );

     my $path      = ( splitpath( $file_path ) )[1];
     mkpath( $path ) unless -d $path;

     my $package   = <<END_MODULE;
     package $file;

     my $dump

     sub get_value
     {
         my (\$class, \$key) = \@_;

         return unless exists \$config_data->{ \$key };
         return               \$config_data->{ \$key };
     }

     1;
 END_MODULE

     $package =~ s/^\t//gm;

     open( my $fh, '>', $file_path )
         or die "Nie mona utworzy pliku konfiguracyjnego '$path': $!\n";
     print $fh $package;
     close $fh;
 }

 1;
-------------------------
use Module::Build::Configurator;

 my $build = Module::Build::Configurator->new(
     module_name      => 'User::IrisScan',
     config_module    => 'User::IrisScan::Config',
     config_questions =>
     [
         [ 'Jak si nazywasz?',                             'nazwisko', 'Anouska'  ],
         [ 'Oce siebie jako szpiega w skali od 1 do 10.',     'ocena', '10'       ],
         [ 'Jakiego koloru masz oczy?',                   'kolor_oczu', 'niebieski'],
     ],
 );


 $build->create_build_script(  );
-------------------------
 $ perl Build.PL
 Jak si nazywasz? [Anouska] Faye
 Oce siebie jako szpiega w skali od 1 do 10. [10] 8
 Jakiego koloru masz oczy? [niebieski] niebieski
 Deleting Build
 Removed previous script 'Build'
 Creating new 'Build' script for 'User-IrisScan' version '1.28'
 $
-------------------------
package User::IrisScan::Config;

 my $config_data = {
              'kolor_oczu' => 'niebieski',
              'nazwisko' => 'Faye',
              'ocena' => '8'
            };


 sub get_value
 {
     my ($class, $key) = @_;

     return unless exists $config_data->{ $key };
     return               $config_data->{ $key };
 }

 1;
-------------------------
 use strict;
 use warnings;

 use HTTP::Proxy ':log';
 use HTTP::Proxy::HeaderFilter::simple;

 # uruchom proxy z podanymi opcjami wiersza polece 
 my $proxy = HTTP::Proxy->new( @ARGV );

 for my $redirect (<DATA>)
 {
     chomp $redirect;

     my ($pattern, $destination) = split( /\|/, $redirect );
     my $filter                  = get_filter( $destination );

     $proxy->push_filter( host => $pattern, request => $filter );
 }

 $proxy->start(  );

 my %filters;

 sub get_filter
 {
     my $site = shift;

     return $filters{ $site } ||= HTTP::Proxy::HeaderFilter::simple->new(
         sub
         {
             my ( $self, $headers, $message ) = @_;

             # modyfikujemy tylko cz dania zwizan z hostem 
             $message->uri(  )->host( $site );

             # tworzymy now odpowied przekierowujc 
             my $res = HTTP::Response->new(
                 301,
                 "Przeniosa si pod adres $site",
                 [ Location => $message->uri(  ) ]
             );

             # i polecamy proxy odesa j do klienta
             $self->proxy(  )->response( $res );
         }
     );
 }

 _ _DATA_ _
 perlmonks.com|perlmonks.org
 www.perlmonks.org|perlmonks.org
-------------------------
$ perl memoryproxy.pl port 5000
-------------------------


