Ukázky kódu v jazyce Perl

Následující text pravděpodobně pochází z mého pravěku a já jej zatím nestačil aktualizovat. Jeho přečtením tedy pravděpodobně nic nezískáte, spíše naopak.

my $numstr = sprintf("%03d", $ARGV[0]);

print "$^O\n";
print "$ENV{'OS'}\n";

@pole = qw(aaa bbb ccc);
print $pole[-1]."\n";

sub func ($) {
    my $n = shift;
    print "you gave me $n\n";
}
 
 
func("pepa");
 
@foo = qw(a b c);
func(@foo);

use Cwd;
my $cur_dir = getcwd;
print "curdir $cur_dir\n";

use strict;
 
sub print_jmena_osob {
  my ( $ra_osoby) = @_;
 
  foreach my $e ( @{$ra_osoby} ) {
    print $e->{jmeno}.': "';
    &{$e->{rs_proc}};
    print "\"\n";
  }
}
 
 
my $rs_sub = sub  {
  print "ja jsem nejlepsi";
};
 
 
my $rh_osoba = {  
                 prijmeno => 'novak',
                 jmeno => 'petr',
                 ra_nar => [ 
                              10, 10, 1910
                           ],
                 rs_proc => $rs_sub,
                 rh_dalsi => { 
                               ra_konicky => [ 'vareni' ], 
                               aaa => 'bbb'
                             }
              };
 
 
my $ra_osoby;
push ( @{$ra_osoby}, $rh_osoba );
&print_jmena_osob( $ra_osoby );
 
#nebo
# my @osoby;
# push(@osoby, $rh_osoba);
# &print_jmena_osob( \@osoby );

while (<>) {
  chomp;
  PARSER: {
       if ( /\G( \d+\b    )/gcx )  {
            print "number: $1\n";
            redo PARSER;
       }
       if ( /\G( \w+      )/gcx )  {
            print "word: $1\n";
            redo PARSER;
       }
       if ( /\G( \s+      )/gcx ) {
            print "space: $1\n";
            redo PARSER;
       }
       if ( /\G( [^\w\d]+ )/gcx ) {
            print "other: $1\n";
            redo PARSER;
       }
  }
}

sub compare($$) {
    my ($val1, $regex) = @_;
    my $retval = $val1 =~ /$regex/;
    return $retval;
}
 
$match = compare("old McDonald", qr/d.*D/i);

$a = "a";
$w = "a";
for $i (1..2) {
  print "$i:  '$a' ";
  if ($w =~ /^\Q$a\E$/o) {
    print "equal";
  } else {
    print "not equal";
  }
  print " '$w'\n";
  $a = b;
}

foreach (keys %SIG) {
  $SIG{$_} = \&sighandle;
}
 
while(1) {}
 
sub sighandle() {
  my($signal) = @_;
  print("Recieved signal: $signal\n");
}

    use Win32::Sound;
    Win32::Sound::Volume('90%');
    Win32::Sound::Play("sound.wav");
    Win32::Sound::Volume('100%');
    Win32::Sound::Stop();

$once = undef;
print "undef ";
if ($once) {
  print "is true\n";
} else {
  print "is false\n";
}
 
$once = 0;
print "$once ";
if ($once) {
  print "is true\n";
} else {
  print "is false\n";
}
 
$once = 1;
print "$once ";
if ($once) {
  print "is true\n";
} else {
  print "is false\n";
}
 
$once = "";
print '"" ';
if ($once) {
  print "is true\n";
} else {
  print "is false\n";
}
 
$once = " ";
print '" " ';
if ($once) {
  print "is true\n";
} else {
  print "is false\n";
}
 
print "\n";
$pok = ($once) ? "true" : "false";
print "'$once' is $pok\n";
 
$pok = (not $once) ? "false" : "true";
print "'$once' is $pok\n";

use threads;
use threads::shared;
 
my $mp : shared = 0;
 
sub start_thread {
    {
        lock($mp);
        $mp++;
        print "Thread started: $mp \n";
    }
}
 
my $thr1 = threads->new( \&start_thread, 1 ); 
my $thr2 = threads->new( \&start_thread, 2 ); 
 
$thr1->join();
$thr2->join();

#uzavery se sdilenim promennych
 
sub prepare_sl {
  my ($last) = @_;
  my ( $rs_s, $rs_l );
  $rs_s = sub { 
    if ( $last % 2 ) { $last++ }
    else { $last += 2 };
    print $last."\n";
  };
  $rs_l = sub { 
    if ( $last % 2 ) { $last += 2 }
    else { $last ++ };
    print $last."\n";
  };
  return ($rs_s, $rs_l );
}
 
( $dalsi_sudeA, $dalsi_licheA ) = prepare_sl(57);
( $dalsi_sudeB, $dalsi_licheB ) = prepare_sl(27);
&$dalsi_sudeA();   #58
&$dalsi_sudeA();   #60
&$dalsi_licheA();  #61
&$dalsi_licheB();  #29
&$dalsi_sudeB();   #30
&$dalsi_licheA();  #63
&$dalsi_licheB();  #31

@colors = qw(red blue green yellow orange purple violet);
for my $name (@colors) {
    no strict 'refs';  # renege for the block
    *$name = sub { "<FONT COLOR='$name'>@_</font>" };
}

use strict;
 
my $conf_file_name = 'yaml_conf.yaml';
 
use CGI::Kwiki::Config_yaml;
my $config_parser = CGI::Kwiki::Config_yaml->new();
my $rh_conf = $config_parser->parse_file( $conf_file_name );
 
foreach my $key ( keys %$rh_conf ) {
    print "$key: ".$rh_conf->{$key}."\n";
}

use strict;
use Carp;
 
$SIG{CHLD}='IGNORE';
 
my $pid;
while (not defined $pid) {
  $pid = fork();
 
  if (not defined $pid) {
    carp "Fork not work\n";
    sleep(5);
  }
}
 
#parent
if ($pid != 0) {
  print "parent (child $pid), press any key ...\n";
  <>;
  print "end\n";
  my $ok = kill 1, $pid;
  kill 9, $pid if not $ok;
  exit 0;
}
 
#child

# pridani vice novych polozek do hashe
@h{ keys %y } = values %y;