Perl
http://www.perl.org/
$string = '\n'; $string = 'Jon \'Maddog\' Orwant'; $string = "\n"; $string = "Jon \"Maddog\" Orwant"; $string = q/Jon 'Maddog' Orwant/; $string = q[Jon 'Maddog' Orwant]; $string = q{Jon 'Maddog' Orwant}; $string = q(Jon 'Maddog' Orwant); $string = q<Jon 'Maddog' Orwant>; $a = <<"EOF";
This is a multiline here document
terminated by EOF on a line by itself
EOF
$value = substr($string, $offset, $count);
$value = substr($string, $offset);
substr($string, $offset, $count) = $newstring;
substr($string, $offset) = $newtail;
($leading, $s1, $s2, $trailing) =
unpack("A5 x3 A8 A8 A*", $data);
@fivers = unpack("A5" x (length($string)/5), $string);
@chars = unpack("A1" x length($string), $string);
$string = "This is what you have";
$first = substr($string, 0, 1); $start = substr($string, 5, 2); $rest = substr($string, 13); $last = substr($string, -1); $end = substr($string, -4); $piece = substr($string, -8, 3); $string = "This is what you have";
print $string;
substr($string, 5, 2) = "wasn't";
substr($string, -12) = "ondrous";
substr($string, 0, 1) = "";
substr($string, -10) = ""; if (substr($string, -10) =~ /pattern/) {
print "Pattern matches in last 10 characters\n";
}
substr($string, 0, 5) =~ s/is/at/g;
$a = "make a hat";
(substr($a,0,1), substr($a,-1)) = (substr($a,-1), substr($a,0,1));
print $a;
$a = "To be or not to be";
$b = unpack("x6 A6", $a); print $b;
($b, $c) = unpack("x6 A2 X5 A2", $a); print "$b\n$c\n";
sub cut2fmt {
my(@positions) = @_;
my $template = '';
my $lastpos = 1;
foreach $place (@positions) {
$template .= "A" . ($place - $lastpos) . " ";
$lastpos = $place;
}
$template .= "A*";
return $template;
}
$fmt = cut2fmt(8, 14, 20, 26, 30);
print "$fmt\n";
$a = $b || $c;
$x ||= $y
$a = defined($b) ? $b : $c;
$foo = $bar || "DEFAULT VALUE";
$dir = shift(@ARGV) || "/tmp";
$dir = $ARGV[0] || "/tmp";
$dir = defined($ARGV[0]) ? shift(@ARGV) : "/tmp";
$dir = @ARGV ? $ARGV[0] : "/tmp";
$count{ $shell || "/bin/sh" }++;
$user = $ENV{USER}
|| $ENV{LOGNAME}
|| getlogin()
|| (getpwuid($<))[0]
|| "Unknown uid number $<";
$starting_point ||= "Greenwich";
@a = @b unless @a; @a = @b ? @b : @c; @b@c
($VAR1, $VAR2) = ($VAR2, $VAR1);
$temp = $a;
$a = $b;
$b = $temp;
$a = "alpha";
$b = "omega";
($a, $b) = ($b, $a); ($alpha, $beta, $production) = qw(January March August);
($alpha, $beta, $production) = ($beta, $production, $alpha);
$num = ord($char);
$char = chr($num);
$char = sprintf("%c", $num); printf("Number %d is character %c\n", $num, $num);
Number 101 is character e
@ASCII = unpack("C*", $string);
$STRING = pack("C*", @ascii);
$ascii_value = ord("e"); $character = chr(101); printf("Number %d is character %c\n", 101, 101);
@ascii_character_numbers = unpack("C*", "sample");
print "@ascii_character_numbers\n";
115 97 109 112 108 101
$word = pack("C*", @ascii_character_numbers);
$word = pack("C*", 115, 97, 109, 112, 108, 101); print "$word\n";
sample
$hal = "HAL";
@ascii = unpack("C*", $hal);
foreach $val (@ascii) {
$val++; }
$ibm = pack("C*", @ascii);
print "$ibm\n";
@array = split(//, $string);
@array = unpack("C*", $string);
while (/(.)/g) { }
%seen = ();
$string = "an apple a day";
foreach $byte (split //, $string) {
$seen{$byte}++;
}
print "unique chars are: ", sort(keys %seen), "\n";
unique chars are: adelnpy
%seen = ();
$string = "an apple a day";
while ($string =~ /(.)/g) {
$seen{$1}++;
}
print "unique chars are: ", sort(keys %seen), "\n";
unique chars are: adelnpy
$sum = 0;
foreach $ascval (unpack("C*", $string)) {
$sum += $ascval;
}
print "sum is $sum\n";
$sum = unpack("%32C*", $string);
$checksum = 0;
while (<>) { $checksum += unpack("%16C*", $_) }
$checksum %= (2 ** 16) - 1;
print "$checksum\n";
$DELAY = ($ARGV[0] =~ /^-([.\d]+)/) ? (shift, $1) : 1;
$| = 1;
while (<>) {
for (split(//)) {
print;
select(undef,undef,undef, 0.005 * $DELAY);
}
}
$revbytes = reverse($string);
$revwords = join(" ", reverse split(" ", $string));
$gnirts = reverse($string);
@sdrow = reverse(@words); @words
$confused = reverse(@words); @words$string = 'Yoda said, "can you see this?"';
@allwords = split(" ", $string);
$revwords = join(" ", reverse @allwords);
print $revwords, "\n";
this?" see you "can said, Yoda
$revwords = join(" ", reverse split(" ", $string));
$revwords = join("", reverse split(/(\s+)/, $string));
$word = "reviver";
$is_palindrome = ($word eq reverse($word));
while ($string =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e) {
}
use Text::Tabs;
@expanded_lines = expand(@lines_with_tabs);
@tabulated_lines = unexpand(@lines_without_tabs);
while (<>) {
1 while s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
print;
}
use Text::Tabs;
$tabstop = 4;
while (<>) { print expand($_) }
use Text::Tabs;
while (<>) { print unexpand($_) }
$text =~ s/\$(\w+)/${$1}/g;
$text =~ s/(\$\w+)/$1/gee;
use vars qw($rows $cols);
no strict 'refs'; my $text;
($rows, $cols) = (24, 80);
$text = q(I am $rows high and $cols long); $text =~ s/\$(\w+)/${$1}/g;
print $text;
I am 24 high and 80 long
$text = "I am 17 years old";
$text =~ s/(\d+)/2 * $1/eg;
2 * 17
$text = 'I am $AGE years old'; $text =~ s/(\$\w+)/$1/eg; '$AGE'
$text =~ s/(\$\w+)/$1/eeg; $text =~ s{
\$ (\w+) }{
no strict 'refs'; if (defined ${$1}) {
${$1}; } else {
"[NO VARIABLE: \$$1]"; }
}egx;
use locale;
$big = uc($little); $little = lc($big); $big = "\U$little"; $little = "\L$big"; $big = "\u$little"; $little = "\l$big"; use locale;
$beast = "dromedary";
$capit = ucfirst($beast); $capit = "\u\L$beast"; $capall = uc($beast); $capall = "\U$beast"; $caprest = lcfirst(uc($beast)); $caprest = "\l\U$beast"; $text = "thIS is a loNG liNE";
$text =~ s/(\w+)/\u\L$1/g;
print $text;
This Is A Long Line
if (uc($a) eq uc($b)) {
print "a and b are the same\n";
}
BEGIN { srand(time() ^ ($$ + ($$ << 15))) }
sub randcase { rand(100) < 20 ? "\u$_[0]" : "\l$_[0]" }
s/(\w)/randcase($1)/ge;
sub randcase {
rand(100) < 20 ? ("\040" ^ $_[0]) : $_[0];
}
$string &= "\177" x length($string);
$answer = $var1 . func() . $var2; $answer = "STRING @{[ LIST EXPR ]} MORE STRING";
$answer = "STRING ${\( SCALAR EXPR )} MORE STRING";
$phrase = "I have " . ($n + 1) . " guanacos.";
$phrase = "I have ${\($n + 1)} guanacos.";
print "I have ", $n + 1, " guanacos.\n";
some_func("What you want is @{[ split /:/, $rec ]} items");
die "Couldn't send mail" unless send_mail(<<"EOTEXT", $target);
To: $naughty
From: Your Bank
Cc: @{ get_manager_list($naughty) }
Date: @{[ do { my $now = `date`; chomp $now; $now } ]} (today)
Dear $naughty,
Today, you bounced check number @{[ 500 + int rand(100) ]} to us.
Your account is now closed.
Sincerely,
the management
EOTEXT
($var = <<HERE_TARGET) =~ s/^\s+//gm;
your text
goes here
HERE_TARGET
$var = <<HERE_TARGET;
your text
goes here
HERE_TARGET$var =~ s/^\s+//gm;
($definition = <<'FINIS') =~ s/^\s+//gm;
The five varieties of camelids
are the familiar camel, his friends
the llama and the alpaca, and the
rather less well-known guanaco
and vicuña.
FINISsub fix {
my $string = shift;
$string =~ s/^\s+//gm;
return $string;
}
print fix(<<"END");
My stuff goes here
END
print fix <<"END";
My stuff goes here
END($quote = <<' FINIS') =~ s/^\s+//gm;
...we will have peace, when you and all your works have
perished--and the works of your dark master to whom you would
deliver us. You are a liar, Saruman, and a corrupter of mens
hearts. --Theoden in /usr/src/perl/taint.c
FINIS$quote =~ s/\s+--/\n--/; if ($REMEMBER_THE_MAIN) {
$perl_main_C = dequote<<' MAIN_INTERPRETER_LOOP';
@@@ int
@@@ runops() {
@@@ SAVEI32(runlevel);
@@@ runlevel++;
@@@ while ( op = (*op->op_ppaddr)() ) ;
@@@ TAINT_NOT;
@@@ return 0;
@@@ }
MAIN_INTERPRETER_LOOP }
sub dequote;
$poem = dequote<<EVER_ON_AND_ON;
Now far ahead the Road has gone,
And I must follow, if I can,
Pursuing it with eager feet,
Until it joins some larger way
Where many paths and errands meet.
And whither then? I cannot say.
--Bilbo in /usr/src/perl/pp_ctl.c
EVER_ON_AND_ONprint "Here's your poem:\n\n$poem\n";
sub dequote {
local $_ = shift;
my ($white, $leader); if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) {
($white, $leader) = ($2, quotemeta($1));
} else {
($white, $leader) = (/^(\s+)/, '');
}
s/^\s*?$leader(?:$white)?//gm;
return $_;
}
if (m{
^ \s * (?: ( [^\w\s] + ) ( \s* ) .* \n ) (?: \s * \1 \2 ? .* \n ) + $ }x
)
{
($white, $leader) = ($2, quotemeta($1));
} else {
($white, $leader) = (/^(\s+)/, '');
}
s{
^ \s * ? $leader (?: $white ) ? }{}xgm;
use Text::Wrap;
@OUTPUT = wrap($LEADTAB, $NEXTTAB, @PARA);
@input = ("Folding and splicing is the work of an editor,",
"not a mere collection of silicon",
"and",
"mobile electrons!");
use Text::Wrap qw($columns &wrap);
$columns = 20;
print "0123456789" x 2, "\n";
print wrap(" ", " ", @input), "\n";
01234567890123456789
Folding and
splicing is the
work of an
editor, not a
mere collection
of silicon and
mobile electrons!
use Text::Wrap;
undef $/;
print wrap('', '', split(/\s*\n\s*/, <>));
use Text::Wrap qw(&wrap $columns);
use Term::ReadKey qw(GetTerminalSize);
($columns) = GetTerminalSize();
($/, $\) = ('', "\n\n"); while (<>) { s/\s*\n\s*/ /g; print wrap('', '', $_); }
$var =~ s/([CHARLIST])/\\$1/g;
$var =~ s/([CHARLIST])/$1$1/g;
$string =~ s/%/%%/g;
$string = q(Mom said, "Don't do that."); $string =~ s/(['"])/\\$1/g;
$string = q(Mom said, "Don't do that.");
$string =~ s/(['"])/$1$1/g;
$string =~ s/([^A-Z])/\\$1/g;
$string = "this \Qis a test!\E";
$string = "this is\\ a\\ test\\!";
$string = "this " . quotemeta("is a test!");
$string =~ s/^\s+//;
$string =~ s/\s+$//;
$string = trim($string);
@many = trim(@many);
sub trim {
my @out = @_;
for (@out) {
s/^\s+//;
s/\s+$//;
}
return wantarray ? @out : $out[0];
}
while(<STDIN>) {
chomp;
print ">$_<\n";
}
sub parse_csv {
my $text = shift; my @new = ();
push(@new, $+) while $text =~ m{
"([^\"\\]*(?:\\.[^\"\\]*)*)",?
| ([^,]+),?
| ,
}gx;
push(@new, undef) if substr($text, -1,1) eq ',';
return @new; }
use
Text::ParseWords;
sub parse_csv {
return quoteword(",",0, $_[0]);
}
$line = q<XYZZY,"","O'Reilly, Inc","Wall, Larry","a \"glug\" bit,",5,
"Error, Core Dumped">;
@fields = parse_csv($line);
for ($i = 0; $i < @fields; $i++) {
print "$i : $fields[$i]\n";
}
use Text::Soundex;
$CODE = soundex($STRING);
@CODES = soundex(@LIST);
use Text::Soundex;
use User::pwent;
print "Lookup user: ";
chomp($user = <STDIN>);
exit unless defined $user;
$name_code = soundex($user);
while ($uent = getpwent()) {
($firstname, $lastname) = $uent->gecos =~ /(\w+)[^,]*\b(\w+)/;
if ($name_code eq soundex($uent->name) ||
$name_code eq soundex($lastname) ||
$name_code eq soundex($firstname) )
{
printf "%s: %s %s\n", $uent->name, $firstname, $lastname;
}
}
use strict;
my $verbose = (@ARGV && $ARGV[0] eq '-v' && shift);
if (@ARGV) {
$^I = ".orig"; } else {
warn "$0: Reading from stdin\n" if -t STDIN;
}
my $code = "while (<>) {\n";
while (<DATA>) {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless $in && $out;
$code .= "s{\\Q$in\\E}{$out}g";
$code .= "&& printf STDERR qq($in => $out at \$ARGV line \$.\\n)"
if $verbose;
$code .= ";\n";
}
$code .= "print;\n}\n";
eval "{ $code } 1" || die;
analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key
use strict;
my $verbose = (@ARGV && $ARGV[0] eq '-v' && shift);
my %change = ();
while (<DATA>) {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless $in && $out;
$change{$in} = $out;
}
if (@ARGV) {
$^I = ".orig";
} else {
warn "$0: Reading from stdin\n" if -t STDIN;
}
while (<>) {
my $i = 0;
s/^(\s+)// && print $1; for (split /(\s+)/, $_, -1) { print( ($i++ & 1) ? $_ : ($change{$_} || $_));
}
}
analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key
while (<>) {
for (split) {
print $change{$_} || $_, " ";
}
print "\n";
}
my $pid = open(STDOUT, "|-");
die "cannot fork: $!" unless defined $pid;
unless ($pid) { while (<STDIN>) {
s/ $//;
print;
}
exit;
}
use strict;
my @fieldnames = qw(FLAGS UID PID PPID PRI NICE SIZE
RSS WCHAN STAT TTY TIME COMMAND);
my $fmt = cut2fmt(8, 14, 20, 26, 30, 34, 41, 47, 59, 63, 67, 72);
my %fields;
die <<Thanatos unless @ARGV;
usage: $0 criterion ...
Each criterion is a Perl expression involving:
@fieldnames
All criteria must be met for a line to be printed.
Thanatos
for my $name (@fieldnames) {
no strict 'refs';
*$name = *{lc $name} = sub () { $fields{$name} };
}
my $code = "sub is_desirable { " . join(" and ", @ARGV) . " } ";
unless (eval $code.1) {
die "Error in code: $@\n\t$code\n";
}
open(PS, "ps wwaxl |") || die "cannot fork: $!";
print scalar <PS>; while (<PS>) {
@fields{@fieldnames} = trim(unpack($fmt, $_));
print if is_desirable(); }
close(PS) || die "ps failed!";
sub cut2fmt {
my(@positions) = @_;
my $template = '';
my $lastpos = 1;
for my $place (@positions) {
$template .= "A" . ($place - $lastpos) . " ";
$lastpos = $place;
}
$template .= "A*";
return $template;
}
sub trim {
my @strings = @_;
for (@strings) {
s/^\s+//;
s/\s+$//;
}
return wantarray ? @strings : $strings[0];
}
FLAGS UID PID PPID PRI NI SIZE RSS WCHAN STA TTY TIME COMMAND
100 0 1 0 0 0 760 432 do_select S ? 0:02 init
140 0 187 1 0 0 784 452 do_select S ? 0:02 syslogd
100100 101 428 1 0 0 1436 944 do_exit S 1 0:00 /bin/login
100140 99 30217 402 0 0 1552 1008 posix_lock_ S ? 0:00 httpd
0 101 593 428 0 0 1780 1260 copy_thread S 1 0:00 -tcsh
100000 101 30639 9562 17 0 924 496 R p1 0:00 ps axl
0 101 25145 9563 0 0 2964 2360 idetape_rea S p2 0:06 trn
100100 0 10116 9564 0 0 1412 928 setup_frame T p3 0:00 ssh -C www
100100 0 26560 26554 0 0 1076 572 setup_frame T p2 0:00 less
100000 101 19058 9562 0 0 1396 900 setup_frame T p1 0:02 nvi /tmp/a
eval "sub is_desirable { uid < 10 } " . 1;
sub id() { $_->{ID} }
sub title() { $_->{TITLE} }
sub executive() { title =~ /(?:vice-)?president/i }
@slowburners = grep { id < 10 && !executive } @employees;
if ($string =~ /PATTERN/) {
} else {
}
warn "has nondigits" if /\D/;
warn "not a natural number" unless /^\d+$/; warn "not an integer" unless /^-?\d+$/; warn "not an integer" unless /^[+-]?\d+$/;
warn "not a decimal number" unless /^-?\d+\.?\d*$/; warn "not a decimal number" unless /^-?(?:\d+(?:\.\d*)?|\.\d+)$/;
warn "not a C float"
unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
sub getnum {
use POSIX qw(strtod);
my $str = shift;
$str =~ s/^\s+//;
$str =~ s/\s+$//;
$! = 0;
my($num, $unparsed) = strtod($str);
if (($str eq '') || ($unparsed != 0) || $!) {
return;
} else {
return $num;
}
}
sub is_numeric { defined scalar &getnum }
sub equal {
my ($A, $B, $dp) = @_;
return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);
}
$wage = 536; $week = 40 * $wage; printf("One week's wage is: \$%.2f\n", $week/100);
$rounded = sprintf("%FORMATf", $unrounded);
$a = 0.255;
$b = sprintf("%.2f", $a);
print "Unrounded: $a\nRounded: $b\n";
printf "Unrounded: $a\nRounded: %.2f\n", $a;
use POSIX;
print "number\tint\tfloor\tceil\n";
@a = ( 3.3 , 3.5 , 3.7, -3.3 );
foreach (@a) {
printf( "%.1f\t%.1f\t%.1f\t%.1f\n",
$_, int($_), floor($_), ceil($_) );
}
sub dec2bin {
my $str = unpack("B32", pack("N", shift));
$str =~ s/^0+(?=\d)//; return $str;
}
sub bin2dec {
return unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
}
$num = bin2dec('0110110'); $binstr = dec2bin(54);
foreach ($X .. $Y) {
}
foreach $i ($X .. $Y) {
}
for ($i = $X; $i <= $Y; $i++) {
}
for ($i = $X; $i <= $Y; $i += 7) {
}
print "Infancy is: ";
foreach (0 .. 2) {
print "$_ ";
}
print "\n";
print "Toddling is: ";
foreach $i (3 .. 4) {
print "$i ";
}
print "\n";
print "Childhood is: ";
for ($i = 5; $i <= 12; $i++) {
print "$i ";
}
print "\n";
use Roman;
$roman = roman($arabic); $arabic = arabic($roman) if isroman($roman); use Roman;
$roman_fifteen = roman(15); print "Roman for fifteen is $roman_fifteen\n";
$arabic_fifteen = arabic($roman_fifteen);
print "Converted back, $roman_fifteen is $arabic_fifteen\n";
Roman for fifteen is xv
Converted back, xv is 15
$random = int( rand( $Y-$X+1 ) ) + $X;
$random = int( rand(51)) + 25;
print "$random\n";
$elt = $array[ rand @array ];
@chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(! @ $ % ^ & *) );
$password = join("", @chars[ map { rand @chars } ( 1 .. 8 ) ]);
srand EXPR;
srand( <STDIN> );
use Math::TrulyRandom;
$random = truly_random_value();
use Math::Random;
$random = random_uniform();
sub gaussian_rand {
my ($u1, $u2); my $w; my ($g1, $g2);
do {
$u1 = 2 * rand() - 1;
$u2 = 2 * rand() - 1;
$w = $u1*$u1 + $u2*$u2;
} while ( $w >= 1 );
$w = sqrt( (-2 * log($w)) / $w );
$g2 = $u1 * $w;
$g1 = $u2 * $w;
return wantarray ? ($g1, $g2) : $g1;
}
sub weight_to_dist {
my %weights = @_;
my %dist = ();
my $total = 0;
my ($key, $weight);
local $_;
foreach (values %weights) {
$total += $_;
}
while ( ($key, $weight) = each %weights ) {
$dist{$key} = $weight/$total;
}
return %dist;
}
sub weighted_rand {
my %dist = @_;
my ($key, $weight);
while (1) { my $rand = rand;
while ( ($key, $weight) = each %dist ) {
return $key if ($rand -= $weight) < 0;
}
}
}
$mean = 25;
$sdev = 2;
$salary = gaussian_rand() * $sdev + $mean;
printf("You have been hired at \$%.2f\n", $salary);
BEGIN {
use constant PI => 3.14159265358979;
sub deg2rad {
my $degrees = shift;
return ($degrees / 180) * PI;
}
sub rad2deg {
my $radians = shift;
return ($radians / PI) * 180;
}
}
use Math::Trig;
$radians = deg2rad($degrees);
$degrees = rad2deg($radians);
sub degree_sine {
my $degrees = shift;
my $radians = deg2rad($degrees);
my $result = sin($radians);
return $result;
}
sub tan {
my $theta = shift;
return sin($theta)/cos($theta);
}
use POSIX;
$y = acos(3.7);
use Math::Trig;
$y = acos(3.7);
eval {
$y = tan($pi/2);
} or return undef;
$log_e = log(VALUE);
use POSIX qw(log10);
$log_10 = log10(VALUE);
sub log_base {
my ($base, $value) = @_;
return log($value)/log($base);
}
$answer = log_base(10, 10_000);
print "log10(10,000) = $answer\n";
use Math::Complex;
printf "log2(1024) = %lf\n", logn(1024, 2);
use PDL;
$c = $a * $b;
sub mmult {
my ($m1,$m2) = @_;
my ($m1rows,$m1cols) = matdim($m1);
my ($m2rows,$m2cols) = matdim($m2);
unless ($m1cols == $m2rows) { die "IndexError: matrices don't match: $m1cols != $m2rows";
}
my $result = [];
my ($i, $j, $k);
for $i (range($m1rows)) {
for $j (range($m2cols)) {
for $k (range($m1cols)) {
$result->[$i][$j] += $m1->[$i][$k] * $m2->[$k][$j];
}
}
}
return $result;
}
sub range { 0 .. ($_[0] - 1) }
sub veclen {
my $ary_ref = $_[0];
my $type = ref $ary_ref;
if ($type ne "ARRAY") { die "$type is bad array ref for $ary_ref" }
return scalar(@$ary_ref);
}
sub matdim {
my $matrix = $_[0];
my $rows = veclen($matrix);
my $cols = veclen($matrix->[0]);
return ($rows, $cols);
}
use PDL;
$a = pdl [
[ 3, 2, 3 ],
[ 5, 9, 8 ],
];
$b = pdl [
[ 4, 7 ],
[ 9, 3 ],
[ 8, 1 ],
];
$c = $a x $b;
$x = [
[ 3, 2, 3 ],
[ 5, 9, 8 ],
];
$y = [
[ 4, 7 ],
[ 9, 3 ],
[ 8, 1 ],
];
$z = mmult($x, $y);
$c_real = ( $a_real * $b_real ) - ( $a_imaginary * $b_imaginary );
$c_imaginary = ( $a_real * $b_imaginary ) + ( $b_real * $a_imaginary );
use Math::Complex;
$c = $a * $b;
$a_real = 3; $a_imaginary = 5; $b_real = 2; $b_imaginary = -2; $c_real = ( $a_real * $b_real ) - ( $a_imaginary * $b_imaginary );
$c_imaginary = ( $a_real * $b_imaginary ) + ( $b_real * $a_imaginary );
print "c = ${c_real}+${c_imaginary}i\n";
c = 16+4i
use Math::Complex;
$a = Math::Complex->new(3,5); $b = Math::Complex->new(2,-2);
$c = $a * $b;
print "c = $c\n";
c = 16+4i
use Math::Complex;
$c = cplx(3,5) * cplx(2,-2); $d = 3 + 4*i; printf "sqrt($d) = %s\n", sqrt($d);
$number = hex($hexadecimal); $number = oct($octal); print "Gimme a number in decimal, octal, or hex: ";
$num = <STDIN>;
chomp $num;
exit unless defined $num;
$num = oct($num) if $num =~ /^0/; printf "%d %x %o\n", $num, $num, $num;
print "Enter file permission in octal: ";
$permissions = <STDIN>;
die "Exiting ...\n" unless defined $permissions;
chomp $permissions;
$permissions = oct($permissions); print "The decimal value is $permissions\n";
sub commify {
my $text = reverse $_[0];
$text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
return scalar reverse $text;
}
use Math::TrulyRandom;
$hits = truly_random_value(); $output = "Your web page received $hits accesses last month.\n";
print commify($output);
Your web page received -1,740,525,205 accesses last month.
printf "It took %d hour%s\n", $time, $time == 1 ? "" : "s";
printf "%d hour%s %s enough.\n", $time,
$time == 1 ? "" : "s",
$time == 1 ? "is" : "are";
printf "It took %d centur%s", $time, $time == 1 ? "y" : "ies";
sub noun_plural {
local $_ = shift;
s/ss$/sses/ ||
s/([psc]h)$/${1}es/ ||
s/z$/zes/ ||
s/ff$/ffs/ ||
s/f$/ves/ ||
s/ey$/eys/ ||
s/y$/ies/ ||
s/ix$/ices/ ||
s/([sx])$/$1es/ ||
s/$/s/ ||
die "can't get here";
return $_;
}
*verb_singular = \&noun_plural; use Lingua::EN::Inflect qw(PL classical);
classical(1); while (<DATA>) { for (split) { print "One $_, two ", PL($_), ".\n";
}
}
$_ = 'secretary general';
print "One $_, two ", PL($_), ".\n";
use strict;
use integer;
use vars qw{ $opt_b $opt_d };
use Getopt::Std;
@ARGV && getopts('bd') or die "usage: $0 [-b] number ...";
load_biglib() if $opt_b;
ARG: foreach my $orig ( @ARGV ) {
my ($n, $root, %factors, $factor);
$n = $opt_b ? Math::BigInt->new($orig) : $orig;
if ($n + 0 ne $n) { printf STDERR "bignum: %s would become %s\n", $n, $n+0 if $opt_d;
load_biglib();
$n = Math::BigInt->new($orig);
}
printf "%-10s ", $n;
for (my ($i, $sqi) = (2, 4); $sqi <= $n; $sqi += 2 * $i ++ + 1) {
while ($n % $i == 0) {
$n /= $i;
print STDERR "<$i>" if $opt_d;
$factors {$i} ++;
}
}
if ($n != 1 && $n != $orig) { $factors{$n}++ }
if (! %factors) {
print "PRIME\n";
next ARG;
}
for $factor ( sort { $a <=> $b } keys %factors ) {
print "$factor";
if ($factors{$factor} > 1) {
print "**$factors{$factor}";
}
print " ";
}
print "\n";
}
sub load_biglib {
require Math::BigInt;
Math::BigInt->import(); }
$sec
$min
$hours
$mday
$month
$year
$wday
$yday
$isdst
print "Today is day ", (localtime)[7], " of the current year.\n";
use Time::localtime;
$tm = localtime;
print "Today is day ", $tm->yday, " of the current year.\n";
($DAY, $MONTH, $YEAR) = (localtime)[3,4,5];
use Time::localtime;
$tm = localtime;
($DAY, $MONTH, $YEAR) = ($tm->mday, $tm->mon, $tm->year);
($day, $month, $year) = (localtime)[3,4,5];
printf("The current date is %04d %02d %02d\n", $year+1900, $month+1, $day);
($day, $month, $year) = (localtime)[3..5];
use Time::localtime;
$tm = localtime;
printf("The current date is %04d-%02d-%02d\n", $tm->year+1900,
($tm->mon)+1, $tm->mday);
printf("The current date is %04d-%02d-%02d\n",
sub {($_[5]+1900, $_[4]+1, $_[3])}->(localtime));
use POSIX qw(strftime);
print strftime "%Y-%m-%d\n", localtime;
use Time::Local;
$TIME = timelocal($sec, $min, $hours, $mday, $mon, $year);
$TIME = timegm($sec, $min, $hours, $mday, $mon, $year);
use Time::Local;
$time = timelocal($seconds, $minutes, $hours, (localtime)[3,4,5]);
use Time::Local;
$time = timegm($seconds, $minutes, $hours, $day, $month-1, $year-1900);
($seconds, $minutes, $hours, $day_of_month, $month, $year,
$wday, $yday, $isdst) = localtime($time);
use Time::localtime; $tm = localtime($TIME); $seconds = $tm->sec;
($seconds, $minutes, $hours, $day_of_month, $month, $year,
$wday, $yday, $isdst) = localtime($time);
printf("Dateline: %02d:%02d:%02d-%04d/%02d/%02d\n",
$hours, $minutes, $seconds, $year+1900, $month+1,
$day_of_month);
use Time::localtime;
$tm = localtime($time);
printf("Dateline: %02d:%02d:%02d-%04d/%02d/%02d\n",
$tm->hour, $tm->min, $tm->sec, $tm->year+1900,
$tm->mon+1, $tm->mday);
$when = $now + $difference;
$then = $now - $difference;
use Date::Calc qw(Add_Delta_Days);
($y2, $m2, $d2) = Add_Delta_Days($y, $m, $d, $offset);
use Date::Calc qw(Add_Delta_DHMS);
($year2, $month2, $day2, $h2, $m2, $s2) =
Add_Delta_DHMS( $year, $month, $day, $hour, $minute, $second,
$days_offset, $hour_offset, $minute_offset, $second_offset );
$birthtime = 96176750; $interval = 5 + 17 * 60 + 2 * 60 * 60 + 55 * 60 * 60 * 24; $then = $birthtime + $interval;
print "Then is ", scalar(localtime($then)), "\n";
use Date::Calc qw(Add_Delta_DHMS);
($year, $month, $day, $hh, $mm, $ss) = Add_Delta_DHMS(
1973, 1, 18, 3, 45, 50, 55, 2, 17, 5); print "To be precise: $hh:$mm:$ss, $month/$day/$year\n";
use Date::Calc qw(Add_Delta_Days);
($year, $month, $day) = Add_Delta_Days(1973, 1, 18, 55);
print "Nat was 55 days old on: $month/$day/$year\n";
$seconds = $recent - $earlier;
use Date::Calc qw(Delta_Days);
$days = Delta_Days( $year1, $month1, $day1, $year2, $month2, $day2);
use Date::Calc qw(Delta_DHMS);
($days, $hours, $minutes, $seconds) =
Delta_DHMS( $year1, $month1, $day1, $hour1, $minute1, $seconds1, $year2, $month2, $day2, $hour2, $minute2, $seconds2); $bree = 361535725; $nat = 96201950;
$difference = $bree - $nat;
print "There were $difference seconds between Nat and Bree\n";
$seconds = $difference % 60;
$difference = ($difference - $seconds) / 60;
$minutes = $difference % 60;
$difference = ($difference - $minutes) / 60;
$hours = $difference % 24;
$difference = ($difference - $hours) / 24;
$days = $difference % 7;
$weeks = ($difference - $days) / 7;
print "($weeks weeks, $days days, $hours:$minutes:$seconds)\n";
use Date::Calc qw(Delta_Days);
@bree = (1981, 6, 16); @nat = (1973, 1, 18); $difference = Delta_Days(@nat, @bree);
print "There were $difference days between Nat and Bree\n";
use Date::Calc qw(Delta_DHMS);
@bree = (1981, 6, 16, 4, 35, 25); @nat = (1973, 1, 18, 3, 45, 50); @diff = Delta_DHMS(@nat, @bree);
print "Bree came $diff[0] days, $diff[1]:$diff[2]:$diff[3] after Nat\n";
($MONTHDAY, $WEEKDAY, $YEARDAY) = (localtime $DATE)[3,6,7];
$WEEKNUM = int($YEARDAY / 7) + 1;
use Date::Calc qw(Day_of_Week Week_Number Day_of_Year);
$wday = Day_of_Week($year, $month, $day);
$wnum = Week_Number($year, $month, $day);
$dnum = Day_of_Year($year, $month, $day);
use Date::Calc qw(Day_of_Week Week_Number Day_of_Week_to_Text)
$year = 1981;
$month = 6; $day = 16;
$wday = Day_of_Week($year, $month, $day);
print "$month/$day/$year was a ", Day_of_Week_to_Text($wday), "\n";
$wnum = Week_Number($year, $month, $day);
print "in the $wnum week.\n";
use Time::Local;
($yyyy, $mm, $dd) = $date =~ /(\d+)-(\d+)-(\d+)/;
$epoch_seconds = timelocal(0, 0, 0, $dd, $mm, $yyyy);
use Date::Manip qw(ParseDate UnixDate);
$date = ParseDate($string);
if (!$date) {
} else {
@values = UnixDate($date, @formats);
}
use Date::Manip qw(ParseDate UnixDate);
while (<>) {
$date = ParseDate($_);
if (!$date) {
warn "Bad date string: $_\n";
next;
} else {
($year, $month, $day) = UnixDate($date, "%Y", "%m", "%d");
print "Date was $month/$day/$year\n";
}
}
$STRING = localtime($EPOCH_SECONDS);
use POSIX qw(strftime);
$STRING = strftime($FORMAT, $SECONDS, $MINUTES, $HOUR,
$DAY_OF_MONTH, $MONTH, $YEAR, $WEEKDAY,
$YEARDAY, $DST);
use Date::Manip qw(UnixDate);
$STRING = UnixDate($DATE, $FORMAT);
use Time::Local;
$time = timelocal(50, 45, 3, 18, 0, 73);
print "Scalar localtime gives: ", scalar(localtime($time)), "\n";
use POSIX qw(strftime);
use Time::Local;
$time = timelocal(50, 45, 3, 18, 0, 73);
print "strftime gives: ", strftime("%A %D", localtime($time)), "\n";
use Date::Manip qw(ParseDate UnixDate);
$date = ParseDate("18 Jan 1973, 3:45:50");
$datestr = UnixDate($date, "%a %b %e %H:%M:%S %z %Y"); print "Date::Manip gives: $datestr\n";
use Time::HiRes qw(gettimeofday);
$t0 = gettimeofday;
$t1 = gettimeofday;
$elapsed = $t1 - $t0;
use Time::HiRes qw(gettimeofday);
print "Press return when ready: ";
$before = gettimeofday;
$line = <>;
$elapsed = gettimeofday-$before;
print "You took $elapsed seconds.\n";
require 'sys/syscall.ph';
$TIMEVAL_T = "LL";
$done = $start = pack($TIMEVAL_T, ());
print "Press return when ready: ";
syscall(&SYS_gettimeofday, $start, 0) != -1
|| die "gettimeofday: $!";
$line = <>;
syscall(&SYS_gettimeofday, $done, 0) != -1
|| die "gettimeofday: $!";
@start = unpack($TIMEVAL_T, $start);
@done = unpack($TIMEVAL_T, $done);
for ($done[1], $start[1]) { $_ /= 1_000_000 }
$delta_time = sprintf "%.4f", ($done[0] + $done[1] )
-
($start[0] + $start[1] );
print "That took $delta_time seconds\n";
use Time::HiRes qw(gettimeofday);
$size = 500;
$number_of_times = 100;
$total_time = 0;
for ($i = 0; $i < $number_of_times; $i++) {
my (@array, $j, $begin, $time);
@array = ();
for ($j=0; $j<$size; $j++) { push(@array, rand) }
$begin = gettimeofday;
@array = sort { $a <=> $b } @array;
$time = gettimeofday-$begin;
$total_time += $time;
}
printf "On average, sorting %d random numbers takes %.5f seconds\n",
$size, ($total_time/$number_of_times);
select(undef, undef, undef, $time_to_sleep);
use Time::HiRes qw(sleep);
sleep($time_to_sleep);
while (<>) {
select(undef, undef, undef, 0.25);
print;
}
use Time::HiRes qw(sleep);
while (<>) {
sleep(0.25);
print;
}
use Date::Manip qw(ParseDate DateCalc);
$d1 = ParseDate("Tue, 26 May 1998 23:57:38 -0400");
$d2 = ParseDate("Wed, 27 May 1998 05:04:03 +0100");
print DateCalc($d1, $d2);
use strict;
use Date::Manip qw (ParseDate UnixDate);
printf "%-20.20s %-20.20s %-20.20s %s\n",
"Sender", "Recipient", "Time", "Delta";
$/ = ''; $_ = <>; s/\n\s+/ /g;
my($start_from) = /^From.*\@([^\s>]*)/m;
my($start_date) = /^Date:\s+(.*)/m;
my $then = getdate($start_date);
printf "%-20.20s %-20.20s %s\n", 'Start', $start_from, fmtdate($then);
my $prevfrom = $start_from;
for (reverse split(/\n/)) {
my ($delta, $now, $from, $by, $when);
next unless /^Received:/;
s/\bon (.*?) (id.*)/; $1/s; unless (($when) = /;\s+(.*)$/) { warn "bad received line: $_";
next;
}
($from) = /from\s+(\S+)/;
($from) = /\((.*?)\)/ unless $from; $from =~ s/\)$//; ($by) = /by\s+(\S+\.\S+)/;
for ($when) {
s/ (for|via) .*$//;
s/([+-]\d\d\d\d) \(\S+\)/$1/;
s/id \S+;\s*//;
}
next unless $now = getdate($when); $delta = $now - $then;
printf "%-20.20s %-20.20s %s ", $from, $by, fmtdate($now);
$prevfrom = $by;
puttime($delta);
$then = $now;
}
exit;
sub getdate {
my $string = shift;
$string =~ s/\s+\(.*\)\s*$//; my $date = ParseDate($string);
my $epoch_secs = UnixDate($date,"%s");
return $epoch_secs;
}
sub fmtdate {
my $epoch = shift;
my($sec,$min,$hour,$mday,$mon,$year) = localtime($epoch);
return sprintf "%02d:%02d:%02d %04d/%02d/%02d",
$hour, $min, $sec,
$year + 1900, $mon + 1, $mday,
}
sub puttime {
my($seconds) = shift;
my($days, $hours, $minutes);
$days = pull_count($seconds, 24 * 60 * 60);
$hours = pull_count($seconds, 60 * 60);
$minutes = pull_count($seconds, 60);
put_field('s', $seconds);
put_field('m', $minutes);
put_field('h', $hours);
put_field('d', $days);
print "\n";
}
sub pull_count {
my($answer) = int($_[0] / $_[1]);
$_[0] -= $answer * $_[1];
return $answer;
}
sub put_field {
my ($char, $number) = @_;
printf " %3d%s", $number, $char if $number || $char eq 's';
}
@nested = ("this", "that", "the", "other");
@nested = ("this", "that", ("the", "other"));
@tune = ( "The", "Star-Spangled", "Banner" );
@a = ("quick", "brown", "fox");
@a = qw(Why are you teasing me?);
@lines = (<<"END_OF_HERE_DOC" =~ m/^\s*(.+)/gm);
The boy stood on the burning deck,
It was as hot as glass.
END_OF_HERE_DOC@bigarray = ();
open(DATA, "< mydatafile") or die "Couldn't read from datafile: $!\n";
while (<DATA>) {
chomp;
push(@bigarray, $_);
}
$banner = 'The Mines of Moria';
$banner = q(The Mines of Moria);
$name = "Gandalf";
$banner = "Speak, $name, and enter!";
$banner = qq(Speak, $name, and welcome!);
$his_host = 'www.perl.com';
$host_info = `nslookup $his_host`;
$perl_info = qx(ps $$); $shell_info = qx'ps $$'; @banner = ('Costs', 'only', '$4.95');
@banner = qw(Costs only $4.95);
@banner = split(' ', 'Costs only $4.95');
@brax = qw! ( ) < > { } [ ] !;
@rings = qw(Nenya Narya Vilya);
@tags = qw<LI TABLE TR TD A IMG H1 P>;
@sample = qw(The vertical bar (|) looks and behaves like a pipe.);
@banner = qw|The vertical bar (\|) looks and behaves like a pipe.|;
@ships = qw(Niña Pinta Santa María); @ships = ('Niña', 'Pinta', 'Santa María');
sub commify_series {
(@_ == 0) ? '' :
(@_ == 1) ? $_[0] :
(@_ == 2) ? join(" and ", @_) :
join(", ", @_[0 .. ($#_-1)], "and $_[-1]");
}
@array = ("red", "yellow", "green");
print "I have ", @array, " marbles.\n";
print "I have @array marbles.\n";
I have redyellowgreen marbles.
I have red yellow green marbles.
@lists = (
[ 'just one thing' ],
[ qw(Mutt Jeff) ],
[ qw(Peter Paul Mary) ],
[ 'To our parents', 'Mother Theresa', 'God' ],
[ 'pastrami', 'ham and cheese', 'peanut butter and jelly', 'tuna' ],
[ 'recycle tired, old phrases', 'ponder big, happy thoughts' ],
[ 'recycle tired, old phrases',
'ponder big, happy thoughts',
'sleep and dream peacefully' ],
);
foreach $aref (@lists) {
print "The list is: " . commify_series(@$aref) . ".\n";
}
sub commify_series {
my $sepchar = grep(/,/ => @_) ? ";" : ",";
(@_ == 0) ? '' :
(@_ == 1) ? $_[0] :
(@_ == 2) ? join(" and ", @_) :
join("$sepchar ", @_[0 .. ($#_-1)], "and $_[-1]");
}
@ARRAY$#ARRAY = $NEW_LAST_ELEMENT_INDEX_NUMBER;
$ARRAY[$NEW_LAST_ELEMENT_INDEX_NUMBER] = $VALUE;
sub what_about_that_array {
print "The array now has ", scalar(@people), " elements.\n";
print "The index of the last element is $#people.\n";
print "Element #3 is `$people[3]'.\n";
}
@people = qw(Crosby Stills Nash Young);
what_about_that_array();
The array now has 4 elements.
The index of the last element is 3.
Element $#people--;
what_about_that_array();
The array now has 3 elements.
The index of the last element is 2.
Element $#people = 10_000;
what_about_that_array();
The array now has 10001 elements.
The index of the last element is 10000.
Element $people[10_000] = undef;
foreach $item (LIST) {
}
foreach $user (@bad_users) {
complain($user);
}
foreach $var (sort keys %ENV) {
print "$var=$ENV{$var}\n";
}
foreach $user (@all_users) {
$disk_space = get_usage($user); if ($disk_space > $MAX_QUOTA) { complain($user); }
}
foreach (`who`) {
if (/tchrist/) {
print;
}
}
while (<FH>) { chomp; foreach (split) { @_ $_ = reverse; print; }
}
foreach my $item (@array) {
print "i = $item\n";
}
@array = (1,2,3);
foreach $item (@array) {
$item--;
}
print "@array\n";
0 1 2
@a@b@a = ( .5, 3 ); @b =( 0, 1 );
foreach $item (@a, @b) {
$item *= 7;
}
print "@a @b\n";
3.5 21 0 7
foreach ($scalar, @array, @hash{keys %hash}) {
s/^\s+//;
s/\s+$//;
}
for $item (@array) { @array }
for (@array) { @array }
foreach $item (@$ARRAYREF) {
}
for ($i = 0; $i <= $#$ARRAYREF; $i++) {
}
@fruits = ( "Apple", "Blackberry" );
$fruit_ref = \@fruits;
foreach $fruit (@$fruit_ref) {
print "$fruit tastes good in a pie.\n";
}
Apple tastes good in a pie.
Blackberry tastes good in a pie.
for ($i=0; $i <= $#$fruit_ref; $i++) {
print "$fruit_ref->[$i] tastes good in a pie.\n";
}
$namelist{felines} = \@rogue_cats;
foreach $cat ( @{ $namelist{felines} } ) {
print "$cat purrs hypnotically..\n";
}
print "--More--\nYou are controlled.\n";
for ($i=0; $i <= $#{ $namelist{felines} }; $i++) {
print "$namelist{felines}[$i] purrs hypnotically.\n";
}
%seen = ();
@uniq = ();
foreach $item (@list) {
unless ($seen{$item}) {
$seen{$item} = 1;
push(@uniq, $item);
}
}
%seen = ();
foreach $item (@list) {
push(@uniq, $item) unless $seen{$item}++;
}
%seen = ();
foreach $item (@list) {
some_func($item) unless $seen{$item}++;
}
%seen = ();
foreach $item (@list) {
$seen{$item}++;
}
@uniq = keys %seen;
%seen = ();
@uniqu = grep { ! $seen{$_} ++ } @list;
%ucnt = ();
for (`who`) {
s/\s.*\n//; $ucnt{$_}++; }
@users = sort keys %ucnt;
print "users logged in: @users\n";
@A@B%seen = (); @aonly = ();
foreach $item (@B) { $seen{$item} = 1 }
@A@Bforeach $item (@A) {
unless ($seen{$item}) {
%seen@aonly push(@aonly, $item);
}
}
my %seen; my @aonly;
@seen{@B} = ();
foreach $item (@A) {
push(@aonly, $item) unless exists $seen{$item};
}
foreach $item (@A) {
push(@aonly, $item) unless $seen{$item};
$seen{$item} = 1; }
$hash{"key1"} = 1;
$hash{"key2"} = 2;
@hash{"key1", "key2"} = (1,2);
@seen{@B} = ();
@seen{@B} = (1) x @B;
@a = (1, 3, 5, 6, 7, 8);
@b = (2, 3, 5, 7, 9);
@union = @isect = @diff = ();
%union = %isect = ();
%count = ();
foreach $e (@a) { $union{$e} = 1 }
foreach $e (@b) {
if ( $union{$e} ) { $isect{$e} = 1 }
$union{$e} = 1;
}
@union = keys %union;
@isect = keys %isect;
foreach $e (@a, @b) { $union{$e}++ && $isect{$e}++ }
@union = keys %union;
@isect = keys %isect;
foreach $e (@a, @b) { $count{$e}++ }
foreach $e (keys %count) {
push(@union, $e);
if ($count{$e} == 2) {
push @isect, $e;
} else {
push @diff, $e;
}
}
@isect = @diff = @union = ();
foreach $e (@a, @b) { $count{$e}++ }
foreach $e (keys %count) {
push(@union, $e);
push @{ $count{$e} == 2 ? \@isect : \@diff }, $e;
}
push(@ARRAY1, @ARRAY2);
@ARRAY1 = (@ARRAY1, @ARRAY2);
@members = ("Time", "Flies");
@initiates = ("An", "Arrow");
push(@members, @initiates);
@memberssplice(@members, 2, 0, "Like", @initiates);
print "@members\n";
splice(@members, 0, 1, "Fruit");
splice(@members, -2, 2, "A", "Banana");
print "@members\n";
Time Flies Like An Arrow
Fruit Flies Like A Banana
@ARRAY@REVERSED@REVERSED = reverse @ARRAY;
for ($i = $#ARRAY; $i >= 0; $i--) {
$ARRAY}
@ascending = sort { $a cmp $b } @users;
@descending = reverse @ascending;
@descending = sort { $b cmp $a } @users;
@ARRAY@FRONT = splice(@ARRAY, 0, $N);
@END = splice(@ARRAY, -$N);
sub shift2 (\@) {
return splice(@{$_[0]}, 0, 2);
}
sub pop2 (\@) {
return splice(@{$_[0]}, -2);
}
@friends = qw(Peter Paul Mary Jim Tim);
($this, $that) = shift2(@friends);
@friends
@beverages = qw(Dew Jolt Cola Sprite Fresca);
@pair = pop2(@beverages);
$pair$pair@beverages$line[5] = \@list;
@got = pop2( @{ $line[5] } );
my($match, $found, $item);
foreach $item (@array) {
if ($criterion) {
$match = $item; $found = 1;
last;
}
}
if ($found) {
} else {
}
my($i, $match_idx);
for ($i = 0; $i < @array; $i++) {
if ($criterion) {
$match_idx = $i; last;
}
}
if (defined $match_idx) {
$array} else {
}
foreach $employee (@employees) {
if ( $employee->category() eq 'engineer' ) {
$highest_engineer = $employee;
last;
}
}
print "Highest paid engineer is: ", $highest_engineer->name(), "\n";
for ($i = 0; $i < @ARRAY; $i++) {
last if $criterion;
}
if ($i < @ARRAY) {
} else {
}
@MATCHING = grep { TEST ($_) } @LIST;
@matching = ();
foreach (@list) {
push(@matching, $_) if TEST ($_);
}
@bigs = grep { $_ > 1_000_000 } @nums;
@pigs = grep { $users{$_} > 1e7 } keys %users;
@matching = grep { /^gnat / } `who`;
@engineers = grep { $_->position() eq 'Engineer' } @employees;
@secondary_assistance = grep { $_->income >= 26_000 &&
$_->income < 30_000 }
@applicants;
@sorted = sort { $a <=> $b } @unsorted;
@pidsforeach my $pid (sort { $a <=> $b } @pids) {
print "$pid\n";
}
print "Select a process ID to kill:\n";
chomp ($pid = <>);
die "Exiting ... \n" unless $pid && $pid =~ /^\d+$/;
kill('TERM',$pid);
sleep 2;
kill('KILL',$pid);
@descending = sort { $b <=> $a } @unsorted;
package Sort_Subs;
sub revnum { $b <=> $a }
package Other_Pack;
@all = sort Sort_Subs::revnum 4, 19, 8, 3;
@all = sort { $b <=> $a } 4, 19, 8, 3;
@ordered = sort { compare() } @unordered;
@precomputed = map { [compute(),$_] } @unordered;
@ordered_precomputed = sort { $a->[0] <=> $b->[0] } @precomputed;
@ordered = map { $_->[1] } @ordered_precomputed;
@ordered = map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { [compute(), $_] }
@unordered;
@ordered = sort { $a->name cmp $b->name } @employees;
foreach $employee (sort { $a->name cmp $b->name } @employees) {
print $employee->name, " earns \$", $employee->salary, "\n";
}
@sorted_employees = sort { $a->name cmp $b->name } @employees;
foreach $employee (@sorted_employees) {
print $employee->name, " earns \$", $employee->salary, "\n";
}
%bonusforeach $employee (@sorted_employees) {
if ( $bonus{ $employee->ssn } ) {
print $employee->name, " got a bonus!\n";
}
}
@sorted = sort { $a->name cmp $b->name
||
$b->age <=> $a->age } @employees;
use User::pwent qw(getpwent);
@users = ();
while (defined($user = getpwent)) {
push(@users, $user);
}
@users = sort { $a->name cmp $b->name } @users;
foreach $user (@users) {
print $user->name, "\n";
}
@sorted = sort { substr($a,1,1) cmp substr($b,1,1) } @names;
@sorted = sort { length $a <=> length $b } @strings;
@temp = map { [ length $_, $_ ] } @strings;
@temp = sort { $a->[0] <=> $b->[0] } @temp;
@sorted = map { $_->[1] } @temp;
@sorted = map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { [ length $_, $_ ] }
@strings;
@temp = map { [ /(\d+)/, $_ ] } @fields;
@sorted_temp = sort { $a->[0] <=> $b->[0] } @temp;
@sorted_fields = map { $_->[1] } @sorted_temp;
@sorted_fields = map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { [ /(\d+)/, $_ ] }
@fields;
print map { $_->[0] } sort {
$a->[1] <=> $b->[1] ||
$a->[2] <=> $b->[2] ||
$a->[3] cmp $b->[3] }
map { [ $_, (split /:/)[3,2,0] ] }
`cat /etc/passwd`;
unshift(@circular, pop(@circular)); push(@circular, shift(@circular)); sub grab_and_rotate ( \@ ) {
my $listref = shift;
my $element = $listref->[0];
push(@$listref, shift @$listref);
return $element;
}
@processes = ( 1, 2, 3, 4, 5 );
while (1) {
$process = grab_and_rotate(@processes);
print "Handling process $process\n";
sleep 1;
}
@array@arraysub fisher_yates_shuffle {
my $array = shift;
my $i;
for ($i = @$array; --$i; ) {
my $j = int rand ($i+1);
next if $i == $j;
@$array[$i,$j] = @$array[$j,$i];
}
}
fisher_yates_shuffle( \@array ); @array$permutations = factorial( scalar @array );
@shuffle = @array [ n2perm( 1+int(rand $permutations), $#array ) ];
sub naive_shuffle { for (my $i = 0; $i < @_; $i++) {
my $j = int rand @_; ($_[$i], $_[$j]) = ($_[$j], $_[$i]); }
}
awk cp ed login mount rmdir sum
basename csh egrep ls mt sed sync
cat date fgrep mail mv sh tar
chgrp dd grep mkdir ps sort touch
chmod df kill mknod pwd stty vi
chown echo ln more rm su
use strict;
my ($item, $cols, $rows, $maxlen);
my ($xpixel, $ypixel, $mask, @data);
getwinsize();
$maxlen = 1;
while (<>) {
my $mylen;
s/\s+$//;
$maxlen = $mylen if (($mylen = length) > $maxlen);
push(@data, $_);
}
$maxlen += 1;
$cols = int($cols / $maxlen) || 1;
$rows = int(($#data+$cols) / $cols);
$mask = sprintf("%%-%ds ", $maxlen-1);
sub EOL { ($item+1) % $cols == 0 }
for ($item = 0; $item < $rows * $cols; $item++) {
my $target = ($item % $cols) * $rows + int($item/$cols);
my $piece = sprintf($mask, $target < @data ? $data[$target] : "");
$piece =~ s/\s+$// if EOL(); print $piece;
print "\n" if EOL();
}
print "\n" if EOL();
sub getwinsize {
my $winsize = "\0" x 8;
my $TIOCGWINSZ = 0x40087468;
if (ioctl(STDOUT, $TIOCGWINSZ, $winsize)) {
($rows, $cols, $xpixel, $ypixel) = unpack('S4', $winsize);
} else {
$cols = 80;
}
}
use Math::BigInt;
sub factorial {
my $n = shift;
my $s = 1;
$s *= $n-- while $n > 0;
return $s;
}
print factorial(Math::BigInt->new("500"));
+1220136... (1035 digits total)
permute([split], []);
sub permute {
my @items = @{ $_[0] };
my @perms = @{ $_[1] };
unless (@items) {
print "@perms\n";
} else {
my(@newitems,@newperms,$i);
foreach $i (0 .. $#items) {
@newitems = @items;
@newperms = @perms;
unshift(@newperms, splice(@newitems, $i, 1));
permute([@newitems], [@newperms]);
}
}
}
use strict;
while (<>) {
my @data = split;
my $num_permutations = factorial(scalar @data);
for (my $i=0; $i < $num_permutations; $i++) {
my @permutation = @data[n2perm($i, $#data)];
print "@permutation\n";
}
}
BEGIN {
my @fact = (1);
sub factorial($) {
my $n = shift;
return $fact[$n] if defined $fact[$n];
$fact[$n] = $n * factorial($n - 1);
}
}
sub n2pat {
my $i = 1;
my $N = shift;
my $len = shift;
my @pat;
while ($i <= $len + 1) { push @pat, $N % $i;
$N = int($N/$i);
$i++;
}
return @pat;
}
@patsub pat2perm {
my @pat = @_;
my @source = (0 .. $#pat);
my @perm;
push @perm, splice(@source, (pop @pat), 1) while @pat;
return @perm;
}
sub n2perm {
pat2perm(n2pat(@_));
}
%age = ( "Nat", 24,
"Jules", 25,
"Josh", 17 );
$age{"Nat"} = 24;
$age{"Jules"} = 25;
$age{"Josh"} = 17;
%food_color = (
"Apple" => "red",
"Banana" => "yellow",
"Lemon" => "yellow",
"Carrot" => "orange"
);
%food_color = (
Apple => "red",
Banana => "yellow",
Lemon => "yellow",
Carrot => "orange"
);
$HASH{$KEY} = $VALUE;
%food_color$food_color{Raspberry} = "pink";
print "Known foods:\n";
foreach $food (keys %food_color) {
print "$food\n";
}
%HASHif (exists($HASH{$KEY})) {
} else {
}
%food_colorforeach $name ("Banana", "Martini") {
if (exists $food_color{$name}) {
print "$name is a food.\n";
} else {
print "$name is a drink.\n";
}
}
%age = ();
$age{"Toddler"} = 3;
$age{"Unborn"} = 0;
$age{"Phantasm"} = undef;
foreach $thing ("Toddler", "Unborn", "Phantasm", "Relic") {
print "$thing: ";
print "Exists " if exists $age{$thing};
print "Defined " if defined $age{$thing};
print "True " if $age{$thing};
print "\n";
}
%size = ();
while (<>) {
chomp;
next if $size{$_}; $size{$_} = -s $_;
}
next if exists $size{$_};
%HASHdelete($HASH{$KEY});
%food_colorsub print_foods {
my @foods = keys %food_color;
my $food;
print "Keys: @foods\n";
print "Values: ";
foreach $food (@foods) {
my $color = $food_color{$food};
if (defined $color) {
print "$color ";
} else {
print "(undef) ";
}
}
print "\n";
}
print "Initially:\n";
print_foods();
print "\nWith Banana undef\n";
undef $food_color{"Banana"};
print_foods();
print "\nWith Banana deleted\n";
delete $food_color{"Banana"};
print_foods();
delete @food_color{"Banana", "Apple", "Cabbage"};
while(($key, $value) = each(%HASH)) {
}
foreach $key (keys %HASH) {
$value = $HASH{$key};
}
%food_colorwhile(($food, $color) = each(%food_color)) {
print "$food is $color.\n";
}
foreach $food (keys %food_color) {
my $color = $food_color{$food};
print "$food is $color.\n";
}
print
"$food
is
$food_color{$food}.\n"
foreach $food (sort keys %food_color) {
print "$food is $food_color{$food}.\n";
}
while ( ($k,$v) = each %food_color ) {
print "Processing $k\n";
keys %food_color; %food_color}
$filename = $ARGV[0] || "-";
open(FILE, "<$filename") or die "Can't open $filename : $!";
while(<FILE>) {
if (/^From: (.*)/) { $from{$1}++ }
}
foreach $person (sort keys %from) {
print "$person: $from{$person}\n";
}
while ( ($k,$v) = each %hash ) {
print "$k => $v\n";
}
print map { "$_ => $hash{$_}\n" } keys %hash;
print "@{[ %hash ]}\n";
{
my @temp = %hash;
print "@temp";
}
foreach $k (sort keys %hash) {
print "$k => $hash{$k}\n";
}
use Tie::IxHash;
tie %HASH, "Tie::IxHash";
%HASH@keys = keys %HASH; @keysuse Tie::IxHash;
tie %food_color, "Tie::IxHash";
$food_color{Banana} = "Yellow";
$food_color{Apple} = "Green";
$food_color{Lemon} = "Yellow";
print "In insertion order, the foods are:\n";
foreach $food (keys %food_color) {
print " $food\n";
}
print "Still in insertion order, the foods' colors are:\n";
while (( $food, $color ) = each %food_color ) {
print "$food is colored $color.\n";
}
%ttys = ();
open(WHO, "who|") or die "can't open who: $!";
while (<WHO>) {
($user, $tty) = split;
push( @{$ttys{$user}}, $tty );
}
foreach $user (sort keys %ttys) {
print "$user: @{$ttys{$user}}\n";
}
foreach $user (sort keys %ttys) {
print "$user: ", scalar( @{$ttys{$user}} ), " ttys.\n";
foreach $tty (sort @{$ttys{$user}}) {
@stat = stat("/dev/$tty");
$user = @stat ? ( getpwuid($stat[4]) )[0] : "(not available)";
print "\t$tty (owned by $user)\n";
}
}
sub multihash_delete {
my ($hash, $key, $value) = @_;
my $i;
return unless ref( $hash->{$key} );
for ($i = 0; $i < @{ $hash->{$key} }; $i++) {
if ($hash->{$key}->[$i] eq $value) {
splice( @{$hash->{$key}}, $i, 1);
last;
}
}
delete $hash->{$key} unless @{$hash->{$key}};
}
%LOOKUP%REVERSE = reverse %LOOKUP;
%surname = ( "Mickey" => "Mantle", "Babe" => "Ruth" );
%first_name = reverse %surname;
print $first_name{"Mantle"}, "\n";
Mickey
("Mickey", "Mantle", "Babe", "Ruth")
("Ruth", "Babe", "Mantle", "Mickey")
("Ruth" => "Babe", "Mantle" => "Mickey")
$given = shift @ARGV or die "usage: foodfind food_or_color\n";
%color = (
"Apple" => "red",
"Banana" => "yellow",
"Lemon" => "yellow",
"Carrot" => "orange"
);
%food = reverse %color;
if (exists $color{$given}) {
print "$given is a food with color $color{$given}.\n";
}
if (exists $food{$given}) {
print "$food{$given} is a food with color $given.\n";
}
%food_colorwhile (($food,$color) = each(%food_color)) {
push(@{$foods_with_color{$color}}, $food);
}
print "@{$foods_with_color{yellow}} were yellow foods.\n";
%HASH@keys = sort { criterion() } (keys %hash);
foreach $key (@keys) {
$value = $hash{$key};
}
foreach $food (sort keys %food_color) {
print "$food is $food_color{$food}.\n";
}
foreach $food (sort { $food_color{$a} cmp $food_color{$b} }
keys %food_color)
{
print "$food is $food_color{$food}.\n";
}
@foods = sort { length($food_color{$a}) <=> length($food_color{$b}) }
keys %food_color;
foreach $food (@foods) {
print "$food is $food_color{$food}.\n";
}
%merged = (%A, %B);
%merged = ();
while ( ($k,$v) = each(%A) ) {
$merged{$k} = $v;
}
while ( ($k,$v) = each(%B) ) {
$merged{$k} = $v;
}
%food_color%drink_color = ( Galliano => "yellow",
"Mai Tai" => "blue" );
%ingested_color = (%drink_color, %food_color);
%food_color%drink_color = ( Galliano => "yellow",
"Mai Tai" => "blue" );
%substance_color = ();
while (($k, $v) = each %food_color) {
$substance_color{$k} = $v;
}
while (($k, $v) = each %drink_color) {
$substance_color{$k} = $v;
}
foreach $substanceref ( \%food_color, \%drink_color ) {
while (($k, $v) = each %$substanceref) {
$substance_color{$k} = $v;
}
}
foreach $substanceref ( \%food_color, \%drink_color ) {
while (($k, $v) = each %$substanceref) {
if (exists $substance_color{$k}) {
print "Warning: $k seen twice. Using the first definition.\n";
next;
}
$substance_color{$k} = $v;
}
}
@all_colors{keys %new_colors} = values %new_colors;
my @common = ();
foreach (keys %hash1) {
push(@common, $_) if exists $hash2{$_};
}
@commonmy @this_not_that = ();
foreach (keys %hash1) {
push(@this_not_that, $_) unless exists $hash2{$_};
}
%food_color
%citrus_color%citrus_color = ( Lemon => "yellow",
Orange => "orange",
Lime => "green" );
@non_citrus = ();
foreach (keys %food_color) {
push (@non_citrus, $_) unless exists $citrus_color{$_};
}
use Tie::RefHash;
tie %hash, "Tie::RefHash";
%hash use Tie::RefHash;
use IO::File;
tie %name, "Tie::RefHash";
foreach $filename ("/etc/termcap", "/vmunix", "/bin/cat") {
$fh = IO::File->new("< $filename") or next;
$name{$fh} = $filename;
}
print "open files: ", join(", ", values %name), "\n";
foreach $file (keys %name) {
seek($file, 0, 2); printf("%s is %d bytes long.\n", $name{$file}, tell($file));
}
%hashkeys(%hash) = $num;
%userskeys(%users) = 512;
keys(%users) = 1000;
%count = ();
foreach $element (@ARRAY) {
$count{$element}++;
}
%father = ( 'Cain' => 'Adam',
'Abel' => 'Adam',
'Seth' => 'Adam',
'Enoch' => 'Cain',
'Irad' => 'Enoch',
'Mehujael' => 'Irad',
'Methusael' => 'Mehujael',
'Lamech' => 'Methusael',
'Jabal' => 'Lamech',
'Jubal' => 'Lamech',
'Tubalcain' => 'Lamech',
'Enos' => 'Seth' );
while (<>) {
chomp;
do {
print "$_ "; $_ = $father{$_}; } while defined; print "\n";
}
while ( ($k,$v) = each %father ) {
push( @{ $children{$v} }, $k );
}
$" = ', '; while (<>) {
chomp;
if ($children{$_}) {
@children = @{$children{$_}};
} else {
@children = "nobody";
}
print "$_ begat @children.\n";
}
foreach $file (@files) {
local *F; unless (open (F, "<$file")) {
warn "Couldn't read $file: $!; skipping.\n";
next;
}
while (<F>) {
next unless /^\s*#\s*include\s*<([^>]+)>/;
push(@{$includes{$1}}, $file);
}
close F;
}
@include_free = (); @uniq{map { @$_ } values %includes} = undef;
foreach $file (sort keys %uniq) {
push( @include_free , $file ) unless $includes{$file};
}
use strict;
my %Dirsize;
my %Kids;
getdots(my $topdir = input());
output($topdir);
sub input {
my($size, $name, $parent);
@ARGV = ("du @ARGV |"); while (<>) { ($size, $name) = split;
$Dirsize{$name} = $size;
($parent = $name) =~ s#/[^/]+$##; push @{ $Kids{$parent} }, $name unless eof;
}
return $name;
}
sub getdots {
my $root = $_[0];
my($size, $cursize);
$size = $cursize = $Dirsize{$root};
if ($Kids{$root}) {
for my $kid (@{ $Kids{$root} }) {
$cursize -= $Dirsize{$kid};
getdots($kid);
}
}
if ($size != $cursize) {
my $dot = "$root/.";
$Dirsize{$dot} = $cursize;
push @{ $Kids{$root} }, $dot;
}
}
sub output {
my($root, $prefix, $width) = (shift, shift || '', shift || 0);
my $path;
($path = $root) =~ s#.*/##; my $size = $Dirsize{$root};
my $line = sprintf("%${width}d %s", $size, $path);
print $prefix, $line, "\n";
for ($prefix .= $line) { s/\d /| /;
s/[^|]/ /g;
}
if ($Kids{$root}) { my @Kids = @{ $Kids{$root} };
@Kids = sort { $Dirsize{$b} <=> $Dirsize{$a} } @Kids;
$Dirsize{$Kids[0]} =~ /(\d+)/;
my $width = length $1;
for my $kid (@Kids) { output($kid, $prefix, $width) }
}
}
@lines = `du @ARGV`;
chop(@lines);
&input($top = pop @lines);
&output($top);
exit;
sub input {
local($root, *kid, $him) = @_[0,0];
while (@lines && &childof($root, $lines[$#lines])) {
&input($him = pop(@lines));
push(@kid, $him);
i}
if (@kid) {
local($mysize) = ($root =~ /^(\d+)/);
for (@kid) { $mysize -= (/^(\d+)/)[0]; }
push(@kid, "$mysize .") if $size != $mysize;
}
@kid = &sizesort(*kid);
}
sub output {
local($root, *kid, $prefix) = @_[0,0,1];
local($size, $path) = split(' ', $root);
$path =~ s!.*/!!;
$line = sprintf("%${width}d %s", $size, $path);
print $prefix, $line, "\n";
$prefix .= $line;
$prefix =~ s/\d /| /;
$prefix =~ s/[^|]/ /g;
local($width) = $kid[0] =~ /(\d+)/ && length("$1");
for (@kid) { &output($_, $prefix); };
}
sub sizesort {
local(*list, @index) = shift;
sub bynum { $index[$b] <=> $index[$a]; }
for (@list) { push(@index, /(\d+)/); }
@list[sort bynum 0..$#list];
}
sub childof {
local(@pair) = @_;
for (@pair) { s/^\d+\s+//g; s/$/\//; }
index($pair[1], $pair[0]) >= 0;
}
match( $string, $pattern );
subst( $string, $pattern, $replacement );
$meadow =~ m/sheep/; $meadow !~ m/sheep/; $meadow =~ s/old/new/; if ($meadow =~ /\bovines?\b/i) { print "Here be sheep!" }
$string = "good food";
$string =~ s/o*/e/;
while (m/(\d+)/g) {
print "Found number $1\n";
}
@numbers = m/(\d+)/g;
$digits = "123456789";
@nonlap = $digits =~ /(\d\d\d)/g;
@yeslap = $digits =~ /(?=(\d\d\d))/g;
print "Non-overlapping: @nonlap\n";
print "Overlapping: @yeslap\n";
$string = "And little lambs eat ivy";
$string =~ /l[^s]*s/;
print "($`) ($&) ($')\n";
$dst = $src;
$dst =~ s/this/that/;
($dst = $src) =~ s/this/that/;
($progname = $0) =~ s!^.*/!!;
($capword = $word) =~ s/(\w+)/\u\L$1/g;
($catpage = $manpage) =~ s/man(?=\d)/cat/;
@bindirs = qw( /usr/bin /bin /usr/local/bin );
for (@libdirs = @bindirs) { s/bin/lib/ }
print "@libdirs\n";
($a = $b) =~ s/x/y/g; $a = ($b =~ s/x/y/g);
if ($var =~ /^[A-Za-z]+$/) {
}
use locale;
if ($var =~ /^[^\W\d_]+$/) {
print "var is purely alphabetic\n";
}
use locale;
use POSIX 'locale_h';
unless (setlocale(LC_ALL, "fr_CA.ISO8859-1")) {
die "couldn't set locale to French Canadian\n";
}
while (<DATA>) {
chomp;
if (/^[^\W\d_]+$/) {
print "$_: alphabetic\n";
} else {
print "$_: line noise\n";
}
}
use Socket; s{ ( (?: (?! [-_] ) [\w-] + \. ) + [A-Za-z] [\w-] + ) }{ "$1 " . ( ($addr = gethostbyname($1)) ? "[" . inet_ntoa($addr) . "]" : "[???]" )
}gex;
s/ \# (\w+) \# /${$1}/xg; s/ \# (\w+) \# /'$' . $1/xeeg;
$WANT = 3;
$count = 0;
while (/(\w+)\s+fish\b/gi) {
if (++$count == $WANT) {
print "The third fish is a $1 one.\n";
}
}
/(?:\w+\s+fish\s+){2}(\w+)\s+fish/i;
$count = 0;
while ($string =~ /PAT/g) {
$count++; }
$count = 0;
$count++ while $string =~ /PAT/g;
for ($count = 0; $string =~ /PAT/g; $count++) { }
$count++ while $string =~ /(?=PAT)/g;
$pond = 'One fish two fish red fish blue fish';
@colors = ($pond =~ /(\w+)\s+fish\b/gi); $color = $colors[2];
$color = ( $pond =~ /(\w+)\s+fish\b/gi )[2];
print "The third fish in the pond is $color.\n";
$count = 0;
$_ = 'One fish two fish red fish blue fish';
@evens = grep { $count++ % 2 == 1 } /(\w+)\s+fish\b/gi;
print "Even numbered fish are @evens.\n";
$count = 0;
s{
\b ( \w+ ) (
\s+ fish \b
)
}{
if (++$count == 4) {
"sushi" . $2;
} else {
$1 . $2;
}
}gex;
$pond = 'One fish two fish red fish blue fish swim here.';
$color = ( $pond =~ /\b(\w+)\s+fish\b/gi )[-1];
print "Last fish is $color.\n";
m{
A (?! .* A )
$ }x
$pond = 'One fish two fish red fish blue fish swim here.';
if ($pond =~ m{
\b ( \w+) \s+ fish \b
(?! .* \b fish \b )
}six )
{
print "Last fish is $1.\n";
} else {
print "Failed!\n";
}
undef $/; while (<>) { s/<.*?>//gs; print; }
$/ = '';
while ( <> ) { s{
\A ( Chapter \s+ \d+ \s* : . * )
}{<H1>$1</H1>}gx;
print;
}
$/ = ''; while (<ARGV>) {
while (m#^START(.*?)^END#sm) { print "chunk $. in $ARGV has <<$1>>\n";
}
}
undef $/;
@chunks = split(/pattern/, <FILEHANDLE>);
{
local $/ = undef;
@chunks = split(/^\.(Ch|Se|Ss)$/m, <>);
}
print "I read ", scalar(@chunks), " chunks.\n";
while (<>) {
if (/BEGIN PATTERN/ .. /END PATTERN/) {
}
}
while (<>) {
if ($FIRST_LINE_NUM .. $LAST_LINE_NUM) {
}
}
while (<>) {
if (/BEGIN PATTERN/ ... /END PATTERN/) {
}
}
while (<>) {
if ($FIRST_LINE_NUM ... $LAST_LINE_NUM) {
}
}
perl -ne 'print if 15 .. 17' datafile
while (<>) {
print if m#<XMP>#i .. m#</XMP>#i;
}
print if /begin/ .. /end/;
print if /begin/ ... /end/;
while (<>) {
$in_header = 1 .. /^$/;
$in_body = /^$/ .. eof();
}
%seen = ();
while (<>) {
next unless /^From:?\s/i .. /^$/;
while (/([^<>(),;\s]+\@[^<>(),;\s]+)/g) {
print "$1\n" unless $seen{$1}++;
}
}
sub glob2pat {
my $globstr = shift;
my %patmap = (
'*' => '.*',
'?' => '.',
'[' => '[',
']' => ']',
);
$globstr =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
return '^' . $globstr . '$'; }
while ($line = <>) {
if ($line =~ /$pattern/o) {
}
}
@popstates = qw(CO ON MI WI MN);
LINE: while (defined($line = <>)) {
for $state (@popstates) {
if ($line =~ /\b$state\b/) {
print; next LINE;
}
}
}
@popstates = qw(CO ON MI WI MN);
$code = 'while (defined($line = <>)) {';
for $state (@popstates) {
$code .= "\tif (\$line =~ /\\b$state\\b/) { print \$line; next; }\n";
}
$code .= '}';
print "CODE IS\n----\n$code\n----\n" if 0; eval $code;
die if $@;
while (defined($line = <>)) {
if ($line =~ /\bCO\b/) { print $line; next; }
if ($line =~ /\bON\b/) { print $line; next; }
if ($line =~ /\bMI\b/) { print $line; next; }
if ($line =~ /\bWI\b/) { print $line; next; }
if ($line =~ /\bMN\b/) { print $line; next; }
}
@popstates = qw(CO ON MI WI MN);
$expr = join('||', map { "m/\\b\$popstates[$_]\\b/o" } 0..$#popstates);
$match_any = eval "sub { $expr }";
die if $@;
while (<>) {
print if &$match_any;
}
sub {
m/\b$popstates[0]\b/o || m/\b$popstates[1]\b/o ||
m/\b$popstates[2]\b/o || m/\b$popstates[3]\b/o ||
m/\b$popstates[4]\b/o
}
$multimatch = build_match_all(q/Tom/, q/Nat/);
while (<>) {
print if &$multimatch;
}
exit;
sub build_match_any { build_match_func('||', @_) }
sub build_match_all { build_match_func('&&', @_) }
sub build_match_func {
my $condition = shift;
my @pattern = @_; my $expr = join $condition => map { "m/\$pattern[$_]/o" } (0..$#pattern);
my $match_func = eval "sub { local \$_ = shift if \@_; $expr }";
die if $@; return $match_func;
}
use Regexp;
@popstates = qw(CO ON MI WI MN);
@poppats = map { Regexp->new( '\b' . $_ . '\b') } @popstates;
while (defined($line = <>)) {
for $patobj (@poppats) {
print $line if $patobj->match($line);
}
}
do {
print "Pattern? ";
chomp($pat = <>);
eval { "" =~ /$pat/ };
warn "INVALID PATTERN $@" if $@;
} while $@;
sub is_valid_pattern {
my $pat = shift;
return eval { "" =~ /$pat/; 1 } || 0;
}
die "usage: $0 pat [files]\n" unless @ARGV;
$/ = '';
$pat = shift;
eval { "" =~ /$pat/; 1 } or die "$0: Bad pattern $pat: $@\n";
while (<>) {
print "$ARGV $.: $_" if /$pat/o;
}
$pat = "You lose @{[ system('rm -rf *')]} big here";
$safe_pat = quotemeta($pat);
something() if /$safe_pat/;
something() if /\Q$pat/;
use locale;
use locale;
use POSIX 'locale_h';
$name = "andreas k\xF6nig";
@locale{qw(German English)} = qw(de_DE.ISO_8859-1 us-ascii);
setlocale(LC_CTYPE, $locale{English})
or die "Invalid locale $locale{English}";
@english_names = ();
while ($name =~ /\b(\w+)\b/g) {
push(@english_names, ucfirst($1));
}
setlocale(LC_CTYPE, $locale{German})
or die "Invalid locale $locale{German}";
@german_names = ();
while ($name =~ /\b(\w+)\b/g) {
push(@german_names, ucfirst($1));
}
print "English names: @english_names\n";
print "German names: @german_names\n";
English names: Andreas K Nig
German names: Andreas König
use String::Approx qw(amatch);
if (amatch("PATTERN", @list)) {
}
@matches = amatch("PATTERN", @list);
use String::Approx qw(amatch);
open(DICT, "/usr/dict/words") or die "Can't open dict: $!";
while(<DICT>) {
print if amatch("balast");
}
ballast
balustrade
blast
blastula
sandblast
while (/(\d+)/g) {
print "Found $1\n";
}
$n = " 49 here";
$n =~ s/\G /0/g;
print $n;
00049 here
while (/\G,?(\d+)/g) {
print "Found number $1\n";
}
$_ = "The year 1752 lost 10 days on the 3rd of September";
while (/(\d+)/gc) {
print "Found number $1\n";
}
if (/\G(\S+)/g) {
print "Found $1 after the last number.\n";
}
print "The position in \$a is ", pos($a);
pos($a) = 30;
print "The position in \$_ is ", pos;
pos = 30;
s/<.*>//gs;
s/<.*?>//gs; m{ <b><i>(.*?)</i></b> }sx
/BEGIN((?:(?!BEGIN).)*)END/
m{ <b><i>( (?: (?!</b>|</i>). )* ) </i></b> }sx
m{ <b><i>( (?: (?!</[ib]>). )* ) </i></b> }sx
m{
<b><i>
[^<]* (?:
(?! </?[ib]> ) < [^<]* ) *
</i></b>
}sx
$/ = ''; while (<>) {
while ( m{
\b (\S+) \b (
\s+ \1 \b ) + }xig
)
{
print "dup word '$1' at paragraph $.\n";
}
}
This is a test
test of the duplicate word finder.
$a = 'nobody';
$b = 'bodysnatcher';
if ("$a $b" =~ /^(\w+)(\w+) \2(\w+)$/) {
print "$2 overlaps in $1-$2-$3\n";
}
body overlaps in no-body-snatcher
/^(\w+?)(\w+) \2(\w+)$/,
for ($N = ('o' x shift); $N =~ /^(oo+?)\1+$/; $N =~ s/$1/o/g) {
print length($1), " ";
}
print length ($N), "\n";
if (($X, $Y, $Z) =
(('o' x 281) =~ /^(o*)\1{11}(o*)\2{14}(o*)\3{15}$/))
{
($x, $y, $z) = (length($X), length($Y), length($Z));
print "One solution is: x=$x; y=$y; z=$z.\n";
} else {
print "No solution.\n";
}
('o' x 281) =~ /^(o+)\1{11}(o+)\2{14}(o+)\3{15}$/;
('o' x 281) =~ /^(o*?)\1{11}(o*)\2{14}(o*)\3{15}$/;
('o' x 281) =~ /^(o+?)\1{11}(o*)\2{14}(o*)\3{15}$/;
chomp($pattern = <CONFIG_FH>);
if ( $data =~ /$pattern/ ) { ..... }
/ALPHA|BETA/;
/^(?=.*ALPHA)(?=.*BETA)/s;
/ALPHA.*BETA|BETA.*ALPHA/s;
/^(?:(?!PAT).)*$/s;
/(?=^(?:(?!BAD).)*$)GOOD/s;
if (!($string =~ /pattern/)) { something() } if ( $string !~ /pattern/) { something() } if ($string =~ /pat1/ && $string =~ /pat2/ ) {
something
() }
if ($string =~ /pat1/ || $string =~ /pat2/ ) {
something
() }
$pat = shift;
while (<>) {
print if /$pat/o;
}
"labelled" =~ /^(?=.*bell)(?=.*lab)/s
$string =~ /bell/ && $string =~ /lab/
if ($murray_hill =~ m{
^ (?= .* bell ) (?= .* lab )
}sx ) {
print "Looks like Bell Labs might be in Murray Hill!\n";
}
"labelled" =~ /(?:^.*bell.*lab)|(?:^.*lab.*bell)/
$brand = "labelled";
if ($brand =~ m{
(?: ^ .*? bell .*? lab ) | (?: ^ .*? lab .*? bell ) }sx ) {
print "Our brand has bell and lab separate.\n";
}
$map =~ /^(?:(?!waldo).)*$/s
if ($map =~ m{
^ (?: (?! waldo ) . ) * $ }sx ) {
print "There's no waldo here!\n";
}
7:15am up 206 days, 13:30, 4 users, load average: 1.04, 1.07, 1.04
USER TTY FROM LOGIN@ IDLE JCPU PCPU WHAT
tchrist tty1 5:16pm 36days 24:43 0.03s xinit
tchrist tty2 5:19pm 6days 0.43s 0.43s -tcsh
tchrist ttyp0 chthon 7:58am 3days 23.44s 0.44s -tcsh
gnat ttyS4 coprolith 2:01pm 13:36m 0.30s 0.30s -tcsh
m{
^ (?! .* ttyp ) .* tchrist }x
my $eucjp = q{ # EUC-JP encoding subcomponents:
[\x00-\x7F] # ASCII/JIS-Roman (one-byte/character)
| \x8E[\xA0-\xDF] # half-width katakana (two bytes/char)
| \x8F[\xA1-\xFE][\xA1-\xFE] # JIS X 0212-1990 (three bytes/char)
| [\xA1-\xFE][\xA1-\xFE] # JIS X 0208:1997 (two bytes/char)
};
/^ (?: $eucjp )*? \xC5\xEC\xB5\xFE/ox /^ ( (?:eucjp)*? ) $Tokyo/$1$Osaka/ox
/\G ( (?:eucjp)*? ) $Tokyo/$1$Osaka/gox
@chars = /$eucjp/gox; while (<>) {
my @chars = /$eucjp/gox; for my $char (@chars) {
if (length($char) == 1) {
} else {
}
}
my $line = join("",@chars); print $line;
}
$is_eucjp = m/^(?:$eucjp)*$/xo;
$is_eucjp = m/^(?:$eucjp)*$/xo;
$is_sjis = m/^(?:$sjis)*$/xo;
while (<>) {
my @chars = /$eucjp/gox; for my $euc (@chars) {
my $uni = $euc2uni{$char};
if (defined $uni) {
$euc = $uni;
} else {
}
}
my $line = join("",@chars);
print $line;
}
1 while $addr =~ s/\([^()]*\)//g;
Dear someuser@host.com,
Please confirm the mail address you gave us Wed May 6 09:38:41
MDT 1998 by replying to this message. Include the string
"Rumpelstiltskin" in that reply, but spelled in reverse; that is,
start with "Nik...". Once this is done, your confirmed address will
be entered into our records.
chomp($answer = <>);
if ("SEND" =~ /^\Q$answer/i) { print "Action is send\n" }
elsif ("STOP" =~ /^\Q$answer/i) { print "Action is stop\n" }
elsif ("ABORT" =~ /^\Q$answer/i) { print "Action is abort\n" }
elsif ("LIST" =~ /^\Q$answer/i) { print "Action is list\n" }
elsif ("EDIT" =~ /^\Q$answer/i) { print "Action is edit\n" }
use Text::Abbrev;
$href = abbrev qw(send abort list edit);
for (print "Action: "; <>; print "Action: ") {
chomp;
my $action = $href->{ lc($_) };
print "Action is $action\n";
}
$name = 'send';
&$name();
use Text::Abbrev;
my($href, %actions, $errors);
%actions = (
"edit" => \&invoke_editor,
"send" => \&deliver_message,
"list" => sub { system($PAGER, $file) },
"abort" => sub {
print "See ya!\n";
exit;
},
"" => sub {
print "Unknown command: $cmd\n";
$errors++;
},
);
$href = abbrev(keys %actions);
local $_;
for (print "Action: "; <>; print "Action: ") {
s/^\s+//; s/\s+$//; next unless $_;
$actions->{ $href->{ lc($_) } }->();
}
$abbreviation = lc($_);
$expansion = $href->{$abbreviation};
$coderef = $actions->{$expansion};
&$coderef();
$urls = '(http|telnet|gopher|file|wais|ftp)';
$ltrs = '\w';
$gunk = '/#~:.?+=&%@!\-';
$punc = '.:?\-';
$any = "${ltrs}${gunk}${punc}";
while (<>) {
s{
\b ( $urls : [$any] +? ) (?= [$punc]* [^$any] | $ )
}{<A HREF="$1">$1</A>}igox;
print;
}
use strict;
use vars qw($Me $Errors $Grand_Total $Mult %Compress $Matches);
my ($matcher, $opt);
init();
($opt, $matcher) = parse_args();
matchfile($opt, $matcher, @ARGV);
exit(2) if $Errors;
exit(0) if $Grand_Total;
exit(1);
sub init {
($Me = $0) =~ s!.*/!!; $Errors = $Grand_Total = 0; $Mult = ""; @ARGV $| = 1;
%Compress = ( z => 'gzcat', gz => 'gzcat',
Z => 'zcat',
);
}
sub usage {
die <<EOF
usage: $Me [flags] [files]
Standard grep options:
i case insensitive
n number lines
c give count of lines matching
C ditto, but >1 match per line possible
w word boundaries only
s silent mode
x exact matches only
v invert search sense (lines that DON'T match)
h hide filenames
e expression (for exprs beginning with -)
f file with expressions
l list filenames matching
Specials:
1 1 match per file
H highlight matches
u underline matches
r recursive on directories or dot if none
t process directories in 'ls -t' order
p paragraph mode (default: line mode)
P ditto, but specify separator, e.g. -P '%%\\n'
a all files, not just plain text files
q quiet about failed file and dir opens
T trace files as opened
May use a TCGREP environment variable to set default options.
EOF}
sub parse_args {
use Getopt::Std;
my ($optstring, $zeros, $nulls, %opt, $pattern, @patterns, $match_code);
my ($SO, $SE);
if ($_ = $ENV{TCGREP}) { s/^([^\-])/-$1/; unshift(@ARGV, $_); @ARGV }
$optstring = "incCwsxvhe:f:l1HurtpP:aqT";
$zeros = 'inCwxvhelut'; $nulls = 'pP';
@opt{ split //, $zeros } = ( 0 ) x length($zeros);
@opt{ split //, $nulls } = ( '' ) x length($nulls);
getopts($optstring, \%opt) or usage();
if ($opt{f}) { open(PATFILE, $opt{f}) or die qq($Me: Can't open '$opt{f}': $!);
while ( defined($pattern = <PATFILE>) ) {
chomp $pattern;
eval { 'foo' =~ /$pattern/, 1 } or
die "$Me: $opt{f}:$.: bad pattern: $@";
push @patterns, $pattern;
}
close PATFILE;
}
else { $pattern = $opt{e} || shift(@ARGV) || usage();
eval { 'foo' =~ /$pattern/, 1 } or
die "$Me: bad pattern: $@";
@patterns = ($pattern);
}
if ($opt{H} || $opt{u}) { my $term = $ENV{TERM} || 'vt100';
my $terminal;
eval { require POSIX; use Term::Cap;
my $termios = POSIX::Termios->new();
$termios->getattr;
my $ospeed = $termios->getospeed;
$terminal = Tgetent Term::Cap { TERM=>undef, OSPEED=>$ospeed }
};
unless ($@) { local $^W = 0; ($SO, $SE) = $opt{H}
? ($terminal->Tputs('so'), $terminal->Tputs('se'))
: ($terminal->Tputs('us'), $terminal->Tputs('ue'));
}
else { ($SO, $SE) = $opt{H} ? (`tput -T $term smso`, `tput -T $term rmso`)
: (`tput -T $term smul`, `tput -T $term rmul`)
}
}
if ($opt{i}) {
@patterns = map {"(?i)$_"} @patterns;
}
if ($opt{p} || $opt{P}) {
@patterns = map {"(?m)$_"} @patterns;
}
$opt{p} && ($/ = '');
$opt{P} && ($/ = eval(qq("$opt{P}"))); $opt{w} && (@patterns = map {'\b' . $_ . '\b'} @patterns);
$opt{'x'} && (@patterns = map {"^$_\$"} @patterns);
if (@ARGV) {
$Mult = 1 if ($opt{r} || (@ARGV > 1) || -d $ARGV[0]) && !$opt{h};
}
$opt{1} += $opt{l}; $opt{H} += $opt{u};
$opt{c} += $opt{C};
$opt{'s'} += $opt{c};
$opt{1} += $opt{'s'} && !$opt{c};
@ARGV = ($opt{r} ? '.' : '-') unless @ARGV;
$opt{r} = 1 if !$opt{r} && grep(-d, @ARGV) == @ARGV;
$match_code = '';
$match_code .= 'study;' if @patterns > 5;
foreach (@patterns) { s(/)(\\/)g }
if ($opt{H}) {
foreach $pattern (@patterns) {
$match_code .= "\$Matches += s/($pattern)/${SO}\$1${SE}/g;";
}
}
elsif ($opt{v}) {
foreach $pattern (@patterns) {
$match_code .= "\$Matches += !/$pattern/;";
}
}
elsif ($opt{C}) {
foreach $pattern (@patterns) {
$match_code .= "\$Matches++ while /$pattern/g;";
}
}
else {
foreach $pattern (@patterns) {
$match_code .= "\$Matches++ if /$pattern/;";
}
}
$matcher = eval "sub { $match_code }";
die if $@;
return (\%opt, $matcher);
}
sub matchfile {
$opt = shift; $matcher = shift;
my ($file, @list, $total, $name);
local($_);
$total = 0;
FILE: while (defined ($file = shift(@_))) {
if (-d $file) {
if (-l $file && @ARGV != 1) {
warn "$Me: \"$file\" is a symlink to a directory\n"
if $opt->{T};
next FILE;
}
if (!$opt->{r}) {
warn "$Me: \"$file\" is a directory, but no -r given\n"
if $opt->{T};
next FILE;
}
unless (opendir(DIR, $file)) {
unless ($opt->{'q'}) {
warn "$Me: can't opendir $file: $!\n";
$Errors++;
}
next FILE;
}
@list = ();
for (readdir(DIR)) {
push(@list, "$file/$_") unless /^\.{1,2}$/;
}
closedir(DIR);
if ($opt->{t}) {
my (@dates);
for (@list) { push(@dates, -M) }
@list = @list[sort { $dates[$a] <=> $dates[$b] } 0..$#dates];
}
else {
@list = sort @list;
}
matchfile($opt, $matcher, @list); next FILE;
}
if ($file eq '-') {
warn "$Me: reading from stdin\n" if -t STDIN && !$opt->{'q'};
$name = '<STDIN>';
}
else {
$name = $file;
unless (-e $file) {
warn qq($Me: file "$file" does not exist\n) unless $opt->{'q'};
$Errors++;
next FILE;
}
unless (-f $file || $opt->{a}) {
warn qq($Me: skipping non-plain file "$file"\n) if $opt->{T};
next FILE;
}
my ($ext) = $file =~ /\.([^.]+)$/;
if (defined $ext && exists $Compress{$ext}) {
$file = "$Compress{$ext} <$file |";
}
elsif (! (-T $file || $opt->{a})) {
warn qq($Me: skipping binary file "$file"\n) if $opt->{T};
next FILE;
}
}
warn "$Me: checking $file\n" if $opt->{T};
unless (open(FILE, $file)) {
unless ($opt->{'q'}) {
warn "$Me: $file: $!\n";
$Errors++;
}
next FILE;
}
$total = 0;
$Matches = 0;
LINE: while (<FILE>) {
$Matches = 0;
&{$matcher}();
next LINE unless $Matches;
$total += $Matches;
if ($opt->{p} || $opt->{P}) {
s/\n{2,}$/\n/ if $opt->{p};
chomp if $opt->{P};
}
print("$name\n"), next FILE if $opt->{l};
$opt->{'s'} || print $Mult && "$name:",
$opt->{n} ? "$.:" : "",
$_,
($opt->{p} || $opt->{P}) && ('-' x 20) . "\n";
next FILE if $opt->{1}; }
}
continue {
print $Mult && "$name:", $total, "\n" if $opt->{c};
}
$Grand_Total += $total;
}
m/^m*(d?c{0,3}|c[dm])(l?x{0,3}|x[lc])(v?i{0,3}|i[vx])$/i
s/(\S+)(\s+)(\S+)/$3$2$1/
m/(\w+)\s*=\s*(.*)\s*$/ m/.{80,}/
m|(\d+)/(\d+)/(\d+) (\d+):(\d+):(\d+)|
s(/usr/bin)(/usr/local/bin)g
s/%([0-9A-Fa-f][0-9A-Fa-f])/chr hex $1/ge
s{
/\* .*? \*/ } []gsx;
s/^\s+//;
s/\s+$//;
s/\\n/\n/g;
s/^.*:://
m/^([01]?\d\d|2[0-4]\d|25[0-5])\.([01]?\d\d|2[0-4]\d|25[0-5])\.
([01]?\d\d|2[0-4]\d|25[0-5])\.([01]?\d\d|2[0-4]\d|25[0-5])$/;
s(^.*/)()
$cols = ( ($ENV{TERMCAP} || " ") =~ m/:co#(\d+):/ ) ? $1 : 80;
($name = " $0 @ARGV") =~ s, /\S+/, ,g;
die "This isn't Linux" unless $^O =~ m/linux/i;
s/\n\s+/ /g
@nums = m/(\d+\.?\d*|\.\d+)/g;
@capwords = m/(\b[^\Wa-z0-9_]+\b)/g;
@lowords = m/(\b[^\WA-Z0-9_]+\b)/g;
@icwords = m/(\b[^\Wa-z0-9_][^\WA-Z0-9_]*\b)/;
@links = m/<A[^>]+?HREF\s*=\s*["']?([^'" >]+?)[ '"]?>/sig; ($initial) = m/^\S+\s+(\S)\S*\s+\S/ ? $1 : "";
s/"([^"]*)"/``$1''/g { local $/ = "";
while (<>) {
s/\n/ /g;
s/ {3,}/ /g;
push @sentences, m/(\S.*?[!?.])(?= |\Z)/g;
}
}
m/(\d{4})-(\d\d)-(\d\d)/ m/ ^
(?:
1 \s (?: \d\d\d \s)? | \(\d\d\d\) \s | (?: \+\d\d?\d? \s)? \d\d\d ([\s\-]) )
\d\d\d (\s|\1) \d\d\d\d $
/x
m/\boh\s+my\s+gh?o(d(dess(es)?|s?)|odness|sh)\b/i
push(@lines, $1)
while ($input =~ s/^([^\012\015]*)(\012\015?|\015\012?)//);
open(INPUT, "< /usr/local/widgets/data")
or die "Couldn't open /usr/local/widgets/data for reading: $!\n";
while (<INPUT>) {
print if /blue/;
}
close(INPUT);
$var = *STDIN;
mysub($var, *LOGFILE);
use IO::File;
$input = IO::File->new("< /usr/local/widgets/data")
or die "Couldn't open /usr/local/widgets/data for reading: $!\n";
while (defined($line = $input->getline())) {
chomp($line);
STDOUT->print($line) if $line =~ /blue/;
}
$input->close();
while (<STDIN>) { unless (/\d/) {
warn "No digit found.\n"; }
print "Read: ", $_; }
END { close(STDOUT) or die "couldn't close STDOUT: $!" }
open(LOGFILE, "> /tmp/log") or die "Can't write /tmp/log: $!";
close(FH) or die "FH didn't close: $!";
$old_fh = select(LOGFILE); print "Countdown initiated ...\n";
select($old_fh); print "You have 30 seconds to reach minimum safety distance.\n";
open(SOURCE, "< $path")
or die "Couldn't open $path for reading: $!\n";
open(SINK, "> $path")
or die "Couldn't open $path for writing: $!\n";
use Fcntl;
sysopen(SOURCE, $path, O_RDONLY)
or die "Couldn't open $path for reading: $!\n";
sysopen(SINK, $path, O_WRONLY)
or die "Couldn't open $path for writing: $!\n";
use IO::File;
$fh = IO::File->new("> $filename")
or die "Couldn't open $filename for writing: $!\n";
$fh = IO::File->new($filename, O_WRONLY|O_CREAT)
or die "Couldn't open $filename for writing: $!\n";
$fh = IO::File->new($filename, "r+")
or die "Couldn't open $filename for read and write: $!\n";
sysopen(FILEHANDLE, $name, $flags) or die "Can't open $name : $!";
sysopen(FILEHANDLE, $name, $flags, $perms) or die "Can't open $name : $!";
open(FH, "< $path") or die $!;
sysopen(FH, $path, O_RDONLY) or die $!;
open(FH, "> $path") or die $!;
sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT) or die $!;
sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT, 0600) or die $!;
sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT) or die $!;
sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT, 0600) or die $!;
open(FH, ">> $path") or die $!;
sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT) or die $!;
sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT, 0600) or die $!;
sysopen(FH, $path, O_WRONLY|O_APPEND) or die $!;
open(FH, "+< $path") or die $!;
sysopen(FH, $path, O_RDWR) or die $!;
sysopen(FH, $path, O_RDWR|O_CREAT) or die $!;
sysopen(FH, $path, O_RDWR|O_CREAT, 0600) or die $!;
sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT) or die $!;
sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT, 0600) or die $!;
$filename =~ s#^(\s)#./$1#;
open(HANDLE, "< $filename\0") or die "cannot open $filename : $!\n";
sysopen(HANDLE, $filename, O_RDONLY) or die "cannot open $filename: $!\n";
$filename = shift @ARGV;
open(INPUT, $filename) or die "Couldn't open $filename : $!\n";
open(OUTPUT, ">$filename")
or die "Couldn't open $filename for writing: $!\n";
use Fcntl;
sysopen(OUTPUT, $filename, O_WRONLY|O_TRUNC)
or die "Can't open $filename for writing: $!\n";
$file =~ s#^(\s)#./$1#;
open(OUTPUT, "> $file\0")
or die "Couldn't open $file for OUTPUT : $!\n";
$filename =~ s{ ^ ~ ( [^/]* ) }
{ $1
? (getpwnam($1))[7]
: ( $ENV{HOME} || $ENV{LOGDIR}
|| (getpwuid($>))[7]
)
}ex;
open($path, "< $path")
or die "Couldn't open $path for reading : $!\n";
use IO::File;
$fh = IO::File->new_tmpfile
or die "Unable to make new temporary file: $!";
use IO::File;
use POSIX qw(tmpnam);
do { $name = tmpnam() }
until $fh = IO::File->new($name, O_RDWR|O_CREAT|O_EXCL);
END { unlink($name) or die "Couldn't unlink $name : $!" }
for (;;) {
$name = tmpnam();
sysopen(TMP, $tmpnam, O_RDWR | O_CREAT | O_EXCL) && last;
}
unlink $tmpnam;
use IO::File;
$fh = IO::File->new_tmpfile or die "IO::File->new_tmpfile: $!";
$fh->autoflush(1);
print $fh "$i\n" while $i++ < 10;
seek($fh, 0, 0) or die "seek: $!";
print "Tmp file has: ", <$fh>;
while (<DATA>) {
}
while (<main::DATA>) {
}
use POSIX qw(strftime);
$raw_time = (stat(DATA))[9];
$size = -s DATA;
$kilosize = int($size / 1024) . 'k';
print "<P>Script size is $kilosize\n";
print strftime("<P>Last script update: %c (%Z)\n", localtime($raw_time));
while (<>) {
}
while (<>) {
}
unshift(@ARGV, '-') unless @ARGV;
while ($ARGV = shift @ARGV) {
unless (open(ARGV, $ARGV)) {
warn "Can't open $ARGV: $!\n";
next;
}
while (defined($_ = <ARGV>)) {
}
}
@ARGV = glob("*.[Cch]") unless @ARGV;
if (@ARGV && $ARGV[0] eq '-c') {
$chop_first++;
shift;
}
if (@ARGV && $ARGV[0] =~ /^-(\d+)$/) {
$columns = $1;
shift;
}
while (@ARGV && $ARGV[0] =~ /^-(.+)/ && (shift, ($_ = $1), 1)) {
next if /^$/;
s/a// && (++$append, redo);
s/i// && (++$ignore_ints, redo);
s/n// && (++$nostdout, redo);
s/u// && (++$unbuffer, redo);
die "usage: $0 [-ainu] [filenames] ...\n";
}
undef $/;
while (<>) {
}
{ local $/; while (<>) {
}
} while (<>) {
print "$ARGV:$.:$_";
close ARGV if eof;
}
while (<>) { print if /login/;
}
print if /login/;
use locale;
while (<>) { s/([^\W0-9_])/\l$1/g; print;
}
use locale;
s/([^\W0-9_])/\l$1/g;
for (split /\W+/) {
next LINE if /^#/;
close ARGV if /_ _(DATA|END)_ _/;
$chunks++;
}
END { print "Found $chunks chunks\n" }
open(OLD, "< $old") or die "can't open $old: $!";
open(NEW, "> $new") or die "can't open $new: $!";
while (<OLD>) {
print NEW $_ or die "can't write $new: $!";
}
close(OLD) or die "can't close $old: $!";
close(NEW) or die "can't close $new: $!";
rename($old, "$old.orig") or die "can't rename $old to $old.orig: $!";
rename($new, $old) or die "can't rename $new to $old: $!";
while (<OLD>) {
if ($. == 20) {
print NEW "Extra line 1\n";
print NEW "Extra line 2\n";
}
print NEW $_;
}
while (<OLD>) {
next if 20 .. 30;
print NEW $_;
}
while (<>) {
if ($ARGV ne $oldargv) { rename($ARGV, $ARGV . '.orig');
open(ARGVOUT, ">$ARGV"); select(ARGVOUT);
$oldargv = $ARGV;
}
s/DATE/localtime/e;
}
continue{
print;
}
select (STDOUT); hervarlocal $^I = '.orig'; local @ARGV = glob("*.c"); while (<>) {
if ($. == 1) {
print "This line should appear at the top of each file\n";
}
s/\b(p)earl\b/${1}erl/ig; print;
} continue {close ARGV if eof}
open(FH, "+< FILE") or die "Opening: $!";
@ARRAY = <FH>;
seek(FH,0,0) or die "Seeking: $!";
print FH @ARRAY or die "Printing: $!";
truncate(FH,tell(FH)) or die "Truncating: $!";
close(FH) or die "Closing: $!";
open(F, "+< $infile") or die "can't read $infile: $!";
$out = '';
while (<F>) {
s/DATE/localtime/eg;
$out .= $_;
}
seek(F, 0, 0) or die "can't seek to start of $infile: $!";
print F $out or die "can't print to $infile: $!";
truncate(F, tell(F)) or die "can't truncate $infile: $!";
close(F) or die "can't close $infile: $!";
open(FH, "+< $path") or die "can't open $path: $!";
flock(FH, 2) or die "can't flock $path: $!";
close(FH) or die "can't close $path: $!";
sub LOCK_SH() { 1 } sub LOCK_EX() { 2 } sub LOCK_NB() { 4 } sub LOCK_UN() { 8 } unless (flock(FH, LOCK_EX|LOCK_NB)) {
warn "can't immediately write-lock the file ($!), blocking ...";
unless (flock(FH, LOCK_EX)) {
die "can't get write-lock on numfile: $!";
}
}
if ($] < 5.004) { my $old_fh = select(FH);
local $| = 1; local $\ = ''; print ""; select($old_fh); }
flock(FH, LOCK_UN);
use Fcntl qw(:DEFAULT :flock);
sysopen(FH, "numfile", O_RDWR|O_CREAT)
or die "can't open numfile: $!";
flock(FH, LOCK_EX) or die "can't write-lock numfile: $!";
$num = <FH> || 0; seek(FH, 0, 0) or die "can't rewind numfile : $!";
truncate(FH, 0) or die "can't truncate numfile: $!";
print FH $num+1, "\n" or die "can't write numfile: $!";
close(FH) or die "can't close numfile: $!";
$old_fh = select(OUTPUT_HANDLE);
$| = 1;
select($old_fh);
use IO::Handle;
OUTPUT_HANDLE->autoflush(1);
$| = (@ARGV > 0); print "Now you don't see it...";
sleep 2;
print "now you do\n";
select((select(OUTPUT_HANDLE), $| = 1)[0]);
use FileHandle;
STDERR->autoflush; $filehandle->autoflush(0);
use IO::Handle;
autoflush REMOTE_CONN 1; autoflush DISK_FILE 0; use IO::Socket;
$sock = new IO::Socket::INET (PeerAddr => 'www.perl.com',
PeerPort => 'http(80)');
die "Couldn't create socket: $@" unless $sock;
$sock->autoflush(1);
$sock->print("GET /index.html http/1.1\n\n");
$document = join('', $sock->getlines());
print "DOC IS: $document\n";
$rin = '';
vec($rin, fileno(FH1), 1) = 1;
vec($rin, fileno(FH2), 1) = 1;
vec($rin, fileno(FH3), 1) = 1;
$nfound = select($rout=$rin, undef, undef, 0);
if ($nfound) {
if (vec($rout,fileno(FH1),1)) {
}
if (vec($rout,fileno(FH2),1)) {
}
if (vec($rout,fileno(FH3),1)) {
}
}
use IO::Select;
$select = IO::Select->new();
$select->add(*FILEHANDLE);
if (@ready = $select->can_read(0)) {
@ready}
$rin = '';
vec($rin, fileno(FILEHANDLE), 1) = 1;
$nfound = select($rin, undef, undef, 0); if ($nfound) {
$line = <FILEHANDLE>;
print "I read $line";
}
use Fcntl;
sysopen(MODEM, "/dev/cua0", O_NONBLOCK|O_RDWR)
or die "Can't open modem: $!\n";
use Fcntl;
$flags = '';
fcntl(HANDLE, F_GETFL, $flags)
or die "Couldn't get flags for HANDLE : $!\n";
$flags |= O_NONBLOCK;
fcntl(HANDLE, F_SETFL, $flags)
or die "Couldn't set flags for HANDLE: $!\n";
use POSIX qw(:errno_h);
$rv = syswrite(HANDLE, $buffer, length $buffer);
if (!defined($rv) && $! == EAGAIN) {
} elsif ($rv != length $buffer) {
} else {
}
$rv = sysread(HANDLE, $buffer, $BUFSIZ);
if (!defined($rv) && $! == EAGAIN) {
} else {
}
$size = pack("L", 0);
ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n";
$size = unpack("L", $size);
require 'sys/ioctl.ph';
$size = pack("L", 0);
ioctl(FH, FIONREAD(), $size) or die "Couldn't call ioctl: $!\n";
$size = unpack("L", $size);
$FIONREAD = 0x4004667f;
$size = pack("L", 0);
ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n";
$size = unpack("L", $size);
$variable = *FILEHANDLE; subroutine(*FILEHANDLE);
sub subroutine {
my $fh = shift;
print $fh "Hello, filehandle!\n";
}
use FileHandle; $fh = FileHandle->new();
use IO::File; $fh = IO::File->new();
$fh_a = IO::File->new("< /etc/motd") or die "open /etc/motd: $!";
$fh_b = *STDIN;
some_sub($fh_a, $fh_b);
sub return_fh { local *FH; return *FH;
}
$handle = return_fh();
sub accept_fh {
my $fh = shift;
print $fh "Sending to indirect filehandle\n";
}
sub accept_fh {
local *FH = shift;
print FH "Sending to localized filehandle\n";
}
accept_fh(*STDOUT);
accept_fh($handle);
@fd = (*STDIN, *STDOUT, *STDERR);
print $fd[1] "Type it: "; $got = <$fd[0]> print $fd[2] "What was that: $got"; print { $fd[1] } "funny stuff\n";
printf { $fd[1] } "Pity the poor %x.\n", 3_735_928_559;
Pity the poor deadbeef.
$ok = -x "/bin/cat";
print { $ok ? $fd[1] : $fd[2] } "cat stat $ok\n";
print { $fd[ 1 + ($ok || 0) ] } "cat stat $ok\n";
$got = readline($fd[0]);
use FileCache;
cacheout ($path); print $path "output";
use FileCache;
$outdir = '/var/log/ftp/by-user';
while (<>) {
unless (defined ($user = (split)[-4])) {
warn "Invalid line: $.\n";
next;
}
$path = "$outdir/$user";
cacheout $path;
print $path $_;
}
foreach $filehandle (@FILEHANDLES) {
print $filehandle $stuff_to_print;
}
open(MANY, "| tee file1 file2 file3 > /dev/null") or die $!;
print MANY "data\n" or die $!;
close(MANY) or die $!;
for $fh ('FH1', 'FH2', 'FH3') { print $fh "whatever\n" }
for $fh (*FH1, *FH2, *FH3) { print $fh "whatever\n" }
open (FH, "| tee file1 file2 file3 >/dev/null");
print FH "whatever\n";
open (STDOUT, "| tee file1 file2 file3") or die "Teeing off: $!\n";
print "whatever\n" or die "Writing: $!\n";
close(STDOUT) or die "Closing: $!\n";
open(FH, "<&=$FDNUM"); open(FH, "<&$FDNUM");
use IO::Handle;
$fh->fdopen($FDNUM, "r"); use IO::Handle;
$fh = IO::Handle->new();
$fh->fdopen(3, "r"); $fd = $ENV{MHCONTEXTFD};
open(MHCONTEXT, "<&=$fd") or die "couldn't fdopen $fd: $!";
close(MHCONTEXT) or die "couldn't close context file: $!";
*ALIAS = *ORIGINAL;
open(OUTCOPY, ">&STDOUT") or die "Couldn't dup STDOUT: $!";
open(INCOPY, "<&STDIN" ) or die "Couldn't dup STDIN : $!";
open(OUTALIAS, ">&=STDOUT") or die "Couldn't alias STDOUT: $!";
open(INALIAS, "<&=STDIN") or die "Couldn't alias STDIN : $!";
open(BYNUMBER, ">&=5") or die "Couldn't alias file descriptor 5: $!";
open(OLDOUT, ">&STDOUT");
open(OLDERR, ">&STDERR");
open(STDOUT, "> /tmp/program.out") or die "Can't redirect stdout: $!";
open(STDERR, ">&STDOUT") or die "Can't dup stdout: $!";
system($joe_random_program);
close(STDOUT) or die "Can't close STDOUT: $!";
close(STDERR) or die "Can't close STDERR: $!";
open(STDERR, ">&OLDERR") or die "Can't restore stderr: $!";
open(STDOUT, ">&OLDOUT") or die "Can't restore stdout: $!";
close(OLDOUT) or die "Can't close OLDOUT: $!";
close(OLDERR) or die "Can't close OLDERR: $!";
use strict;
use File::LockDir;
$SIG{INT} = sub { die "outta here\n" };
$File::LockDir::Debug = 1;
my $path = shift or die "usage: $0 <path>\n";
unless (nflock($path, 2)) {
die "couldn't lock $path in 2 seconds\n";
}
sleep 100;
nunflock($path);
package File::LockDir;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(nflock nunflock);
use vars qw($Debug $Check);
$Debug ||= 0; $Check ||= 5;
use Cwd;
use Fcntl;
use Sys::Hostname;
use File::Basename;
use File::stat;
use Carp;
my %Locked_Files = ();
sub nflock($;$) {
my $pathname = shift;
my $naptime = shift || 0;
my $lockname = name2lock($pathname);
my $whosegot = "$lockname/owner";
my $start = time();
my $missed = 0;
local *OWNER;
if ($Locked_Files{$pathname}) {
carp "$pathname already locked";
return 1
}
if (!-w dirname($pathname)) {
croak "can't write to directory of $pathname";
}
while (1) {
last if mkdir($lockname, 0777);
confess "can't get $lockname: $!" if $missed++ > 10
&& !-d $lockname;
if ($Debug) {{
open(OWNER, "< $whosegot") || last; my $lockee = <OWNER>;
chomp($lockee);
printf STDERR "%s $0\[$$]: lock on %s held by %s\n",
scalar(localtime), $pathname, $lockee;
close OWNER;
}}
sleep $Check;
return if $naptime && time > $start+$naptime;
}
sysopen(OWNER, $whosegot, O_WRONLY|O_CREAT|O_EXCL)
or croak "can't create $whosegot: $!";
printf OWNER "$0\[$$] on %s since %s\n",
hostname(), scalar(localtime);
close(OWNER)
or croak "close $whosegot: $!";
$Locked_Files{$pathname}++;
return 1;
}
sub nunflock($) {
my $pathname = shift;
my $lockname = name2lock($pathname);
my $whosegot = "$lockname/owner";
unlink($whosegot);
carp "releasing lock on $lockname" if $Debug;
delete $Locked_Files{$pathname};
return rmdir($lockname);
}
sub name2lock($) {
my $pathname = shift;
my $dir = dirname($pathname);
my $file = basename($pathname);
$dir = getcwd() if $dir eq '.';
my $lockname = "$dir/$file.LOCKDIR";
return $lockname;
}
END {
for my $pathname (keys %Locked_Files) {
my $lockname = name2lock($pathname);
my $whosegot = "$lockname/owner";
carp "releasing forgotten $lockname";
unlink($whosegot);
return rmdir($lockname);
}
}
1;
4: 18584 was just here
29: 24652 ZAPPED 24656
use strict;
my $FORKS = shift || 1;
my $SLEEP = shift || 1;
use Fcntl;
use POSIX qw(:unistd_h :errno_h);
my $COLS = 80;
my $ROWS = 23;
open(FH, "+> /tmp/lkscreen") or die $!;
select(FH);
$| = 1;
select STDOUT;
for (1 .. $ROWS) {
print FH " " x $COLS, "\n";
}
my $progenitor = $$;
fork while $FORKS-- > 0;
print "hello from $$\n";
if ($progenitor == $$) {
$SIG{INT} = \&genocide;
} else {
$SIG{INT} = sub { die "goodbye from $$" };
}
while (1) {
my $line_num = int rand($ROWS);
my $line;
my $n;
seek(FH, $n = $line_num * ($COLS+1), SEEK_SET) or next;
my $place = tell(FH);
my $him;
next unless defined($him = lock(*FH, $place, $COLS));
read(FH, $line, $COLS) == $COLS or next;
my $count = ($line =~ /(\d+)/) ? $1 : 0;
$count++;
seek(FH, $place, 0) or die $!;
my $update = sprintf($him
? "%6d: %d ZAPPED %d"
: "%6d: %d was just here",
$count, $$, $him);
my $start = int(rand($COLS - length($update)));
die "XXX" if $start + length($update) > $COLS;
printf FH "%*.*s\n", -$COLS, $COLS, " " x $start . $update;
unlock(*FH, $place, $COLS);
sleep $SLEEP if $SLEEP;
}
die "NOT REACHED";
sub lock {
my ($fh, $start, $till) = @_;
my $lock = struct_flock(F_WRLCK, SEEK_SET, $start, $till, 0);
my $blocker = 0;
unless (fcntl($fh, F_SETLK, $lock)) {
die "F_SETLK $$ @_: $!" unless $! == EAGAIN || $! == EDEADLK;
fcntl($fh, F_GETLK, $lock) or die "F_GETLK $$ @_: $!";
$blocker = (struct_flock($lock))[-1];
@_: $lock = struct_flock(F_WRLCK, SEEK_SET, $start, $till, 0);
unless (fcntl($fh, F_SETLKW, $lock)) {
warn "F_SETLKW $$ @_: $!\n";
return; }
}
return $blocker;
}
sub unlock {
my ($fh, $start, $till) = @_;
my $lock = struct_flock(F_UNLCK, SEEK_SET, $start, $till, 0);
fcntl($fh, F_SETLK, $lock) or die "F_UNLCK $$ @_: $!";
}
BEGIN {
my $FLOCK_STRUCT = 's s l l i';
sub linux_flock {
if (wantarray) {
my ($type, $whence, $start, $len, $pid) =
unpack($FLOCK_STRUCT, $_[0]);
return ($type, $whence, $start, $len, $pid);
} else {
my ($type, $whence, $start, $len, $pid) = @_;
return pack($FLOCK_STRUCT,
$type, $whence, $start, $len, $pid);
}
}
}
BEGIN {
my $FLOCK_STRUCT = 's s l l s s';
sub sunos_flock {
if (wantarray) {
my ($type, $whence, $start, $len, $pid, $xxx) =
unpack($FLOCK_STRUCT, $_[0]);
return ($type, $whence, $start, $len, $pid);
} else {
my ($type, $whence, $start, $len, $pid) = @_;
return pack($FLOCK_STRUCT,
$type, $whence, $start, $len, $pid, 0);
}
}
}
BEGIN {
my $FLOCK_STRUCT = 'll ll i s s';
sub bsd_flock {
if (wantarray) {
my ($xxstart, $start, $xxlen, $len, $pid, $type, $whence) =
unpack($FLOCK_STRUCT, $_[0]);
return ($type, $whence, $start, $len, $pid);
} else {
my ($type, $whence, $start, $len, $pid) = @_;
my ($xxstart, $xxlen) = (0,0);
return pack($FLOCK_STRUCT,
$xxstart, $start, $xxlen, $len, $pid, $type, $whence);
}
}
}
BEGIN {
for ($^O) {
*struct_flock = do {
/bsd/ && \&bsd_flock
||
/linux/ && \&linux_flock
||
/sunos/ && \&sunos_flock
||
die "unknown operating system $^O, bailing out";
};
}
}
BEGIN {
my $called = 0;
sub genocide {
exit if $called++;
print "$$: Time to die, kiddies.\n" if $$ == $progenitor;
my $job = getpgrp();
$SIG{INT} = 'IGNORE';
kill -2, $job if $job; 1 while wait > 0;
print "$$: My turn\n" if $$ == $progenitor;
exit;
}
}
END { &genocide }
while (defined ($line = <DATAFILE>)) {
chomp $line;
$size = length $line;
print "$size\n"; }
while (<DATAFILE>) {
chomp;
print length, "\n"; }
@lines = <DATAFILE>;
undef $/;
$whole_file = <FILE>; print HANDLE "One", "two", "three"; print "Baa baa black sheep.\n"; $rv = read(HANDLE, $buffer, 4096)
or die "Couldn't read from HANDLE : $!\n";
truncate(HANDLE, $length)
or die "Couldn't truncate: $!\n";
truncate("/tmp/$$.pid", $length)
or die "Couldn't truncate: $!\n";
$pos = tell(DATAFILE);
print "I'm $pos bytes from the start of DATAFILE.\n";
seek(LOGFILE, 0, 2) or die "Couldn't seek to the end: $!\n";
seek(DATAFILE, $pos, 0) or die "Couldn't seek to $pos: $!\n";
seek(OUT, -20, 1) or die "Couldn't seek back 20 bytes: $!\n";
$written = syswrite(DATAFILE, $mystring, length($mystring));
die "syswrite failed: $!\n" unless $written == length($mystring);
$read = sysread(INFILE, $block, 256, 5);
warn "only read $read bytes, not 256" if 256 != $read;
$pos = sysseek(HANDLE, 0, 1); die "Couldn't sysseek: $!\n" unless defined $pos;
while (defined($line = <FH>) ) {
chomp $line;
if ($line =~ s/\\$//) {
$line .= <FH>;
redo unless eof(FH);
}
}
if ($line =~ s/\\\s*$//) {
}
$count = `wc -l < $file`;
die "wc failed: $?" if $?;
chomp($count);
open(FILE, "< $file") or die "can't open $file: $!";
$count++ while <FILE>;
$count += tr/\n/\n/ while sysread(FILE, $_, 2 ** 16);
open(FILE, "< $file") or die "can't open $file: $!";
$count++ while <FILE>;
open(FILE, "< $file") or die "can't open $file: $!";
for ($count=0; <FILE>; $count++) { }
1 while <FILE>;
$count = $.;
$/ = ''; open(FILE, $file) or die "can't open $file: $!";
1 while <FILE>;
$para_count = $.;
while (<>) {
for $chunk (split) {
}
}
while (<>) {
while ( /(\w[\w'-]*)/g ) { }
}
%seen = ();
while (<>) {
while ( /(\w['\w-]*)/g ) { $seen{lc $1}++;
}
}
foreach $word ( sort { $seen{$b} <=> $seen{$a} } keys %seen) {
printf "%5d %s\n", $seen{$word}, $word;
}
%seen = ();
while (<>) {
$seen{lc $_}++;
}
foreach $line ( sort { $seen{$b} <=> $seen{$a} } keys %seen ) {
printf "%5d %s", $seen{$line}, $line;
}
@lines = <FILE>;
while ($line = pop @lines) {
}
@lines = reverse <FILE>;
foreach $line (@lines) {
}
for ($i = $#lines; $i != -1; $i--) {
$line = $lines[$i];
}
{
local $/ = '';
@paragraphs = reverse <FILE>;
}
foreach $paragraph (@paragraphs) {
}
for (;;) {
while (<FH>) { .... }
sleep $SOMETIME;
seek(FH, 0, 1);
}
use IO::Seekable;
for (;;) {
while (<FH>) { .... }
sleep $SOMETIME;
FH->clearerr();
}
$naptime = 1;
use IO::Handle;
open (LOGFILE, "/tmp/logfile") or die "can't open /tmp/logfile: $!";
for (;;) {
while (<LOGFILE>) { print } sleep $naptime;
LOGFILE->clearerr(); }
for (;;) {
for ($curpos = tell(LOGFILE); <LOGFILE>; $curpos = tell(LOGFILE)) {
}
sleep $naptime;
seek(LOGFILE, $curpos, 0); }
exit if (stat(LOGFILE))[3] == 0
use File::stat;
exit if stat(*LOGFILE)->nlink == 0;
srand;
rand($.) < 1 && ($line = $_) while <>;
$/ = "%%\n";
@ARGV = qw( /usr/share/games/fortunes );
srand;
rand($.) < 1 && ($adage = $_) while <>;
print $adage;
while (<INPUT>) {
push(@lines, $_);
}
@reordered = shuffle(@lines);
foreach (@reordered) {
print OUTPUT $_;
}
$. = 0;
do { $LINE = <HANDLE> } until $. == $DESIRED_LINE_NUMBER || eof;
@lines = <HANDLE>;
$LINE = $lines[$DESIRED_LINE_NUMBER];
sub build_index {
my $data_file = shift;
my $index_file = shift;
my $offset = 0;
while (<$data_file>) {
print $index_file pack("N", $offset);
$offset = tell($data_file);
}
}
sub line_with_index {
my $data_file = shift;
my $index_file = shift;
my $line_number = shift;
my $size; my $i_offset; my $entry; my $d_offset;
$size = length(pack("N", 0));
$i_offset = $size * ($line_number-1);
seek($index_file, $i_offset, 0) or return;
read($index_file, $entry, $size);
$d_offset = unpack("N", $entry);
seek($data_file, $d_offset, 0);
return scalar(<$data_file>);
}
open(FILE, "< $file") or die "Can't open $file for reading: $!\n";
open(INDEX, "+>$file.idx")
or die "Can't open $file.idx for read/write: $!\n";
build_index(*FILE, *INDEX);
$line = line_with_index(*FILE, *INDEX, $seeking);
use DB_File;
use Fcntl;
$tie = tie(@lines, $FILE, "DB_File", O_RDWR, 0666, $DB_RECNO) or die
"Cannot open file $FILE: $!\n";
$line = $lines[$sought - 1];
@ARGV == 2 or die "usage: print_line FILENAME LINE_NUMBER\n";
($filename, $line_number) = @ARGV;
open(INFILE, "< $filename") or die "Can't open $filename for reading: $!\n";
while (<INFILE>) {
$line = $_;
last if $. == $line_number;
}
if ($. != $line_number) {
die "Didn't find line $line_number in $filename\n";
}
print;
@ARGV == 2 or
die "usage: print_line FILENAME LINE_NUMBER";
($filename, $line_number) = @ARGV;
open(ORIG, "< $filename")
or die "Can't open $filename for reading: $!";
$indexname = "$filename.index";
sysopen(IDX, $indexname, O_CREAT|O_RDWR)
or die "Can't open $indexname for read/write: $!";
build_index(*ORIG, *IDX) if -z $indexname;
$line = line_with_index(*ORIG, *IDX, $line_number);
die "Didn't find line $line_number in $filename" unless defined $line;
print $line;
use DB_File;
use Fcntl;
@ARGV == 2 or
die "usage: print_line FILENAME LINE_NUMBER\n";
($filename, $line_number) = @ARGV;
$tie = tie(@lines, "DB_File", $filename, O_RDWR, 0666, $DB_RECNO)
or die "Cannot open file $filename: $!\n";
unless ($line_number < $tie->length) {
die "Didn't find line $line_number in $filename\n"
}
print $lines[$line_number-1];
@FIELDS@FIELDS = split(/PATTERN/, $RECORD);
split(/([+-])/, "3+5-2");
(3, '+', 5, '-', 2)
@fields = split(/:/, $RECORD);
@fields = split(/\s+/, $RECORD);
@fields = split(" ", $RECORD);
open (FH, "+< $file") or die "can't update $file: $!";
while ( <FH> ) {
$addr = tell(FH) unless eof(FH);
}
truncate(FH, $addr) or die "can't truncate $file: $!";
binmode(HANDLE);
$gifname = "picture.gif";
open(GIF, $gifname) or die "can't open $gifname: $!";
binmode(GIF); binmode(STDOUT);
while (read(GIF, $buff, 8 * 2**10)) {
print STDOUT $buff;
}
$ADDRESS = $RECSIZE * $RECNO;
seek(FH, $ADDRESS, 0) or die "seek:$!";
read(FH, $BUFFER, $RECSIZE);
$ADDRESS = $RECSIZE * ($RECNO-1);
use Fcntl;
$ADDRESS = $RECSIZE * $RECNO;
seek(FH, $ADDRESS, SEEK_SET) or die "Seeking: $!";
read(FH, $BUFFER, $RECSIZE) == $RECSIZE
or die "Reading: $!";
@FIELDS = unpack($FORMAT, $BUFFER);
$BUFFER = pack($FORMAT, @FIELDS);
seek(FH, -$RECSIZE, SEEK_CUR) or die "Seeking: $!";
print FH $BUFFER;
close FH or die "Closing: $!";
use User::pwent;
use IO::Seekable;
$typedef = 'L A12 A16'; $sizeof = length(pack($typedef, ()));
$user = shift(@ARGV) || $ENV{USER} || $ENV{LOGNAME};
$address = getpwnam($user)->uid * $sizeof;
open (LASTLOG, "+</var/log/lastlog")
or die "can't update /usr/adm/lastlog: $!";
seek(LASTLOG, $address, SEEK_SET)
or die "seek failed: $!";
read(LASTLOG, $buffer, $sizeof) == $sizeof
or die "read failed: $!";
($time, $line, $host) = unpack($typedef, $buffer);
$time -= 24 * 7 * 60 * 60; $buffer = pack($typedef, $time, $line, $time);
seek(LASTLOG, -$sizeof, SEEK_CUR) or die "seek failed: $!";
print LASTLOG $record;
close(LASTLOG)
or die "close failed: $!";
$old_rs = $/; $/ = "\0"; seek(FH, $addr, SEEK_SET) or die "Seek error: $!\n";
$string = <FH>; chomp $string; $/ = $old_rs; {
local $/ = "\0";
} use IO::Seekable;
($file, @addrs) = @ARGV or die "usage: $0 addr ...";
open(FH, $file) or die "cannot open $file: $!";
$/ = "\000";
foreach $addr (@addrs) {
$addr = oct $addr if $addr =~ /^0/;
seek(FH, $addr, SEEK_SET)
or die "can't seek to $addr in $file: $!";
printf qq{%#x %#o %d "%s"\n}, $addr, $addr, $addr, scalar <>;
}
$/ = "\0";
while (<>) {
while (/([\040-\176\s]{4,})/g) {
print $1, "\n";
}
}
@FIELDS
until ( eof(FILE) ) {
read(FILE, $record, $RECORDSIZE) == $RECORDSIZE
or die "short read\n";
@FIELDS = unpack($TEMPLATE, $record);
}
struct utmp { /* here are the pack template codes */
short ut_type; /* s for short, must be padded */
pid_t ut_pid; /* i for integer */
char ut_line[UT_LINESIZE]; /* A12 for 12-char string */
char ut_id[2]; /* A2, but need x2 for alignment */
time_t ut_time; /* l for long */
char ut_user[UT_NAMESIZE]; /* A8 for 8-char string */
char ut_host[UT_HOSTSIZE]; /* A16 for 16-char string */
long ut_addr; /* l for long */
};
while (<CONFIG>) {
chomp; s/#.*//; s/^\s+//; s/\s+$//; next unless length; my ($var, $value) = split(/\s*=\s*/, $_, 2);
$User_Preferences{$var} = $value;
}
do "$ENV{HOME}/.progrc";
NETMASK = 255.255.255.0
MTU = 296
DEVICE = cua1
RATE = 115200
MODE = adaptive
no strict 'refs';
$$var = $value;
$NETMASK = '255.255.255.0';
$MTU = 0x128;
$DEVICE = 'cua1';
$RATE = 115_200;
$MODE = 'adaptive';
if ($DEVICE =~ /1$/) {
$RATE = 28_800;
} else {
$RATE = 115_200;
}
$APPDFLT = "/usr/local/share/myprog";
do "$APPDFLT/sysconfig.pl";
do "$ENV{HOME}/.myprogrc";
do "$ENV{HOME}/.myprogrc";
or
do "$APPDFLT/sysconfig.pl"
{ package Settings; do "$ENV{HOME}/.myprogrc" }
eval `cat $ENV{HOME}/.myprogrc`;
$file = "someprog.pl";
unless ($return = do $file) {
warn "couldn't parse $file: $@" if $@;
warn "couldn't do $file: $!" unless defined $return;
warn "couldn't run $file" unless $return;
}
( $dev, $ino, $mode, $nlink,
$uid, $gid, $rdev, $size,
$atime, $mtime, $ctime,
$blksize, $blocks ) = stat($filename)
or die "no $filename: $!";
$mode &= 07777; $info = stat($filename) or die "no $filename: $!";
if ($info->uid == 0) {
print "Superuser owns $filename\n";
}
if ($info->atime > $info->mtime) {
print "$filename has been read since it was written.\n";
}
use File::stat;
sub is_safe {
my $path = shift;
my $info = stat($path);
return unless $info;
if (($info->uid != 0) && ($info->uid != $<)) {
return 0;
}
if ($info->mode & 022) { return 0 unless -d _; return 0 unless $info->mode & 01000;
}
return 1;
}
use Cwd;
use POSIX qw(sysconf _PC_CHOWN_RESTRICTED);
sub is_verysafe {
my $path = shift;
return is_safe($path) if sysconf(_PC_CHOWN_RESTRICTED);
$path = getcwd() . '/' . $path if $path !~ m{^/};
do {
return unless is_safe($path);
$path =~ s#([^/]+|/)$##; $path =~ s#/$## if length($path) > 1; } while length $path;
return 1;
}
$file = "$ENV{HOME}/.myprogrc";
readconfig($file) if is_safe($file);
$file = "$ENV{HOME}/.myprogrc";
if (open(FILE, "< $file")) {
readconfig(*FILE) if is_safe(*FILE);
}
$typedef = 's x2 i A12 A4 l A8 A16 l';
$sizeof = length pack($typedef, () );
use IO::File;
open(WTMP, '/var/log/wtmp') or die "can't open /var/log/wtmp: $!";
seek(WTMP, 0, SEEK_END);
for (;;) {
while (read(WTMP, $buffer, $sizeof) == $sizeof) {
($type, $pid, $line, $id, $time, $user, $host, $addr)
= unpack($typedef, $buffer);
next unless $user && ord($user) && $time;
printf "%1d %-8s %-12s %2s %-24s %-16s %5d %08x\n",
$type,$user,$line,$id,scalar(localtime($time)),
$host,$pid,$addr;
}
for ($size = -s WTMP; $size == -s WTMP; sleep 1) {}
WTMP->clearerr();
}
@host
while ($ARGV[0] =~ /^-(.+)/ && (shift, ($_ = $1), 1)) {
next if /^$/;
s/i// && (++$ignore_ints, redo);
s/a// && (++$append, redo);
s/u// && (++$unbuffer, redo);
s/n// && (++$nostdout, redo);
die "usage tee [-aiun] [filenames] ...\n";
}
if ($ignore_ints) {
for $sig ('INT', 'TERM', 'HUP', 'QUIT') { $SIG{$sig} = 'IGNORE'; }
}
$SIG{'PIPE'} = 'PLUMBER';
$mode = $append ? '>>' : '>';
$fh = 'FH000';
unless ($nostdout) {
%fh = ('STDOUT', 'standard output'); }
$| = 1 if $unbuffer;
for (@ARGV) {
if (!open($fh, (/^[^>|]/ && $mode) . $_)) {
warn "$0: cannot open $_: $!\n"; $status++;
next;
}
select((select($fh), $| = 1)[0]) if $unbuffer;
$fh{$fh++} = $_;
}
while (<STDIN>) {
for $fh (keys %fh) {
print $fh $_;
}
}
for $fh (keys %fh) {
next if close($fh) || !defined $fh{$fh};
warn "$0: couldnt close $fh{$fh}: $!\n";
$status++;
}
exit $status;
sub PLUMBER {
warn "$0: pipe to \"$fh{$fh}\" broke!\n";
$status++;
delete $fh{$fh};
}
use User::pwent;
use IO::Seekable qw(SEEK_SET);
open (LASTLOG, "/var/log/lastlog") or die "can't open /usr/adm/lastlog: $!";
$typedef = 'L A12 A16'; $sizeof = length(pack($typedef, ()));
for $user (@ARGV) {
$U = ($user =~ /^\d+$/) ? getpwuid($user) : getpwnam($user);
unless ($U) { warn "no such uid $user\n"; next; }
seek(LASTLOG, $U->uid * $sizeof, SEEK_SET) or die "seek failed: $!";
read(LASTLOG, $buffer, $sizeof) == $sizeof or next;
($time, $line, $host) = unpack($typedef, $buffer);
printf "%-8s UID %5d %s%s%s\n", $U->name, $U->uid,
$time ? ("at " . localtime($time)) : "never logged in",
$line && " on $line",
$host && " from $host";
}
@entry = stat("/usr/bin/vi") or die "Couldn't stat /usr/bin/vi : $!";
@entry = stat("/usr/bin") or die "Couldn't stat /usr/bin : $!";
@entry = stat(INFILE) or die "Couldn't stat INFILE : $!";
use File::stat;
$inode = stat("/usr/bin/vi");
$ctime = $inode->ctime;
$size = $inode->size;
open( F, "< $filename" )
or die "Opening $filename: $!\n";
unless (-s F && -T _) {
die "$filename doesn't have text in it.\n";
}
opendir(DIRHANDLE, "/usr/bin") or die "couldn't open /usr/bin : $!";
while ( defined ($filename = readdir(DIRHANDLE)) ) {
print "Inside /usr/bin is something called $filename\n";
}
closedir(DIRHANDLE);
($READTIME, $WRITETIME) = (stat($filename))[8,9];
utime($NEWREADTIME, $NEWWRITETIME, $filename);
$SECONDS_PER_DAY = 60 * 60 * 24;
($atime, $mtime) = (stat($file))[8,9];
$atime -= 7 * $SECONDS_PER_DAY;
$mtime -= 7 * $SECONDS_PER_DAY;
utime($atime, $mtime, $file)
or die "couldn't backdate $file by a week w/ utime: $!";
$mtime = (stat $file)[9];
utime(time, $mtime, $file);
use File::stat;
utime(time, stat($file)->mtime, $file);
$file = shift or die "usage: uvi filename\n";
($atime, $mtime) = (stat($file))[8,9];
system($ENV{EDITOR} || "vi", $file);
utime($atime, $mtime, $file)
or die "couldn't restore $file to orig times: $!";
unlink($FILENAME) or die "Can't delete $FILENAME: $!\n";
unlink(@FILENAMES) == @FILENAMES or die "Couldn't unlink all of @FILENAMES: $!\n";
unlink($file) or die "Can't unlink $file: $!";
unless (($count = unlink(@filelist)) == @filelist) {
warn "could only delete $count of "
. (@filelist) . " files";
}
use File::Copy;
copy($oldfile, $newfile);
open(IN, "< $oldfile") or die "can't open $oldfile: $!";
open(OUT, "> $newfile") or die "can't open $newfile: $!";
$blksize = (stat IN)[11] || 16384; while ($len = sysread IN, $buf, $blksize) {
if (!defined $len) {
next if $! =~ /^Interrupted/; die "System read error: $!\n";
}
$offset = 0;
while ($len) { defined($written = syswrite OUT, $buf, $len, $offset)
or die "System write error: $!\n";
$len -= $written;
$offset += $written;
};
}
close(IN);
close(OUT);
system("cp $oldfile $newfile"); system("copy $oldfile $newfile"); use File::Copy;
copy("datafile.dat", "datafile.bak")
or die "copy failed: $!";
move("datafile.new", "datafile.dat")
or die "move failed: $!";
%seen = ();
sub do_my_thing {
my $filename = shift;
my ($dev, $ino) = stat $filename;
unless ($seen{$dev, $ino}++) {
}
}
foreach $filename (@files) {
($dev, $ino) = stat $filename;
push( @{ $seen{$dev,$ino} }, $filename);
}
foreach $devino (sort keys %seen) {
($dev, $ino) = split(/$;/o, $devino);
if (@{$seen{$devino}} > 1) {
$seen }
}
opendir(DIR, $dirname) or die "can't opendir $dirname: $!";
while (defined($file = readdir(DIR))) {
}
closedir(DIR);
$dir = "/usr/local/bin";
print "Text files in $dir are:\n";
opendir(BIN, $dir) or die "Can't open $dir: $!";
while( defined ($file = readdir BIN) ) {
print "$file\n" if -T "$dir/$file";
}
closedir(BIN);
while ( defined ($file = readdir BIN) ) {
next if $file =~ /^\.\.?$/; }
use DirHandle;
sub plainfiles {
my $dir = shift;
my $dh = DirHandle->new($dir) or die "can't opendir $dir: $!";
return sort grep { -f } map { "$dir/$_" } grep { !/^\./ } $dh->
read()
; }
@list = <*.c>;
@list = glob("*.c");
opendir(DIR, $path);
@files = grep { /\.c$/ } readdir(DIR);
closedir(DIR);
use File::KGlob;
@files = glob("*.c");
@files = grep { /\.[ch]$/i } readdir(DH);
use DirHandle;
$dh = DirHandle->new($path) or die "Can't open $path : $!\n";
@files = grep { /\.[ch]$/i } $dh->read();
opendir(DH, $dir) or die "Couldn't open $dir for reading: $!";
@files = ();
while( defined ($file = readdir(DH)) ) {
next unless /\.[ch]$/i;
my $filename = "$dir/$file";
push(@files, $filename) if -T $file;
}
@dirs = map { $_->[1] } sort { $a->[0] <=> $b->[0] } grep { -d $_->[1] } map { [ $_, "$path/$_" ] } grep { /^\d+$/ } readdir(DIR);
use File::Find;
sub process_file {
}
find(\&process_file, @DIRLIST);
@ARGV = qw(.) unless @ARGV;
use File::Find;
find sub { print $File::Find::name, -d && '/', "\n" }, @ARGV;
use File::Find;
@ARGV = ('.') unless @ARGV;
my $sum = 0;
find sub { $sum += -s }, @ARGV;
print "@ARGV contains $sum bytes\n";
use File::Find;
@ARGV = ('.') unless @ARGV;
my ($saved_size, $saved_name) = (-1, '');
sub biggest {
return unless -f && -s _ > $saved_size;
$saved_size = -s _;
$saved_name = $File::Find::name;
}
find(\&biggest, @ARGV);
print "Biggest file $saved_name in @ARGV is $saved_size bytes long.\n";
use File::Find;
@ARGV = ('.') unless @ARGV;
my ($age, $name);
sub youngest {
return if defined $age && $age > (stat($_))[9];
$age = (stat(_))[9];
$name = $File::Find::name;
}
find(\&youngest, @ARGV);
print "$name " . scalar(localtime($age)) . "\n";
@ARGV = qw(.) unless @ARGV;
use File::Find ();
sub find(&@) { &File::Find::find }
*name = *File::Find::name;
find { print $name if -d } @ARGV;
find sub { print $File::Find::name if -d }, @ARGV;
find { print $name if -d } @ARGV;
use File::Find qw(finddepth);
die "usage: $0 dir ..\n" unless @ARGV;
*name = *File::Find::name;
finddepth \&zap, @ARGV;
sub zap {
if (!-l && -d _) {
print "rmdir $name\n";
rmdir($name) or warn "couldn't rmdir $name: $!";
} else {
print "unlink $name";
unlink($name) or warn "couldn't unlink $name: $!";
}
}
use File::Path;
die "usage: $0 dir ..\n" unless @ARGV;
foreach $dir (@ARGV) {
rmtree($dir);
}
foreach $file (@NAMES) {
my $newname = $file;
rename($file, $newname) or
warn "Couldn't rename $file to $newname: $!\n";
}
$op = shift or die "Usage: rename expr [files]\n";
chomp(@ARGV = <STDIN>) unless @ARGV;
for (@ARGV) {
$was = $_;
eval $op;
die $@ if $@;
rename($was,$_) unless $was eq $_;
}
use File::Basename;
$base = basename($path);
$dir = dirname($path);
($base, $dir, $ext) = fileparse($path);
$path = '/usr/lib/libc.a';
$file = basename($path);
$dir = dirname($path);
print "dir is $dir, file is $file\n";
$path = '/usr/lib/libc.a';
($name,$dir,$ext) = fileparse($path,'\..*');
print "dir is $dir, name is $name, extension is $ext\n";
fileparse_set_fstype("MacOS");
$path = "Hard%20Drive:System%20Folder:README.txt";
($name,$dir,$ext) = fileparse($path,'\..*');
print "dir is $dir, name is $name, extension is $ext\n";
sub extension {
my $path = shift;
my $ext = (fileparse($path,'\..*'))[2];
$ext =~ s/^\.//;
return $ext;
}
use strict;
use File::Find;
use Cwd;
my ($srcdir, $dstdir);
my $cwd = getcwd();
die "usage: $0 realdir mirrordir" unless @ARGV == 2;
for (($srcdir, $dstdir) = @ARGV) {
my $is_dir = -d;
next if $is_dir; if (defined ($is_dir)) {
die "$0: $_ is not a directory\n";
} else { mkdir($dstdir, 07777) or die "can't mkdir $dstdir: $!";
}
} continue {
s#^(?!/)#$cwd/#; }
chdir $srcdir;
find(\&wanted, '.');
sub wanted {
my($dev, $ino, $mode) = lstat($_);
my $name = $File::Find::name;
$mode &= 07777; $name =~ s!^\./!!; if (-d _) { mkdir("$dstdir/$name", $mode)
or die "can't mkdir $dstdir/$name: $!";
} else { symlink("$srcdir/$name", "$dstdir/$name")
or die "can't symlink $srcdir/$name to $dstdir/$name: $!";
}
}
use Getopt::Std;
use File::Find;
use File::stat;
use User::pwent;
use User::grent;
getopts('lusrcmi') or die <<DEATH;
Usage: $0 [-mucsril] [dirs ...]
or $0 -i [-mucsrl] < filelist
Input format:
-i read pathnames from stdin
Output format:
-l long listing
Sort on:
-m use mtime (modify time) [DEFAULT]
-u use atime (access time)
-c use ctime (inode change time)
-s use size for sorting
Ordering:
-r reverse sort
NB: You may only use select one sorting option at a time.
DEATH
unless ($opt_i || @ARGV) { @ARGV = ('.') }
if ($opt_c + $opt_u + $opt_s + $opt_m > 1) {
die "can only sort on one time or size";
}
$IDX = 'mtime';
$IDX = 'atime' if $opt_u;
$IDX = 'ctime' if $opt_c;
$IDX = 'size' if $opt_s;
$TIME_IDX = $opt_s ? 'mtime' : $IDX;
*name = *File::Find::name;
if ($opt_i) {
*name = *_; while (<>) { chomp; &wanted; } } else {
find(\&wanted, @ARGV);
}
@skeys = sort { $time{$b} <=> $time{$a} } keys %time;
@skeys = reverse @skeys if $opt_r;
for (@skeys) {
unless ($opt_l) { print "$_\n";
next;
}
$now = localtime $stat{$_}->$TIME_IDX();
printf "%6d %04o %6d %8s %8s %8d %s %s\n",
$stat{$_}->ino(),
$stat{$_}->mode() & 07777,
$stat{$_}->nlink(),
user($stat{$_}->uid()),
group($stat{$_}->gid()),
$stat{$_}->size(),
$now, $_;
}
%time%statsub wanted {
my $sb = stat($_); return unless $sb;
$time{$name} = $sb->$IDX(); $stat{$name} = $sb if $opt_l;
}
sub user {
my $uid = shift;
$user{$uid} = getpwuid($uid)->name || "#$uid"
unless defined $user{$uid};
return $user{$uid};
}
sub group {
my $gid = shift;
$group{$gid} = getgrgid($gid)->name || "#$gid"
unless defined $group{$gid};
return $group{$gid};
}
sub hello {
$greeted++; print "hi there!\n";
}
hello();
sub hypotenuse {
return sqrt( ($_[0] ** 2) + ($_[1] ** 2) );
}
$diag = hypotenuse(3,4); sub hypotenuse {
my ($side1, $side2) = @_;
return sqrt( ($side1 ** 2) + ($side2 ** 2) );
}
print hypotenuse(3, 4), "\n";
@a = (3, 4);
print hypotenuse(@a), "\n"; @both = (@men, @women);
@nums = (1.4, 3.5, 6.7);
@ints = int_all(@nums); @numssub int_all {
my @retlist = @_; for my $n (@retlist) { $n = int($n) }
return @retlist;
}
@nums = (1.4, 3.5, 6.7);
trunc_em(@nums); @numssub trunc_em {
for (@_) { $_ = int($_) } }
$line = chomp(<>);
sub somefunc {
my $variable; my ($another, @an_array, %a_hash);
}
my ($name, $age) = @ARGV;
my $start = fetch_time();
my ($a, $b) = @pair;
my $c = fetch_time();
sub check_x {
my $x = $_[0];
my $y = "whatever";
run_check();
if ($condition) {
print "got $x\n";
}
}
sub save_array {
my @arguments = @_;
push(@Global_Array, \@arguments);
}
{
my $variable;
sub mysub {
}
}
BEGIN {
my $variable = 1; sub othersub { }
}
{
my $counter;
sub next_counter { return ++$counter }
}
BEGIN {
my $counter = 42;
sub next_counter { return ++$counter }
sub prev_counter { return --$counter }
}
$this_function = (caller(0))[3];
($package, $filename, $line, $subr, $has_args, $wantarray )= caller($i);
$me = whoami();
$him = whowasi();
sub whoami { (caller(1))[3] }
sub whowasi { (caller(2))[3] }
array_diff( \@array1, \@array2 );
@a = (1, 2);
@b = (5, 8);
@c = add_vecpair( \@a, \@b );
print "@c\n";
6 10
sub add_vecpair { my ($x, $y) = @_; my @result;
for (my $i=0; $i < @$x; $i++) {
$result[$i] = $x->[$i] + $y->[$i];
}
return @result;
}
unless (@_ == 2 && ref($x) eq 'ARRAY' && ref($y) eq 'ARRAY') {
die "usage: add_vecpair ARRAYREF1 ARRAYREF2";
}
if (wantarray()) {
}
elsif (defined wantarray()) {
}
else {
}
if (wantarray()) {
print "In list context\n";
return @many_things;
} elsif (defined wantarray()) {
print "In scalar context\n";
return $one_thing;
} else {
print "In void context\n";
return; }
mysub();
$a = mysub(); if (mysub()) { }
@a = mysub(); print mysub();
thefunc(INCREMENT => "20s", START => "+5m", FINISH => "+30m");
thefunc(START => "+5m", FINISH => "+30m");
thefunc(FINISH => "+30m");
thefunc(START => "+5m", INCREMENT => "15s");
sub thefunc {
my %args = (
INCREMENT => '10s',
FINISH => 0,
START => 0,
@_, );
if ($args{INCREMENT} =~ /m$/ ) { ..... }
}
($a, undef, $c) = func();
($a, $c) = (func())[0,2];
($dev,$ino,$DUMMY,$DUMMY,$uid) = stat($filename);
($dev,$ino,undef,undef,$uid) = stat($filename);
($dev,$ino,$uid,$gid) = (stat($filename))[0,1,4,5];
() = some_function();
($array_ref, $hash_ref) = somefunc();
sub somefunc {
my @array;
my %hash;
return ( \@array, \%hash );
}
sub fn {
.....
return (\%a, \%b, \%c); return \(%a, %b, %c); }
(%h0, %h1, %h2) = fn(); @array_of_hashes = fn(); $array_of_hashes($r0, $r1, $r2) = fn();
return;
sub empty_retval {
return ( wantarray ? () : undef );
}
if (@a = yourfunc()) { ... }
unless ($a = sfunc()) { die "sfunc failed" }
unless (@a = afunc()) { die "afunc failed" }
unless (%a = hfunc()) { die "hfunc failed" }
ioctl(....) or die "can't ioctl: $!";
@results = myfunc 3, 5;
@results = myfunc(3, 5);
sub myfunc($);
@results = myfunc 3, 5;
@results = ( myfunc(3), 5 );
sub LOCK_SH () { 1 }
sub LOCK_EX () { 2 }
sub LOCK_UN () { 4 }
sub mypush (\@@) {
my $array_ref = shift;
my @remainder = @_;
}
mypush( $x > 10 ? @a : @b , 3, 5 ); mypush( @{ $x > 10 ? \@a : \@b }, 3, 5 ); sub hpush(\%@) {
my $href = shift;
while ( my ($k, $v) = splice(@_, 0, 2) ) {
$href->{$k} = $v;
}
}
hpush(%pieces, "queen" => 9, "rook" => 5);
die "some message"; eval { func() };
if ($@) {
warn "func raised an exception: $@";
}
eval { $val = func() };
warn "func blew up: $@" if $@;
eval { $val = func() };
if ($@ && $@ !~ /Full moon!/) {
die; }
if (defined wantarray()) {
return;
} else {
die "pay attention to my error!";
}
$age = 18; if (CONDITION) {
local $age = 23;
func(); } $para = get_paragraph(*FH); $para = get_paragraph(\*FH); $para = get_paragraph(*IO{FH}); sub get_paragraph {
my $fh = shift;
local $/ = '';
my $paragraph = <$fh>;
chomp($paragraph);
return $paragraph;
}
$contents = get_motd();
sub get_motd {
local *MOTD;
open(MOTD, "/etc/motd") or die "can't open motd: $!";
local $/ = undef; local $_ = <MOTD>;
close (MOTD);
return $_;
}
return *MOTD;
my @nums = (0 .. 5);
sub first {
local $nums[3] = 3.14159;
second();
}
sub second {
print "@nums\n";
}
second();
0 1 2 3 4 5
first();
0 1 2 3.14159 4 5
sub first {
local $SIG{INT} = 'IGNORE';
second();
}
sub func {
local($x, $y) = @_;
}
sub func {
my($x, $y) = @_;
}
&func(*Global_Array);
sub func {
local(*aliased_array) = shift;
for (@aliased_array) { .... }
}
func(\@Global_Array);
sub func {
my $array_ref = shift;
for (@$array_ref) { .... }
}
undef &grow; *grow = \&expand;
grow();
{
local *grow = \&shrink; grow(); }
*one::var = \%two::Table; %one::var%two::Table*one::big = \&two::small; local *fred = \&barney; $string = red("careful here");
print $string;
<FONT COLOR='red'>careful here</FONT>
sub red { "<FONT COLOR='red'>@_</FONT>" }
sub color_font {
my $color = shift;
return "<FONT COLOR='$color'>@_</FONT>";
}
sub red { color_font("red", @_) }
sub green { color_font("green", @_) }
sub blue { color_font("blue", @_) }
sub purple { color_font("purple", @_) }
@colors = qw(red blue green yellow orange purple violet);
for my $name (@colors) {
no strict 'refs';
*$name = sub { "<FONT COLOR='$name'>@_</FONT>" };
}
*$name = sub ($) { "<FONT COLOR='$name'>$_[0]</FONT>" };
sub AUTOLOAD {
use vars qw($AUTOLOAD);
my $color = $AUTOLOAD;
$color =~ s/.*:://;
return "<FONT COLOR='$color'>@_</FONT>";
}
print chartreuse("stuff");
{
local *yellow = \&violet;
local (*red, *green) = (\&green, \&red);
print_stuff();
}
sub outer {
my $x = $_[0] + 35;
sub inner { return $x * 19 } return $x + inner();
}
sub outer {
my $x = $_[0] + 35;
local *inner = sub { return $x * 19 };
return $x + inner();
}
my(@msgs, @sub);
my $msgno = -1;
$/ = ''; while (<>) {
if (/^From/m) {
/^Subject:\s*(?:Re:\s*)*(.*)/mi;
$sub[++$msgno] = lc($1) || '';
}
$msgs[$msgno] .= $_;
}
for my $i (sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msgs)) {
print $msgs[$i];
}
BEGIN { $msgno = -1 }
$sub[++$msgno] = (/^Subject:\s*(?:Re:\s*)*(.*)/mi)[0] if /^From/m;
$msg[$msgno] .= $_;
END { print @msg[ sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msg) ] }
use strict;
my @msgs = ();
while (<>) {
push @msgs, {
SUBJECT => /^Subject:\s*(?:Re:\s*)*(.*)/mi,
NUMBER => scalar @msgs, TEXT => '',
} if /^From/m;
$msgs[-1]{TEXT} .= $_;
}
for my $msg (sort {
$a->{SUBJECT} cmp $b->{SUBJECT}
||
$a->{NUMBER} <=> $b->{NUMBER}
} @msgs
)
{
print $msg->{TEXT};
}
use strict;
use Date::Manip;
my @msgs = ();
while (<>) {
next unless /^From/m;
my $date = '';
if (/^Date:\s*(.*)/m) {
($date = $1) =~ s/\s+\(.*//; $date = ParseDate($date);
}
push @msgs, {
SUBJECT => /^Subject:\s*(?:Re:\s*)*(.*)/mi,
DATE => $date,
NUMBER => scalar @msgs,
TEXT => '',
};
} continue {
$msgs[-1]{TEXT} .= $_;
}
for my $msg (sort {
$a->{SUBJECT} cmp $b->{SUBJECT}
||
$a->{DATE} cmp $b->{DATE}
||
$a->{NUMBER} <=> $b->{NUMBER}
} @msgs
)
{
print $msg->{TEXT};
}
print $$sref; $$sref = 3; print ${$sref}; ${$sref} = 3; $aref = \@array;
$pi = \3.14159;
$$pi = 4; $aref = [ 3, 4, 5 ]; $href = { "How" => "Now", "Brown" => "Cow" }; undef $aref;
@$aref = (1, 2, 3);
print $aref;
ARRAY(0x80c04f0)
$a[4][23][53][21] = "fred";
print $a[4][23][53][21];
fred
print $a[4][23][53];
ARRAY(0x81e2494)
print $a[4][23];
ARRAY(0x81e0748)
print $a[4];
ARRAY(0x822cd40)
$op_cit = cite($ibid) or die "couldn't make a reference";
$Nat = { "Name" => "Leonhard Euler",
"Address" => "1729 Ramanujan Lane\nMathworld, PI 31416",
"Birthday" => 0x5bb5580,
};
$aref = \@array;
$anon_array = [1, 3, 5, 7, 9];
$anon_copy = [ @array ];
@$implicit_creation = (2, 4, 6, 8, 10);
push(@$anon_array, 11);
$two = $implicit_creation->[0];
$last_idx = $#$aref;
$num_items = @$aref;
$last_idx = $#{ $aref };
$num_items = scalar @{ $aref };
if (ref($someref) ne 'ARRAY') {
die "Expected an array reference, not $someref\n";
}
print "@{$array_ref}\n";
@order = sort @{ $array_ref };
push @{ $array_ref }, $item; sub array_ref {
my @array;
return \@array;
}
$aref1 = array_ref();
$aref2 = array_ref();
print $array_ref->[$N]; print $$array_ref[$N]; print ${$array_ref}[$N]; @$pie[3..5]; @{$pie}[3..5]; @{$pie}[3..5] = ("blackberry", "blueberry", "pumpkin");
$sliceref = \@{$pie}[3..5]; foreach $item ( @{$array_ref} ) {
}
for ($idx = 0; $idx <= $#{ $array_ref }; $idx++) {
}
push(@{ $hash{"KEYNAME"} }, "new value");
foreach $string (keys %hash) {
print "$string: @{$hash{$string}}\n";
}
$hash{"a key"} = [ 3, 4, 5 ]; @values = @{ $hash{"a key"} };
push @{ $hash{"a key"} }, $value;
@residents = @{ $phone2name{$number} };
@residents = exists( $phone2name{$number} )
? @{ $phone2name{$number} }
: ();
$href = \%hash;
$anon_hash = { "key1" => "value1", "key2" => "value2", ... };
$anon_hash_copy = { %hash };
%hash = %$href;
$value = $href->{$key};
@slice = @$href{$key1, $key2, $key3}; @keys = keys %$href;
if (ref($someref) ne 'HASH') {
die "Expected a hash reference, not $someref\n";
}
foreach $href ( \%ENV, \%INC ) { %ENV%INC foreach $key ( keys %$href ) {
print "$key => $href->{$key}\n";
}
}
@values = @$hash_ref{"key1", "key2", "key3"};
for $val (@$hash_ref{"key1", "key2", "key3"}) {
$val += 7; }
$cref = \&func;
$cref = sub { ... };
@returned = $cref->(@arguments);
@returned = &$cref(@arguments);
$funcname = "thefunc";
&$funcname();
my %commands = (
"happy" => \&joy,
"sad" => \&sullen,
"done" => sub { die "See ya!" },
"mad" => \&angry,
);
print "How are you? ";
chomp($string = <STDIN>);
if ($commands{$string}) {
$commands{$string}->();
} else {
print "No such command: $string\n";
}
sub counter_maker {
my $start = 0;
return sub { return $start++; };
}
$counter = counter_maker();
for ($i = 0; $i < 5; $i ++) {
print &$counter, "\n";
}
$counter1 = counter_maker();
$counter2 = counter_maker();
for ($i = 0; $i < 5; $i ++) {
print &$counter1, "\n";
}
print &$counter1, " ", &$counter2, "\n";
0
1
2
3
4
5 0
sub timestamp {
my $start_time = time();
return sub { return time() - $start_time };
}
$early = timestamp();
sleep 20;
$later = timestamp();
sleep 10;
printf "It's been %d seconds since early.\n", $early->();
printf "It's been %d seconds since later.\n", $later->();
$scalar_ref = \$scalar; undef $anon_scalar_ref;
$$anon_scalar_ref = 15;
$anon_scalar_ref = \15;
print ${ $scalar_ref }; ${ $scalar_ref } .= "string"; sub new_anon_scalar {
my $temp;
return \$temp;
}
$sref = new_anon_scalar();
$$sref = 3;
print "Three = $$sref\n";
@array_of_srefs = ( new_anon_scalar(), new_anon_scalar() );
${ $array[0] } = 6.02e23;
${ $array[1] } = "avocado";
print "\@array contains: ", join(", ", map { $$_ } @array ), "\n";
$var = `uptime`; $vref = \$var; if ($$vref =~ /load/) {} chomp $$vref; if (ref($someref) ne 'SCALAR') {
die "Expected a scalar reference, not $someref\n";
}
@array_of_scalar_refs = ( \$a, \$b );
@array_of_scalar_refs = \( $a, $b );
${ $array_of_scalar_refs[1] } = 12; ($a, $b, $c, $d) = (1 .. 4); @array = (\$a, \$b, \$c, \$d); @array = \( $a, $b, $c, $d); @array = map { \my $anon } 0 .. 3;
${ $array[2] } += 9;
${ $array[ $#array ] } *= 5; ${ $array[-1] } *= 5;
$tmp = $array[-1]; $$tmp *= 5; use Math::Trig qw(pi); foreach $sref (@array) { ($$sref **= 3) *= (4/3 * pi); }
$c1 = mkcounter(20);
$c2 = mkcounter(77);
printf "next c1: %d\n", $c1->{NEXT}->(); printf "next c2: %d\n", $c2->{NEXT}->(); printf "next c1: %d\n", $c1->{NEXT}->(); printf "last c1: %d\n", $c1->{PREV}->(); printf "old c2: %d\n", $c2->{RESET}->(); sub mkcounter {
my $count = shift;
my $start = $count;
my $bundle = {
"NEXT" => sub { return ++$count },
"PREV" => sub { return --$count },
"GET" => sub { return $count },
"SET" => sub { $count = shift },
"BUMP" => sub { $count += shift },
"RESET" => sub { $count = $start },
};
$bundle->{"LAST"} = $bundle->{"PREV"};
return $bundle;
}
$mref = sub { $obj->meth(@_) };
$mref->("args", "go", "here");
$sref = \$obj->meth;
$cref = $obj->can("meth");
$record = {
NAME => "Jason",
EMPNO => 132,
TITLE => "deputy peon",
AGE => 23,
SALARY => 37_000,
PALS => [ "Norbert", "Rhys", "Phineas"],
};
printf "I am %s, and my pals are %s.\n",
$record->{NAME},
join(", ", @{$record->{PALS}});
$byname{ $record->{NAME} } = $record;
if ($rp = $byname{"Aron"}) { printf "Aron is employee %d.\n", $rp->{EMPNO};
}
push @{$byname{"Jason"}->{PALS}}, "Theodore";
printf "Jason now has %d pals\n", scalar @{$byname{"Jason"}->{PALS}};
while (($name, $record) = each %byname) {
printf "%s is employee number %d\n", $name, $record->{EMPNO};
}
$employees[ $record->{EMPNO} ] = $record;
if ($rp = $employee[132]) {
printf "employee number 132 is %s\n", $rp->{NAME};
}
$byname{"Jason"}->{SALARY} *= 1.035;
@peons = grep { $_->{TITLE} =~ /peon/i } @employees;
@tsevens = grep { $_->{AGE} == 27 } @employees;
foreach $rp (sort { $a->{AGE} <=> $b->{AGE} } values %byname) {
printf "%s is age %d.\n", $rp->{NAME}, $rp->{AGE};
printf "%s is employee number %d.\n", @$rp{'NAME','EMPNO'};
}
@byagepush @{ $byage[ $record->{AGE} ] }, $record;
for ($age = 0; $age <= $#byage; $age++) {
next unless $byage[$age];
print "Age $age: ";
foreach $rp (@{$byage[$age]}) {
print $rp->{NAME}, " ";
}
print "\n";
}
for ($age = 0; $age <= $#byage; $age++) {
next unless $byage[$age];
printf "Age %d: %s\n", $age,
join(", ", map {$_->{NAME}} @{$byage[$age]});
}
FieldName: Value
foreach $record (@Array_of_Records) {
for $key (sort keys %$record) {
print "$key: $record->{$key}\n";
}
print "\n";
}
$/ = ""; while (<>) {
my @fields = split /^([^:]+):\s*/m;
shift @fields; push(@Array_of_Records, { map /(.*)/, @fields });
}
DB<1> $reference = [ { "foo" => "bar" }, 3, sub { print "hello, world\n" } ];
DB<2> x $reference
0 ARRAY(0x1d033c)
0 HASH(0x7b390)
'foo' = 'bar'>
1 3
2 CODE(0x21e3e4)
- & in ???>
use Data::Dumper;
print Dumper($reference);
D<1> x \@INC
0 ARRAY(0x807d0a8)
0 '/home/tchrist/perllib'
1 '/usr/lib/perl5/i686-linux/5.00403'
2 '/usr/lib/perl5'
3 '/usr/lib/perl5/site_perl/i686-linux'
4 '/usr/lib/perl5/site_perl'
5 '.'
{ package main; require "dumpvar.pl" }
*dumpvar = \&main::dumpvar if __PACKAGE__ ne 'main';
dumpvar("main", "INC"); @INC%INC@INC = (
0 '/home/tchrist/perllib/i686-linux'
1 '/home/tchrist/perllib'
2 '/usr/lib/perl5/i686-linux/5.00404'
3 '/usr/lib/perl5'
4 '/usr/lib/perl5/site_perl/i686-linux'
5 '/usr/lib/perl5/site_perl'
6 '.'
)
%INC = (
'dumpvar.pl' = '/usr/lib/perl5/i686-linux/5.00404/dumpvar.pl'
'strict.pm' = '/usr/lib/perl5/i686-linux/5.00404/strict.pm'
)
use Data::Dumper;
print Dumper(\@INC);
$VAR1 = [
'/home/tchrist/perllib',
'/usr/lib/perl5/i686-linux/5.00403',
'/usr/lib/perl5',
'/usr/lib/perl5/site_perl/i686-linux',
'/usr/lib/perl5/site_perl',
'.'
];
use Storable;
$r2 = dclone($r1);
@original = ( \@a, \@b, \@c );
@surface = @original;
@deep = map { [ @$_ ] } @original;
use Storable qw(dclone);
$r2 = dclone($r1);
%newhash = %{ dclone(\%oldhash) };
use Storable;
store(\%hash, "filename");
$href = retrieve("filename"); %hash = %{ retrieve("filename") }; use Storable qw(nstore);
nstore(\%hash, "filename");
$href = retrieve("filename");
use Storable qw(nstore_fd);
use Fcntl qw(:DEFAULT :flock);
sysopen(DF, "/tmp/datafile", O_RDWR|O_CREAT, 0666)
or die "can't open /tmp/datafile: $!";
flock(DF, LOCK_EX) or die "can't lock /tmp/datafile: $!";
nstore_fd(\%hash, *DF)
or die "can't store hash\n";
truncate(DF, tell(DF));
close(DF);
use Storable;
use Fcntl qw(:DEFAULT :flock);
open(DF, "< /tmp/datafile") or die "can't open /tmp/datafile: $!";
flock(DF, LOCK_SH) or die "can't lock /tmp/datafile: $!";
$href = retrieve(*DF);
close(DF);
use MLDBM qw(DB_File);
use Fcntl;
tie(%hash, 'MLDBM', 'testfile.db', O_CREAT|O_RDWR, 0666)
or die "can't open tie to testfile.db: $!";
%hash
untie %hash;
use MLDBM qw(DB_File);
use Fcntl;
tie(%hash, 'MLDBM', 'testfile.db', O_CREAT|O_RDWR, 0666)
or die "can't open tie to testfile.db: $!";
$hash{"some key"}[4] = "fred";
$aref = $hash{"some key"};
$aref->[4] = "fred";
$hash{"some key"} = $aref;
use strict;
my($root, $n);
while ($n++ < 20) { insert($root, int(rand(1000)) }
print "Pre order: "; pre_order($root); print "\n";
print "In order: "; in_order($root); print "\n";
print "Post order: "; post_order($root); print "\n";
for (print "Search? "; <>; print "Search? ") {
chomp;
my $found = search($root, $_);
if ($found) { print "Found $_ at $found, $found->{VALUE}\n" }
else { print "No $_ in tree\n" }
}
exit;
@_sub insert {
my($tree, $value) = @_;
unless ($tree) {
$tree = {}; $tree->{VALUE} = $value;
$tree->{LEFT} = undef;
$tree->{RIGHT} = undef;
$_[0] = $tree; $_ return;
}
if ($tree->{VALUE} > $value) { insert($tree->{LEFT}, $value) }
elsif ($tree->{VALUE} < $value) { insert($tree->{RIGHT}, $value) }
else { warn "dup insert of $value\n" }
}
sub in_order {
my($tree) = @_;
return unless $tree;
in_order($tree->{LEFT});
print $tree->{VALUE}, " ";
in_order($tree->{RIGHT});
}
sub pre_order {
my($tree) = @_;
return unless $tree;
print $tree->{VALUE}, " ";
pre_order($tree->{LEFT});
pre_order($tree->{RIGHT});
}
sub post_order {
my($tree) = @_;
return unless $tree;
post_order($tree->{LEFT});
post_order($tree->{RIGHT});
print $tree->{VALUE}, " ";
}
sub search {
my($tree, $value) = @_;
return unless $tree;
if ($tree->{VALUE} == $value) {
return $tree;
}
search($tree->{ ($value < $tree->{VALUE}) ? "LEFT" : "RIGHT"}, $value)
}
package Alpha;
$name = "first";
package Omega;
$name = "last";
package main;
print "Alpha is $Alpha::name, Omega is $Omega::name.\n";
Alpha is first, Omega is last.
require "FileHandle.pm"; require FileHandle; use FileHandle;
require "Cards/Poker.pm"; require Cards::Poker; use Cards::Poker; 1 package Cards::Poker;
2 use Exporter;
3 @ISA = ('Exporter');
4 @EXPORT = qw(&shuffle @card_deck);
5 @card_deck = (); 6 sub shuffle { } 7 1;
package YourModule;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
use Exporter;
$VERSION = 1.00; @ISA = qw(Exporter);
@EXPORT = qw(...); @EXPORT_OK = qw(...); %EXPORT_TAGS = ( TAG1 => [...],
TAG2 => [...],
...
);
1; use YourModule; use YourModule qw(...); use YourModule (); use YourModule qw(:TAG1); @EXPORT = qw(&F1 &F2 @List);
@EXPORT = qw( F1 F2 @List); @EXPORT_OK = qw(Op_Func %Table);
use YourModule qw(Op_Func %Table F1);
use YourModule qw(:DEFAULT %Table);
%EXPORT_TAGS = (
Functions => [ qw(F1 F2 Op_Func) ],
Variables => [ qw(@List %Table) ],
);
use YourModule qw(:Functions %Table);
@{
$YourModule::EXPORT_TAGS{Functions}
}
,
BEGIN {
unless (eval "require $mod") {
warn "couldn't load $mod: $@";
}
}
BEGIN {
unless (eval "use $mod") {
warn "couldn't load $mod: $@";
}
}
BEGIN {
my($found, @DBs, $mod);
$found = 0;
@DBs = qw(Giant::Eenie Giant::Meanie Mouse::Mynie Moe);
for $mod (@DBs) {
if (eval "require $mod") {
$mod->
import
(); $found = 1;
last;
}
}
die "None of @DBs loaded" unless $found;
}
BEGIN {
unless (@ARGV == 2 && (2 == grep {/^\d+$/} @ARGV)) {
die "usage: $0 num1 num2\n";
}
}
use Some::Module;
use More::Modules;
if ($opt_b) {
require Math::BigInt;
}
use Fcntl qw(O_EXCL O_CREAT O_RDWR);
require Fcntl;
Fcntl->import(qw(O_EXCL O_CREAT O_RDWR));
sub load_module {
require $_[0]; import $_[0]; }
load_module('Fcntl', qw(O_EXCL O_CREAT O_RDWR));
sub load_module {
eval "require $_[0]";
die if $@;
$_[0]->import(@_[1 .. $#_]);
}
use autouse Fcntl => qw( O_EXCL() O_CREAT() O_RDWR() );
package Alpha;
my $aa = 10;
$x = "azure";
package Beta;
my $bb = 20;
$x = "blue";
package main;
print "$aa, $bb, $x, $Alpha::x, $Beta::x\n";
10, 20, , azure, blue
package Flipper;
use strict;
require Exporter;
use vars qw(@ISA @EXPORT $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw(flip_words flip_boundary);
$VERSION = 1.0;
my $Separatrix = ' ';
sub flip_boundary {
my $prev_sep = $Separatrix;
if (@_) { $Separatrix = $_[0] }
return $prev_sep;
}
sub flip_words {
my $line = $_[0];
my @words = split($Separatrix, $line);
return join($Separatrix, reverse @words);
}
1;
$this_pack = __PACKAGE__;
$that_pack = caller();
print "I am in package __PACKAGE__\n"; I am in package __PACKAGE__
package Alpha;
runit('$line = <TEMP>');
package Beta;
sub runit {
my $codestr = shift;
eval $codestr;
die if $@;
}
package Beta;
sub runit {
my $codestr = shift;
my $hispack = caller;
eval "package $hispack; $codestr";
die if $@;
}
package Alpha;
runit( sub { $line = <TEMP> } );
package Beta;
sub runit {
my $coderef = shift;
&$coderef();
}
open (FH, "< /etc/termcap")
or die "can't open /etc/termcap: $!";
($a, $b, $c) = nreadline(3, 'FH');
use Symbol ();
use Carp;
sub nreadline {
my ($count, $handle) = @_;
my(@retlist,$line);
croak "count must be > 0" unless $count > 0;
$handle = Symbol::qualify($handle, (
caller()
)[0]);
croak "need open filehandle" unless defined fileno($handle);
push(@retlist, $line) while defined($line = <$handle>) && $count--;
return @retlist;
}
$Logfile = "/tmp/mylog" unless defined $Logfile;
open(LF, ">>$Logfile")
or die "can't append to $Logfile: $!";
select(((select(LF), $|=1))[0]); logmsg("startup");
sub logmsg {
my $now = scalar gmtime;
print LF "$0 $$ $now: @_\n"
or die "write to $Logfile failed: $!";
}
END {
logmsg("shutdown");
close(LF)
or die "close $Logfile failed: $!";
}
use sigtrap qw(die normal-signals error-signals);
@INC%d%s
use lib "/projects/spectre/lib";
use FindBin;
use lib $FindBin::Bin;
use FindBin qw($Bin);
use lib "$Bin/../lib";
package Astronomy::Orbits;
require Exporter;
require AutoLoader;
@ISA = qw(Exporter AutoLoader);
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
require Exporter;
require SelfLoader;
@ISA = qw(Exporter SelfLoader);
package FineTime;
use strict;
require Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(time);
sub time() { ..... } use FineTime qw(time);
$start = time();
1 while print time() - $start, "\n";
sub even_only {
my $n = shift;
die "$n is not even" if $n & 1; }
use Carp;
sub even_only {
my $n = shift;
croak "$n is not even" if $n % 2; }
use Carp;
sub even_only {
my $n = shift;
if ($n & 1) { carp "$n is not even, continuing";
++$n;
}
}
carp "$n is not even, continuing" if $^W;
{
no strict 'refs';
$val = ${ $packname . "::" . $varname };
@vals = @{ $packname . "::" . $aryname };
&{ $packname . "::" . $funcname }("args");
($packname . "::" . $funcname) -> ("args");
}
eval "package $packname; \$'$val = \$$varname"; die if $@;
printf "log2 of 100 is %.2f\n", log2(100);
printf "log10 of 100 is %.2f\n", log10(100);
$packname = 'main';
for ($i = 2; $i < 1000; $i++) {
$logN = log($i);
eval "sub ${packname}::log$i { log(shift) / $logN }";
die if $@;
}
$packname = 'main';
for ($i = 2; $i < 1000; $i++) {
my $logN = log($i);
no strict 'refs';
*{"${packname}::log$i"} = sub { log(shift) / $logN };
}
*blue = \&Colors::blue;
*main::blue = \&Colors::azure;
@INC@INCpackage main;
require 'sys/syscall.ph';
die "No SYS_gettimeofday in sys/syscall.ph"
unless defined &SYS_gettimeofday;
package FineTime;
use strict;
require Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(time);
sub time() {
my $tv = pack("LL", ()); syscall(&main::SYS_gettimeofday, $tv, undef) >= 0
or die "gettimeofday: $!";
my($seconds, $microseconds) = unpack("LL", $tv);
return $seconds + ($microseconds / 1_000_000);
}
1;
require 'sys/ioctl.ph';
die "no TIOCSTI" unless defined &TIOCSTI;
sub jam {
local $SIG{TTOU} = "IGNORE"; local *TTY; open(TTY, "+</dev/tty") or die "no tty: $!";
for (split(//, $_[0])) {
ioctl(TTY, &TIOCSTI, $_) or die "bad TIOCSTI: $!";
}
close(TTY);
}
jam("@ARGV\n");
require 'sys/ioctl.ph';
die "no TIOCGWINSZ " unless defined &TIOCGWINSZ;
open(TTY, "+</dev/tty") or die "No tty: $!";
unless (ioctl(TTY, &TIOCGWINSZ, $winsize='')) {
die sprintf "$0: ioctl TIOCGWINSZ (%08x: $!)\n", &TIOCGWINSZ;
}
($row, $col, $xpixel, $ypixel) = unpack('S4', $winsize);
print "(row,col) = ($row,$col)";
print " (xpixel,ypixel) = ($xpixel,$ypixel)" if $xpixel || $ypixel;
print "\n";
package FineTime;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
@EXPORT_OK = qw(time);
$VERSION = '0.01';
bootstrap FineTime $VERSION;
1;
package Some::Module;
use strict;
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = 0.01;
@ISA = qw(Exporter);
@EXPORT = qw(&func1 &func2 &func4);
%EXPORT_TAGS = ( ); TAG
@EXPORT_OK = qw($Var1 %Hashit &func3);
use vars qw($Var1 %Hashit);
use vars qw(@more $stuff);
$Var1 = '';
%Hashit = ();
$stuff = '';
@more = ();
my $priv_var = '';
my %secret_hash = ();
my $priv_func = sub {
};
sub func1 { .... } sub func2() { .... } sub func3($$) { .... }
sub func4(\%) { .... }
END { }
1;
@perl
use strict;
use File::Find qw(find);
use Getopt::Std qw(getopts);
use Carp;
use vars (
q!$opt_v!, q!$opt_w!, q!$opt_a!, q!$opt_s!, );
$| = 1;
getopts('wvas') or die "bad usage";
@ARGV = @INC unless @ARGV;
use vars (
q!$Start_Dir!, q!%Future!, );
my $Module;
if ($opt_s) {
if (open(ME, "-|")) {
$/ = '';
while (<ME>) {
chomp;
print join("\n", sort split /\n/), "\n";
}
exit;
}
}
MAIN: {
my %visited;
my ($dev,$ino);
@Future{@ARGV} = (1) x @ARGV;
foreach $Start_Dir (@ARGV) {
delete $Future{$Start_Dir};
print "\n<<Modules from $Start_Dir>>\n\n"
if $opt_v;
next unless ($dev,$ino) = stat($Start_Dir);
next if $visited{$dev,$ino}++;
next unless $opt_a || $Start_Dir =~ m!^/!;
find(\&wanted, $Start_Dir);
}
exit;
}
sub modname {
local $_ = $File::Find::name;
if (index($_, $Start_Dir . '/') == 0) {
substr($_, 0, 1+length($Start_Dir)) = '';
}
s { / } {::}gx;
s { \.p(m|od)$ } {}x;
return $_;
}
sub wanted {
if ( $Future{$File::Find::name} ) {
warn "\t(Skipping $File::Find::name, qui venit in futuro.)\n"
if 0 and $opt_v;
$File::Find::prune = 1;
return;
}
return unless /\.pm$/ && -f;
$Module = &modname;
if ($Module =~ /^CPAN(\Z|::)/) {
warn("$Module -- skipping because it misbehaves\n");
return;
}
my $file = $_;
unless (open(POD, "< $file")) {
warn "\tcannot open $file: $!";
return 0;
}
$: = " -:";
local $/ = '';
local $_;
while (<POD>) {
if (/=head\d\s+NAME/) {
chomp($_ = <POD>);
s/^.*?-\s+//s;
s/\n/ /g;
my $v;
if (defined ($v = getversion($Module))) {
print "$Module ($v) ";
} else {
print "$Module ";
}
print "- $_\n";
return 1;
}
}
warn "\t(MISSING DESC FOR $File::Find::name)\n"
if $opt_w;
return 0;
}
sub getversion {
my $mod = shift;
my $vers = `$^X -m$mod -e 'print \$${mod}::VERSION' 2>/dev/null`;
$vers =~ s/^\s*(.*?)\s*$/$1/; return ($vers || undef);
}
format =
^<<<<<<<<<<<<<<<<<~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$Module, $_
.
$object = {}; bless($object, "Data::Encoder"); bless($object); $obj = [3,5];
print ref($obj), " ", $obj->[1], "\n";
bless($obj, "Human::Cannibal");
print ref($obj), " ", $obj->[1], "\n";
ARRAY 5
Human::Cannibal 5
$obj->{Stomach} = "Empty"; $obj->{NAME} = "Thag"; $encoded = $object->encode("data");
$encoded = Data::Encoder->encode("data");
sub new {
my $class = shift;
my $self = {}; bless($self, $class);
return $self;
}
$object = Class->new();
$object = Class::new("Class");
sub class_only_method {
my $class = shift;
die "class method called on object" if ref $class;
}
sub instance_only_method {
my $self = shift;
die "instance method called on class" unless ref $self;
}
$lector = new Human::Cannibal;
feed $lector "Zak";
move $lector "New York";
$lector = Human::Cannibal->
new();
$lector->feed("Zak");
$lector->move("New York");
printf STDERR "stuff here\n";
move $obj->{FIELD}; move $ary[$i]; $obj->move->{FIELD}; $ary->move->[$i]; $obj->{FIELD}->
move()
; $ary[$i]->
move;
sub new {
my $class = shift;
my $self = { };
bless($self, $class);
return $self;
}
sub new { bless( { }, shift ) }
sub new { bless({}) }
sub new {
my $self = { }; bless($self);
$self->{START} = time();
$self->{AGE} = 0;
return $self;
}
sub new {
my $classname = shift; my $self = {}; bless($self, $classname); $self->{START} =
time();
$self->{AGE} =
0;
return $self; }
sub new {
my $classname = shift; my $self = {}; bless($self, $classname); $self->_init(@_); return $self;
}
sub _init {
my $self = shift;
$self->{START} =
time();
$self->{AGE} = 0;
if (@_) {
my %extra = @_;
@$self{keys %extra} = values %extra;
}
}
sub DESTROY {
my $self = shift;
printf("$self dying at %s\n", scalar localtime);
}
$self->{WHATEVER} = $self;
sub get_name {
my $self = shift;
return $self->{NAME};
}
sub set_name {
my $self = shift;
$self->{NAME} = shift;
}
sub name {
my $self = shift;
if (@_) { $self->{NAME} = shift }
return $self->{NAME};
}
sub age {
my $self = shift;
my $prev = $self->{AGE};
if (@_) { $self->{AGE} = shift }
return $prev;
}
$obj->age( 1 + $obj->age );
$him = Person->
new()
;
$him->{NAME} = "Sylvester";
$him->{AGE} = 23;
use Carp;
sub name {
my $self = shift;
return $self->{NAME} unless @_;
local $_ = shift;
croak "too many arguments" if @_;
if ($^W) {
/[^\s\w'-]/ && carp "funny characters in name"; /\d/ && carp "numbers in name";
/\S+(\s+\S+)+/ || carp "prefer multiword name";
/\S/ || carp "name is blank";
}
s/(\w+)/\u\L$1/g; $self->{NAME} = $_;
}
package Person;
sub new {
my $that = shift;
my $class = ref($that) || $that;
my $self = {
NAME => undef,
AGE => undef,
PEERS => [],
};
bless($self, $class);
return $self;
}
use Alias qw(attr);
use vars qw($NAME $AGE @PEERS);
sub name {
my $self = attr shift;
if (@_) { $NAME = shift; }
return $NAME;
};
sub age {
my $self = attr shift;
if (@_) { $AGE = shift; }
return $AGE;
}
sub peers {
my $self = attr shift;
if (@_) { @PEERS = @_; }
return @PEERS;
}
sub exclaim {
my $self = attr shift;
return sprintf "Hi, I'm %s, age %d, working with %s",
$NAME, $AGE, join(", ", @PEERS);
}
sub happy_birthday {
my $self = attr shift;
return ++$AGE;
}
package Person;
$Body_Count = 0;
sub population { return $Body_Count }
sub new { $Body_Count++;
return bless({}, shift);
}
sub DESTROY { --$BodyCount }
package main;
for (1..10) { push @people, Person->new }
printf "There are %d people alive.\n", Person->population();
There are 10 people alive.
$him = Person->
new()
;
$him->gender("male");
$her = Person->
new()
;
$her->gender("female");
FixedArray->Max_Bounds(100); $alpha = FixedArray->new();
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();
100
$beta = FixedArray->new();
$beta->Max_Bounds(50); printf "Bound on alpha is %d\n", $alpha->Max_Bounds();
50
package FixedArray;
$Bounds = 7; sub new { bless( {}, shift ) }
sub Max_Bounds {
my $proto = shift;
$Bounds = shift if @_; return $Bounds;
}
sub Max_Bounds { $Bounds }
sub new {
my $class = shift;
my $self = bless({}, $class);
$self->{Max_Bounds_ref} = \$Bounds;
return $self;
}
use Class::Struct;
struct Person => { name => '$', age => '$', peers => '@', };
my $p = Person->
new()
;
$p->name("Jason Smythe"); $p->age(13); $p->peers( ["Wilbur", "Ralph", "Fred" ] );
@{$p->peers} = ("Wilbur", "Ralph", "Fred");
printf "At age %d, %s's first friend is %s.\n",
$p->age, $p->name, $p->peers(0);
use Class::Struct;
struct Person => {name => '$', age => '$'}; struct Family => {head => 'Person', address => '$', members => '@'};
$folks = Family->
new();
$dad = $folks->head;
$dad->name("John");
$dad->age(34);
printf("%s's age is %d\n", $folks->head->name, $folks->head->age);
sub Person::age {
use Carp;
my ($self, $age) = @_;
if (@_ > 2) { confess "too many arguments" }
elsif (@_ == 1) { return $struct->{'age'} }
elsif (@_ == 2) {
carp "age `$age' isn't numeric" if $age !~ /^\d+/;
carp "age `$age' is unreasonable" if $age > 150;
$self->{'age'} = $age;
}
}
if ($^W) {
carp "age `$age' isn't numeric" if $age !~ /^\d+/;
carp "age `$age' is unreasonable" if $age > 150;
}
my $gripe = $^W ? \&carp : \&croak;
$gripe->("age `$age' isn't numeric") if $age !~ /^\d+/;
$gripe->("age `$age' is unreasonable") if $age > 150;
struct Family => [head => 'Person', address => '$', members => '@']; struct Card => {
name => '$',
color => '$',
cost => '$',
type => '$',
release => '$',
text => '$',
};
struct Card => map { $_ => '$' } qw(name color cost type release text); struct hostent => { reverse qw{
$ name
@ aliases
$ addrtype
$ length
@ addr_list
}};
type()
same as (hostent object)->
addrtype()
*hostent::type = \&hostent::addrtype;
addr()
same as (hostenv object)->addr_list(0)
sub hostent::addr { shift->addr_list(0,@_) }
package Extra::hostent;
use Net::hostent;
@ISA = qw(hostent);
sub addr { shift->addr_list(0,@_) }
1;
my $proto = shift;
my $class = ref($proto) || $proto;
my $parent = ref($proto) && $proto;
$ob1 = SomeClass->
new()
;
$ob2 = (ref $ob1)->
new();
$ob1 = Widget->new();
$ob2 = $ob1->new();
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $parent = ref($proto) && $proto;
my $self;
@ISA if (@ISA && $proto->SUPER::can('new') ) {
$self = $proto->SUPER::new(@_);
} else {
$self = {};
bless ($self, $proto);
}
bless($self, $class);
$self->{PARENT} = $parent;
$self->{START} = time(); $self->{AGE} = 0;
return $self;
}
$methname = "flicker";
$obj->$methname(10);
foreach $m ( qw(start run stop) ) {
$obj->
$m();
}
@methods = qw(name rank serno);
%his_info = map { $_ => $ob->$_() } @methods;
%his_info = (
'name' => $ob->
name()
,
'rank' => $ob->
rank()
,
'serno' => $ob->
serno()
,
);
my $fnref = sub { $ob->method(@_) };
$fnref->(10, "fred");
$obj->method(10, "fred");
$obj->can('method_name')->($obj_target, @arguments)
if $obj_target->isa( ref $obj );
$obj->isa("HTTP::Message"); HTTP::Response->isa("HTTP::Message");
if ($obj->can("method_name")) { .... } $has_io = $fd->isa("IO::Handle");
$itza_handle = IO::Socket->isa("IO::Handle");
$his_print_method = $obj->can('as_string');
Some_Module->VERSION(3.0);
$his_vers = $obj->
VERSION()
;
use Some_Module 3.0;
use vars qw($VERSION);
$VERSION = '1.01';
package Person;
sub new {
my $class = shift;
my $self = { };
return bless $self, $class;
}
sub name {
my $self = shift;
$self->{NAME} = shift if @_;
return $self->{NAME};
}
sub age {
my $self = shift;
$self->{AGE} = shift if @_;
return $self->{AGE};
}
use Person;
my $dude = Person->
new()
;
$dude->name("Jason");
$dude->age(23);
printf "%s is age %d.\n", $dude->name, $dude->age;
package Employee;
use Person;
@ISA = ("Person");
1;
use Employee;
my $empl = Employee->
new()
;
$empl->name("Jason");
$empl->age(23);
printf "%s is age %d.\n", $empl->name, $empl->age;
$him = Person::
new()
;
sub meth {
my $self = shift;
$self->SUPER::
meth()
;
}
$self->
meth();
$self->Where::
meth();
$self->SUPER::
meth();
sub new {
my $classname = shift; my $self = $classname->SUPER::new(@_);
$self->_init(@_);
return $self; }
sub _init {
my $self = shift;
$self->{START} = time(); $self->{AGE} = 0;
$self->{EXTRA} = { @_ }; }
$obj = Widget->new( haircolor => red, freckles => 121 );
my $self = bless {}, $class;
for my $class (@ISA) {
my $meth = $class . "::_init";
$self->$meth(@_) if $class->can("_init");
}
package Person;
use strict;
use Carp;
use vars qw($AUTOLOAD %ok_field);
for my $attr ( qw(name age peers parent) ) { $ok_field{$attr}++; }
sub AUTOLOAD {
my $self = shift;
my $attr = $AUTOLOAD;
$attr =~ s/.*:://;
return unless $attr =~ /[^A-Z]/; croak "invalid attribute method: ->
$attr()"
unless $ok_field{$attr};
$self->{uc $attr} = shift if @_;
return $self->{uc $attr};
}
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $parent = ref($proto) && $proto;
my $self = {};
bless($self, $class);
$self->parent($parent);
return $self;
}
1;
use Person;
my ($dad, $kid);
$dad = Person->new;
$dad->name("Jason");
$dad->age(23);
$kid = $dad->new;
$kid->name("Rachel");
$kid->age(2);
printf "Kid's parent is %s\n", $kid->parent->name;
sub AUTOLOAD {
my $self = shift;
my $attr = $AUTOLOAD;
$attr =~ s/.*:://;
return if $attr eq 'DESTROY';
if ($ok_field{$attr}) {
$self->{uc $attr} = shift if @_;
return $self->{uc $attr};
} else {
my $superior = "SUPER::$attr";
$self->$superior(@_);
}
}
sub Employee::age {
my $self = shift;
$self->{Employee_age} = shift if @_;
return $self->{Employee_age};
}
package Person;
use Class::Attributes; mkattr qw(name age peers parent);
package Employee;
@ISA = qw(Person);
use Class::Attributes;
mkattr qw(salary age boss);
package Class::Attributes;
use strict;
use Carp;
use Exporter ();
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(mkattr);
sub mkattr {
my $hispack = caller();
for my $attr (@_) {
my($field, $method);
$method = "${hispack}::$attr";
($field = $method) =~ s/:/_/g;
no strict 'refs'; *$method = sub {
my $self = shift;
confess "too many arguments" if @_ > 1;
$self->{$field} = shift if @_;
return $self->{$field};
};
}
}
1;
$node->{NEXT} = $node;
package Ring;
sub new {
my $class = shift;
my $node = { };
$node->{NEXT} = $node->{PREV} = $node;
my $self = { DUMMY => $node, COUNT => 0 };
bless $self, $class;
return $self;
}
use Ring;
$COUNT = 1000;
for (1 .. 20) {
my $r = Ring->
new()
;
for ($i = 0; $i < $COUNT; $i++) { $r->insert($i) }
}
sub DESTROY {
my $ring = shift;
my $node;
for ( $node = $ring->{DUMMY}->{NEXT};
$node != $ring->{DUMMY};
$node = $node->{NEXT} )
{
$ring->delete_node($node);
}
$node->{PREV} = $node->{NEXT} = undef;
}
sub delete_node {
my ($ring, $node) = @_;
$node->{PREV}->{NEXT} = $node->{NEXT};
$node->{NEXT}->{PREV} = $node->{PREV};
--$ring->{COUNT};
}
sub search {
my ($ring, $value) = @_;
my $node = $ring->{DUMMY}->{NEXT};
while ($node != $ring->{DUMMY} && $node->{VALUE} != $value) {
$node = $node->{NEXT};
}
return $node;
}
sub insert {
my ($ring, $value) = @_;
my $node = { VALUE => $value };
$node->{NEXT} = $ring->{DUMMY}->{NEXT};
$ring->{DUMMY}->{NEXT}->{PREV} = $node;
$ring->{DUMMY}->{NEXT} = $node;
$node->{PREV} = $ring->{DUMMY};
++$ring->{COUNT};
}
sub delete_value {
my ($ring, $value) = @_;
my $node = $ring->search($value);
return if $node == $ring->{DUMMY};
$ring->delete_node($node);
}
1;
use overload ('<=>' => \&threeway_compare);
sub threeway_compare {
my ($s1, $s2) = @_;
return uc($s1->{NAME}) cmp uc($s2->{NAME});
}
use overload ( '""' => \&stringify );
sub stringify {
my $self = shift;
return sprintf "%s (%05d)",
ucfirst(lc($self->{NAME})),
$self->{IDNUM};
}
package TimeNumber;
use overload '+' => \&my_plus,
'-' => \&my_minus,
'*' => \&my_star,
'/' => \&my_slash;
sub my_plus {
my($left, $right) = @_;
my $answer = $left->
new();
$answer->{SECONDS} = $left->{SECONDS} + $right->{SECONDS};
$answer->{MINUTES} = $left->{MINUTES} + $right->{MINUTES};
$answer->{HOURS} = $left->{HOURS} + $right->{HOURS};
if ($answer->{SECONDS} >= 60) {
$answer->{SECONDS} %= 60;
$answer->{MINUTES} ++;
}
if ($answer->{MINUTES} >= 60) {
$answer->{MINUTES} %= 60;
$answer->{HOURS} ++;
}
return $answer;
}
use StrNum;
$x = StrNum("Red"); $y = StrNum("Black");
$z = $x + $y; $r = $z * 3;
print "values are $x, $y, $z, and $r\n";
print "$x is ", $x < $y ? "LT" : "GE", " $y\n";
package StrNum;
use Exporter ();
@ISA = 'Exporter';
@EXPORT = qw(StrNum);
use overload (
'<=>' => \&spaceship,
'cmp' => \&spaceship,
'""' => \&stringify,
'bool' => \&boolify,
'0+' => \&numify,
'+' => \&concat,
'*' => \&repeat,
);
sub StrNum($) {
my ($value) = @_;
return bless \$value;
}
sub stringify { ${ $_[0] } }
sub numify { ${ $_[0] } }
sub boolify { ${ $_[0] } }
sub spaceship {
my ($s1, $s2, $inverted) = @_;
return $inverted ? $$s2 cmp $$s1 : $$s1 cmp $$s2;
}
sub concat {
my ($s1, $s2, $inverted) = @_;
return StrNum $inverted ? ($s2 . $s1) : ($s1 . $s2);
}
sub repeat {
my ($s1, $s2, $inverted) = @_;
return StrNum $inverted ? ($s2 x $s1) : ($s1 x $s2);
}
1;
use FixNum;
FixNum->places(5);
$x = FixNum->new(40);
$y = FixNum->new(12);
print "sum of $x and $y is ", $x + $y, "\n";
print "product of $x and $y is ", $x * $y, "\n";
$z = $x / $y;
printf "$z has %d places\n", $z->places;
$z->places(2) unless $z->places;
print "div of $x by $y is $z\n";
print "square of that is ", $z * $z, "\n";
sum of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 52
product of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 480
STRFixNum: 3 has 0 places
div of STRFixNum: 40 by STRFixNum: 12 is STRFixNum: 3.33
square of that is STRFixNum: 11.11
package FixNum;
use strict;
my $PLACES = 0;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $parent = ref($proto) && $proto;
my $v = shift;
my $self = {
VALUE => $v,
PLACES => undef,
};
if ($parent && defined $parent->{PLACES}) {
$self->{PLACES} = $parent->{PLACES};
} elsif ($v =~ /(\.\d*)/) {
$self->{PLACES} = length($1) - 1;
} else {
$self->{PLACES} = 0;
}
return bless $self, $class;
}
sub places {
my $proto = shift;
my $self = ref($proto) && $proto;
my $type = ref($proto) || $proto;
if (@_) {
my $places = shift;
($self ? $self->{PLACES} : $PLACES) = $places;
}
return $self ? $self->{PLACES} : $PLACES;
}
sub _max { $_[0] > $_[1] ? $_[0] : $_[1] }
use overload '+' => \&add,
'*' => \&multiply,
'/' => \÷,
'<=>' => \&spaceship,
'""' => \&as_string,
'0+' => \&as_number;
sub add {
my ($this, $that, $flipped) = @_;
my $result = $this->new( $this->{VALUE} + $that->{VALUE} );
$result->places( _max($this->{PLACES}, $that->{PLACES} ));
return $result;
}
sub multiply {
my ($this, $that, $flipped) = @_;
my $result = $this->new( $this->{VALUE} * $that->{VALUE} );
$result->places( _max($this->{PLACES}, $that->{PLACES} ));
return $result;
}
sub divide {
my ($this, $that, $flipped) = @_;
my $result = $this->new( $this->{VALUE} / $that->{VALUE} );
$result->places( _max($this->{PLACES}, $that->{PLACES} ));
return $result;
}
sub as_string {
my $self = shift;
return sprintf("STR%s: %.*f", ref($self),
defined($self->{PLACES}) ? $self->{PLACES} : $PLACES,
$self->{VALUE});
}
sub as_number {
my $self = shift;
return $self->{VALUE};
}
sub spaceship {
my ($this, $that, $flipped) = @_;
$this->{VALUE} <=> $that->{VALUE};
}
1;
tie $s, "SomeClass"
SomeClass->
TIESCALAR()
$p = $s
$p = $obj->
FETCH()
$s = 10
$obj->STORE(10)
use ValueRing;
tie $color, 'ValueRing', qw(red blue);
print "$color $color $color $color $color $color\n";
red blue red blue red blue
$color = 'green';
print "$color $color $color $color $color $color\n";
green red blue green red blue
package ValueRing;
sub TIESCALAR {
my ($class, @values) = @_;
bless \@values, $class;
return \@values;
}
sub FETCH {
my $self = shift;
push(@$self, shift(@$self));
return $self->[-1];
}
sub STORE {
my ($self, $value) = @_;
unshift @$self, $value;
return $value;
}
1;
no UnderScore;
no UnderScore;
@tests = (
"Assignment" => sub { $_ = "Bad" },
"Reading" => sub { print },
"Matching" => sub { $x = /badness/ },
"Chop" => sub { chop },
"Filetest" => sub { -x },
"Nesting" => sub { for (1..3) { print } },
);
while ( ($name, $code) = splice(@tests, 0, 2) ) {
print "Testing $name: ";
eval { &$code };
print $@ ? "detected" : "missed!";
print "\n";
}
Testing Assignment: detected
Testing Reading: detected
Testing Matching: detected
Testing Chop: detected
Testing Filetest: detected
Testing Nesting: 123missed!
package UnderScore;
use Carp;
sub TIESCALAR {
my $class = shift;
my $dummy;
return bless \$dummy => $class;
}
sub FETCH { croak "Read access to \$_ forbidden" }
sub STORE { croak "Write access to \$_ forbidden" }
sub unimport { tie($_, _ _PACKAGE_ _) }
sub import { untie $_ }
tie($_, _ _PACKAGE_ _) unless tied $_;
1;
use Tie::AppendHash;
tie %tab, 'Tie::AppendHash';
$tab{beer} = "guinness";
$tab{food} = "potatoes";
$tab{food} = "peas";
while (my($k, $v) = each %tab) {
print "$k => [@$v]\n";
}
food => [potatoes peas]
beer => [guinness]
package Tie::AppendHash;
use strict;
use Tie::Hash;
use Carp;
use vars qw(@ISA);
@ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
push @{$self->{key}}, $value;
}
1;
use Tie::Folded;
tie %tab, 'Tie::Folded';
$tab{VILLAIN} = "big ";
$tab{herOine} = "red riding hood";
$tab{villain} .= "bad wolf";
while ( my($k, $v) = each %tab ) {
print "$k is $v\n";
}
heroine is red riding hood
villain is big bad wolf
package Tie::Folded;
use strict;
use Tie::Hash;
use vars qw(@ISA);
@ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
return $self->{lc $key} = $value;
}
sub FETCH {
my ($self, $key) = @_;
return $self->{lc $key};
}
sub EXISTS {
my ($self, $key) = @_;
return exists $self->{lc $key};
}
sub DEFINED {
my ($self, $key) = @_;
return defined $self->{lc $key};
}
1;
use strict;
use Tie::RevHash;
my %tab;
tie %tab, 'Tie::RevHash';
%tab = qw{
Red Rojo
Blue Azul
Green Verde
};
$tab{EVIL} = [ "No way!", "Way!!" ];
while ( my($k, $v) = each %tab ) {
print ref($k) ? "[@$k]" : $k, " => ",
ref($v) ? "[@$v]" : $v, "\n";
}
[No way! Way!!] => EVIL
EVIL => [No way! Way!!]
Blue => Azul
Green => Verde
Rojo => Red
Red => Rojo
Azul => Blue
Verde => Green
package Tie::RevHash;
use Tie::RefHash;
use vars qw(@ISA);
@ISA = qw(Tie::RefHash);
sub STORE {
my ($self, $key, $value) = @_;
$self->SUPER::STORE($key, $value);
$self->SUPER::STORE($value, $key);
}
sub DELETE {
my ($self, $key) = @_;
my $value = $self->SUPER::FETCH($key);
$self->SUPER::DELETE($key);
$self->SUPER::DELETE($value);
}
1;
use Counter;
tie *CH, 'Counter';
while (<CH>) {
print "Got $_\n";
}
package Counter;
sub TIEHANDLE {
my $class = shift;
my $start = shift;
return bless \$start => $class;
}
sub READLINE {
my $self = shift;
return ++$$self;
}
1;
use Tie::Tee;
tie *TEE, 'Tie::Tee', *STDOUT, *STDERR;
print TEE "This line goes both places.\n";
use Tie::Tee;
use Symbol;
@handles = (*STDOUT);
for $i ( 1 .. 10 ) {
push(@handles, $handle = gensym());
open($handle, ">/tmp/teetest.$i");
}
tie *TEE, 'Tie::Tee', @handles;
print TEE "This lines goes many places.\n";
package Tie::Tee;
sub TIEHANDLE {
my $class = shift;
my $handles = [@_];
bless $handles, $class;
return $handles;
}
sub PRINT {
my $href = shift;
my $handle;
my $success = 0;
foreach $handle (@$href) {
$success += print $handle @_;
}
return $success == @$href;
}
1;
AsciiDB DBI Db MLDBM OLE Pg Sybase
CDB_File DBZ_ File Fame Msql ObjStore Postgres XBase
DBD DB_File Ingperl MySQL Oraperl Sprite
use DB_File; dbmopen %HASH, $FILENAME, 0666 %HASH or die "Can't open $FILENAME: $!\n";
$V = $HASH{$KEY}; $HASH{$KEY} = $VALUE; if (exists $HASH{$KEY}) { }
delete $HASH{$KEY}; dbmclose %HASH; use DB_File;
tie %HASH, "DB_File", $FILENAME or die "Can't open $FILENAME:$!\n"; %HASH
$V = $HASH{$KEY}; $HASH{$KEY} = $VALUE; if (exists $HASH{$KEY}) { }
delete $HASH{$KEY}; untie %hash;
use DB_File;
$db = '/tmp/userstats.db';
tie(%db, 'DB_File', $db) or die "Can't open DB_File $db : $!\n";
if (@ARGV) {
if ("@ARGV" eq "ALL") {
@ARGV = sort keys %db;
}
foreach $user (@ARGV) {
print "$user\t$db{$user}\n";
}
} else {
@who = `who`; if ($?) {
die "Couldn't run who: $?\n"; }
foreach $line (@who) {
$line =~ /^(\S+)/;
die "Bad line from who: $line\n" unless $1;
$db{$1}++;
}
}
untie %db;
gnat ttyp1 May 29 15:39 (coprolith.frii.com)
dbmopen(%HASH, $FILENAME, 0666) or die "Can't open FILENAME: $!\n";
%HASH = ();
dbmclose %HASH;
use DB_File;
tie(%HASH, "DB_File", $FILENAME) or die "Can't open FILENAME: $!\n";
%HASH = ();
untie %hash;
unlink $FILENAME
or die "Couldn't unlink $FILENAME to empty the database: $!\n";
dbmopen(%HASH, $FILENAME, 0666)
or die "Couldn't create $FILENAME database: $!\n";
use strict;
use DB_File;
use GDBM_File;
unless (@ARGV == 2) {
die "usage: db2gdbm infile outfile\n";
}
my ($infile, $outfile) = @ARGV;
my (%db_in, %db_out);
tie(%db_in, 'DB_File', $infile)
or die "Can't tie $infile: $!";
tie(%db_out, 'GDBM_File', $outfile, GDBM_WRCREAT, 0666)
or die "Can't tie $outfile: $!";
%db_out%db_inwhile (my($k, $v) = each %db_in) {
$db_out{$k} = $v;
}
untie %db_in;
untie %db_out;
%OUTPUT = (%INPUT1, %INPUT2);
%OUTPUT = ();
foreach $href ( \%INPUT1, \%INPUT2 ) {
while (my($key, $value) = each(%$href)) {
if (exists $OUTPUT{$key}) {
$OUTPUT } else {
$OUTPUT{$key} = $value;
}
}
}
use DB_File;
use strict;
sub LOCK_SH { 1 } sub LOCK_EX { 2 } sub LOCK_NB { 4 } sub LOCK_UN { 8 }
my($oldval, $fd, $db, %db, $value, $key);
$key = shift || 'default';
$value = shift || 'magic';
$value .= " $$";
$db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666)
or die "dbcreat /tmp/foo.db $!";
$fd = $db->fd; print "$$: db fd is $fd\n";
open(DB_FH, "+<&=$fd")
or die "dup $!";
unless (flock (DB_FH, LOCK_SH | LOCK_NB)) {
print "$$: CONTENTION; can't read during write update!
Waiting for read lock ($!) ....";
unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" }
}
print "$$: Read lock granted\n";
$oldval = $db{$key};
print "$$: Old value was $oldval\n";
flock(DB_FH, LOCK_UN);
unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
print "$$: CONTENTION; must have exclusive lock!
Waiting for write lock ($!) ....";
unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" }
}
print "$$: Write lock granted\n";
$db{$key} = $value;
$db->sync; sleep 10;
flock(DB_FH, LOCK_UN);
undef $db;
untie %db;
close(DB_FH);
print "$$: Updated db to $key=$value\n";
use DB_File;
$DB_BTREE->{'compare'} = sub {
my ($key1, $key2) = @_ ;
return "\L$key1" cmp "\L$key2";
};
tie(%hash, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE)
or die "can't tie $filename: $!";
use strict;
use DB_File;
$DB_BTREE->{'compare'} = sub {
my ($key1, $key2) = @_ ;
"\L$key1" cmp "\L$key2" ;
};
my %hash;
my $filename = '/tmp/sorthash.db';
tie(%hash, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE)
or die "can't tie $filename: $!";
my $i = 0;
for my $word (qw(Can't you go camp down by Gibraltar)) {
$hash{$word} = ++$i;
}
while (my($word, $number) = each %hash) {
printf "%-12s %d\n", $word, $number;
}
tie(%hash, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE)
or die "can't tie: $!";
use DB_File;
tie(@array, "DB_File", "/tmp/textfile", O_RDWR|O_CREAT, 0666, $DB_RECNO)
or die "Cannot open file 'text': $!\n" ;
$array[4] = "a new line";
untie @array;
use strict;
use vars qw(@lines $dbobj $file $i);
use DB_File;
$file = "/tmp/textfile";
unlink $file;
$dbobj = tie(@lines, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO)
or die "Cannot open file $file: $!\n";
$lines[0] = "zero";
$lines[1] = "one";
$lines[2] = "two";
$lines[3] = "three";
$lines[4] = "four";
print "\nORIGINAL\n";
foreach $i (0 .. $dbobj->length - 1) {
print "$i: $lines[$i]\n";
}
$a = $dbobj->pop;
$dbobj->push("last");
print "\nThe last record was [$a]\n";
$a = $dbobj->shift;
$dbobj->unshift("first");
print "The first record was [$a]\n";
$i = 2;
$dbobj->put($i, "Newbie", R_IAFTER);
$i = 1;
$dbobj->put($i, "New One", R_IBEFORE);
$dbobj->del(3);
print "\nREVERSE\n";
for ($i = $dbobj->length - 1; $i >= 0; -- $i) {
print "$i: $lines[$i]\n";
}
print "\nREVERSE again\n";
my ($s, $k, $v) = (0, 0, 0);
for ($s = $dbobj->seq($k, $v, R_LAST);
$s == 0;
$s = $dbobj->seq($k, $v, R_PREV))
{
print "$k: $v\n"
}
undef $dbobj;
untie @lines;
foreach $item (@lines) { }
foreach $i (0 .. $dbobj->length - 1) { }
for ($done_yet = $dbobj->get($k, $v, R_FIRST);
not $done_yet;
$done_yet = $dbobj->get($k, $v, R_NEXT) )
{
}
use MLDBM 'DB_File';
tie(%HASH, 'MLDBM', [... other DBM arguments]) or die $!;
%hash$hash{"Tom Christiansen"} = [ "book author", 'tchrist@perl.com' ];
$hash{"Tom Boutell"} = [ "shareware author", 'boutell@boutell.com' ];
$name1 = "Tom Christiansen";
$name2 = "Tom Boutell";
$tom1 = $hash{$name1}; $tom2 = $hash{$name2};
print "Two Toming: $tom1 $tom2\n";
Tom Toming: ARRAY(0x73048) ARRAY(0x73e4c)
if ($tom1->[0] eq $tom2->[0] &&
$tom1->[1] eq $tom2->[1]) {
print "You're having runtime fun with one Tom made two.\n";
} else {
print "No two Toms are ever alike.\n";
}
if ($hash{$name1}->[0] eq $hash{$name2}->[0] && $hash{$name1}->[1] eq $hash{$name2}->[1]) {
print "You're having runtime fun with one Tom made two.\n";
} else {
print "No two Toms are ever alike.\n";
}
$hash{"Tom Boutell"}->[0] = "Poet Programmer"; $entry = $hash{"Tom Boutell"}; $entry->[0] = "Poet Programmer";
$hash{"Tom Boutell"} = $entry;
use MLDBM 'DB_File';
my ($VARIABLE1,$VARIABLE2);
my $Persistent_Store = '/projects/foo/data';
BEGIN {
my %data;
tie(%data, 'MLDBM', $Persistent_Store)
or die "Can't tie to $Persistent_Store : $!";
$VARIABLE1 = $data{VARIABLE1};
$VARIABLE2 = $data{VARIABLE2};
untie %data;
}
END {
my %data;
tie (%data, 'MLDBM', $Persistent_Store)
or die "Can't tie to $Persistent_Store : $!";
$data{VARIABLE1} = $VARIABLE1;
$data{VARIABLE2} = $VARIABLE2;
untie %data;
}
push(@{$db{$user}}, $duration);
use MLDBM "DB_File";
$db = "/tmp/mldbm-array";
tie %db, 'MLDBM', $db
or die "Can't open $db : $!";
while(<DATA>) {
chomp;
($user, $duration) = split(/\s+/, $_);
$array_ref = exists $db{$user} ? $db{$user} : [];
push(@$array_ref, $duration);
$db{$user} = $array_ref;
}
foreach $user (sort keys %db) {
print "$user: ";
$total = 0;
foreach $duration (@{ $db{$user} }) {
print "$duration ";
$total += $duration;
}
print "($total)\n";
}
use MLDBM qw(DB_File Storable);
use DBI;
$dbh = DBI->connect('DBI:driver:database', 'username', 'auth',
{ RaiseError => 1, AutoCommit => 1});
$dbh->do($sql);
$sth = $dbh->prepare($sql);
$sth->execute();
while (@row = $sth->fetchrow_array) {
}
$sth->finish();
$dbh->disconnect();
use DBI;
use User::pwent;
$dbh = DBI->connect('DBI:mysql:dbname:mysqlserver.domain.com:3306',
'user', 'password',
{ RaiseError => 1 })
or die "connecting : $DBI::errstr\n";
$dbh->do("CREATE TABLE users (uid INT, login CHAR(8))");
$sql_fmt = "INSERT INTO users VALUES( %d, %s )";
while ($user = getpwent) {
$sql = sprintf($sql_fmt, $user->uid, $dbh->quote($user->name));
$dbh->do($sql);
}
$sth = $dbh->prepare("SELECT * FROM users WHERE uid < 50");
$sth->execute;
while ((@row) = $sth->fetchrow) {
print join(", ", map {defined $_ ? $_ : "(null)"} @row), "\n";
}
$sth->finish;
$dbh->do("DROP TABLE users");
$dbh->disconnect;
$USAGE = <<EO_COMPLAINT;
usage: $0 [-database dbfilename] [-help]
[-epochtime | -localtime | -gmtime]
[ [-regexp] pattern] | href ... ]
EO_COMPLAINT
use Getopt::Long;
($opt_database, $opt_epochtime, $opt_localtime,
$opt_gmtime, $opt_regexp, $opt_help,
$pattern, ) = (0) x 7;
usage() unless GetOptions qw{ database=s
regexp=s
epochtime localtime gmtime
help
};
if ($opt_help) { print $USAGE; exit; }
usage("only one of localtime, gmtime, and epochtime allowed")
if $opt_localtime + $opt_gmtime + $opt_epochtime > 1;
if ( $opt_regexp ) {
$pattern = $opt_regexp;
} elsif (@ARGV && $ARGV[0] !~ m(://)) {
$pattern = shift;
}
usage("can't mix URLs and explicit patterns")
if $pattern && @ARGV;
if ($pattern && !eval { '' =~ /$pattern/; 1 } ) {
$@ =~ s/ at \w+ line \d+\.//;
die "$0: bad pattern $@";
}
require DB_File; DB_File->import(); $| = 1;
$dotdir = $ENV{HOME} || $ENV{LOGNAME};
$HISTORY = $opt_database || "$dotdir/.netscape/history.db";
die "no netscape history dbase in $HISTORY: $!" unless -e $HISTORY;
die "can't dbmopen $HISTORY: $!" unless dbmopen %hist_db, $HISTORY, 0666;
$add_nulls = (ord(substr(each %hist_db, -1)) == 0);
$nulled_href = "";
$byte_order = "V";
if (@ARGV) {
foreach $href (@ARGV) {
$nulled_href = $href . ($add_nulls && "\0");
unless ($binary_time = $hist_db{$nulled_href}) {
warn "$0: No history entry for HREF $href\n";
next;
}
$epoch_secs = unpack($byte_order, $binary_time);
$stardate = $opt_epochtime ? $epoch_secs
: $opt_gmtime ? gmtime $epoch_secs
: localtime $epoch_secs;
print "$stardate $href\n";
}
} else {
while ( ($href, $binary_time) = each %hist_db ) {
chop $href if $add_nulls;
$binary_time = pack($byte_order, 0) unless $binary_time;
$epoch_secs = unpack($byte_order, $binary_time);
$stardate = $opt_epochtime ? $epoch_secs
: $opt_gmtime ? gmtime $epoch_secs
: localtime $epoch_secs;
print "$stardate $href\n" unless $pattern && $href !~ /$pattern/o;
}
}
sub usage {
print STDERR "@_\n" if @_;
die $USAGE;
}
use Getopt::Std;
getopt("vDo");
$argsv$argsD$argsogetopt("vDo", \%args);
getopts("vDo:"); getopts("vDo:", \%args); $argsv$argsD$argsouse Getopt::Long;
GetOptions( "verbose" => \$verbose, "Debug" => \$debug, "output=s" => \$output ); use Getopt::Std;
getopts("o:");
if ($opt_o) {
print "Writing output to $opt_o";
}
use Getopt::Std;
%option = ();
getopts("Do:", \%option);
if ($option{D}) {
print "Debugging mode enabled.\n";
}
$option{o} = "-" unless defined $option{o};
print "Writing output to file $option{o}\n" unless $option{o} eq "-";
open(STDOUT, "> $option{o}")
or die "Can't open $option{o} for output: $!\n";
use Getopt::Long;
GetOptions( "extract" => \$extract,
"file=s" => \$file );
if ($extract) {
print "I'm extracting.\n";
}
die "I wish I had a file" unless defined $file;
print "Working on the file $file\n";
sub I_am_interactive {
return -t STDIN && -t STDOUT;
}
use POSIX qw/getpgrp tcgetpgrp/;
sub I_am_interactive {
local *TTY; open(TTY, "/dev/tty") or die "can't open /dev/tty: $!";
my $tpgrp = tcgetpgrp(fileno(TTY));
my $pgrp = getpgrp();
close TTY;
return ($tpgrp == $pgrp);
}
while (1) {
if (I_am_interactive()) {
print "Prompt: ";
}
$line = <STDIN>;
last unless defined $line;
}
sub prompt { print "Prompt: " if I_am_interactive() }
for (prompt(); $line = <STDIN>; prompt()) {
}
use Term::Cap;
$OSPEED = 9600;
eval {
require POSIX;
my $termios = POSIX::Termios->new();
$termios->getattr;
$OSPEED = $termios->getospeed;
};
$terminal = Term::Cap->Tgetent({OSPEED=>$OSPEED});
$terminal->Tputs('cl', 1, STDOUT);
system("clear");
$clear = $terminal->Tputs('cl');
$clear = `clear`;
print $clear;
use Term::ReadKey;
($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize();
use Term::ReadKey;
($width) = GetTerminalSize();
die "You must have at least 10 characters" unless $width >= 10;
$max = 0;
foreach (@values) {
$max = $_ if $max < $_;
}
$ratio = ($width-10)/$max; foreach (@values) {
printf("%8.1f %s\n", $_, "*" x ($ratio*$_));
}
use Term::ANSIColor;
print color("red"), "Danger, Will Robinson!\n", color("reset");
print "This is just normal text.\n";
print colored("<BLINK>Do you hurt yet?</BLINK>", "blink");
use Term::ANSIColor qw(:constants);
print RED, "Danger, Will Robinson!\n", RESET;
print color("red on_black"), "venom lack\n";
print color("red on_yellow"), "kill that fellow\n";
print color("green on_cyan blink"), "garish!\n";
print color("reset");
print colored("venom lack\n", "red", "on_black");
print colored("kill that fellow\n", "red", "on_yellow");
print colored("garish!\n", "green", "on_cyan", "blink");
use Term::ANSIColor qw(:constants);
print BLACK, ON_WHITE, "black on white\n";
print WHITE, ON_BLACK, "white on black\n";
print GREEN, ON_CYAN, BLINK, "garish!\n";
print RESET;
END { print color("reset") }
$Term::ANSIColor::EACHLINE = $/;
print colored(<<EOF, RED, ON_WHITE, BOLD, BLINK);
This way
each line
has its own
attribute set.
EOF
use Term::ReadKey;
ReadMode('cbreak');
$key = ReadKey(0);
ReadMode('normal');
use Term::ReadKey;
ReadMode('cbreak');
print "Press keys to see their ASCII values. Use Ctrl-C to quit.\n";
while (1) {
$char = ReadKey(0);
last unless defined $char;
printf(" Decimal: %d\tHex: %x\n", ord($char), ord($char));
}
ReadMode('normal');
print "\aWake up!\n";
use Term::Cap;
$OSPEED = 9600;
eval {
require POSIX;
my $termios = POSIX::Termios->new();
$termios->getattr;
$OSPEED = $termios->getospeed;
};
$terminal = Term::Cap->Tgetent({OSPEED=>$OSPEED});
$vb = "";
eval {
$terminal->Trequire("vb");
$vb = $terminal->Tputs('vb', 1);
};
print $vb;
use POSIX qw(:termios_h);
$term = POSIX::Termios->new;
$term->getattr(fileno(STDIN));
$erase = $term->getcc(VERASE);
$kill = $term->getcc(VKILL);
printf "Erase is character %d, %s\n", $erase, uncontrol(chr($erase));
printf "Kill is character %d, %s\n", $kill, uncontrol(chr($kill));
$term->setcc(VERASE, ord('#'));
$term->setcc(VKILL, ord('@'));
$term->setattr(1, TCSANOW);
print("erase is #, kill is @; type something: ");
$line = <STDIN>;
print "You typed: $line";
$term->setcc(VERASE, $erase);
$term->setcc(VKILL, $kill);
$term->setattr(1, TCSANOW);
sub uncontrol {
local $_ = shift;
s/([\200-\377])/sprintf("M-%c",ord($1) & 0177)/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1) ^ 0100)/eg;
return $_;
}
package HotKey;
@ISA = qw(Exporter);
@EXPORT = qw(cbreak cooked readkey);
use strict;
use POSIX qw(:termios_h);
my ($term, $oterm, $echo, $noecho, $fd_stdin);
$fd_stdin = fileno(STDIN);
$term = POSIX::Termios->new();
$term->getattr($fd_stdin);
$oterm = $term->getlflag();
$echo = ECHO | ECHOK | ICANON;
$noecho = $oterm & ~$echo;
sub cbreak {
$term->setlflag($noecho); $term->setcc(VTIME, 1);
$term->setattr($fd_stdin, TCSANOW);
}
sub cooked {
$term->setlflag($oterm);
$term->setcc(VTIME, 0);
$term->setattr($fd_stdin, TCSANOW);
}
sub readkey {
my $key = '';
cbreak();
sysread(STDIN, $key, 1);
cooked();
return $key;
}
END { cooked() }
1;
use Term::ReadKey;
ReadMode ('cbreak');
if (defined ($char = ReadKey(-1)) ) {
} else {
}
ReadMode ('normal');
use Term::ReadKey;
ReadMode('noecho');
$password = ReadLine(0);
use Term::ReadKey;
print "Enter your password: ";
ReadMode 'noecho';
$password = ReadLine 0;
chomp $password;
ReadMode 'normal';
print "\n";
($username, $encrypted) = ( getpwuid $< )[0,1];
if (crypt($password, $encrypted) ne $encrypted) {
die "You are not $username\n";
} else {
print "Welcome, $username\n";
}
use Term::ReadLine;
$term = Term::ReadLine->new("APP DESCRIPTION");
$OUT = $term->OUT || *STDOUT;
$term->addhistory($fake_line);
$line = $term->readline(PROMPT);
print $OUT "Any program output\n";
use strict;
use Term::ReadLine;
use POSIX qw(:sys_wait_h);
my $term = Term::ReadLine->new("Simple Shell");
my $OUT = $term->OUT() || *STDOUT;
my $cmd;
while (defined ($cmd = $term->readline('$ ') )) {
my @output = `$cmd`;
my $exit_value = $? >> 8;
my $signal_num = $? & 127;
my $dumped_core = $? & 128;
printf $OUT "Program terminated with status %d from signal %d%s\n",
$exit_value, $signal_num,
$dumped_core ? " (core dumped)" : "";
print @output;
$term->addhistory($seed_line);
}
$term->addhistory($seed_line);
$term->remove_history($line_number);
@history = $term->GetHistory;
use strict;
use Curses;
my $timeout = 10;
if (@ARGV && $ARGV[0] =~ /^-(\d+\.?\d*)$/) {
$timeout = $1;
shift;
}
die "usage: $0 [ -timeout ] cmd args\n" unless @ARGV;
initscr(); noecho();
cbreak();
nodelay(1);
$SIG{INT} = sub { done("Ouch!") };
sub done { endwin(); print "@_\n"; exit; }
while (1) {
while ((my $key = getch()) ne ERR) { done("See ya") if $key eq 'q'
}
my @data = `(@ARGV) 2>&1`; for (my $i = 0; $i < $LINES; $i++) {
addstr($i, 0, $data[$i] || ' ' x $COLS);
}
standout();
addstr($LINES-1, $COLS - 24, scalar localtime);
standend();
move(0,0);
refresh();
my ($in, $out) = ('', '');
vec($in,fileno(STDIN),1) = 1; select($out = $in,undef,undef,$timeout);}
keypad(1); $key = getch();
if ($key eq 'k' || $key eq "\cP" || $key eq KEY_UP) {
}
use Expect;
$command = Expect->spawn("program to run")
or die "Couldn't start program: $!\n";
$command->log_stdout(0);
unless ($command->expect(10, "Password")) {
}
unless ($command->expect(20, -re => '[lL]ogin: ?')) {
}
unless ($command->expect(undef, "invalid")) {
}
print $command "Hello, world\r";
$command->soft_close();
$command->hard_close();
$which = $command->expect(30, "invalid", "succes", "error", "boom");
if ($which) {
}
use Tk;
$main = MainWindow->new();
$menubar = $main->Frame(-relief => "raised",
-borderwidth => 2)
->pack (-anchor => "nw",
-fill => "x");
$file_menu = $menubar->Menubutton(-text => "File",
-underline => 1)
->pack (-side => "left" );
$file_menu->command(-label => "Print",
-command => \&Print);
$file_menu = $menubar->Menubutton(-text => "File",
-underline => 1,
-menuitems => [
[ Button => "Print",-command => \&Print ],
[ Button => "Save",-command => \&Save ] ])
->pack(-side => "left");
$file_menu->command(-label => "Quit Immediately",
-command => sub { exit } );
$file_menu->separator();
$options_menu->checkbutton(-label => "Create Debugging File",
-variable => \$debug,
-onvalue => 1,
-offvalue => 0);
$debug_menu->radiobutton(-label => "Level 1",
-variable => \$log_level,
-value => 1);
$debug_menu->radiobutton(-label => "Level 2",
-variable => \$log_level,
-value => 2);
$debug_menu->radiobutton(-label => "Level 3",
-variable => \$log_level,
-value => 3);
$format_menu->cascade (-label => "Font");
$font_menu = $format_menu->cget("-menu");
$font_menu->radiobutton (-label => "Courier",
-variable => \$font_name,
-value => "courier");
$font_menu->radiobutton (-label => "Times Roman",
-variable => \$font_name,
-value => "times");
$format_menu = $menubar->Menubutton(-text => "Format",
-underline => 1
-tearoff => 0)
->pack;
$font_menu = $format_menu->cascade(-label => "Font",
-tearoff => 0);
my $f = $menubar->Menubutton(-text => "Edit", -underline => 0,
-menuitems =>
[
[Button => 'Copy', -command => \&edit_copy ],
[Button => 'Cut', -command => \&edit_cut ],
[Button => 'Paste', -command => \&edit_paste ],
[Button => 'Delete', -command => \&edit_delete ],
[Separator => ''],
[Cascade => 'Object ...', -tearoff => 0,
-menuitems => [
[ Button => "Circle", -command => \&edit_circle ],
[ Button => "Square", -command => \&edit_square ],
[ Button => "Point", -command => \&edit_point ] ] ],
])->grid(-row => 0, -column => 0, -sticky => 'w');
use Tk::DialogBox;
$dialog = $main->DialogBox( -title => "Register This Program",
-buttons => [ "Register", "Cancel" ] );
$button = $dialog->Show();
if ($button eq "Register") {
} elsif ($button eq "Cancel") {
} else {
}
use Tk;
use Tk::DialogBox;
$main = MainWindow->new();
$dialog = $main->DialogBox( -title => "Register",
-buttons => [ "Register", "Cancel" ],
);
$dialog->add("Label", -text => "Name")->pack();
$entry = $dialog->add("Entry", -width => 35)->pack();
$main->Button( -text => "Click Here For Registration Form",
-command => \®ister) ->pack(-side => "left");
$main->Button( -text => "Quit",
-command => sub { exit } ) ->pack(-side => "left");
MainLoop;
sub register {
my $button;
my $done = 0;
do {
$button = $dialog->Show;
if ($button eq "Register") {
my $name = $entry->get;
if (defined($name) && length($name)) {
print "Welcome to the fold, $name\n";
$done = 1;
} else {
print "You didn't give me your name!\n";
}
} else {
print "Sorry you decided not to register.\n";
$done = 1;
}
} until $done;
}
use Tk;
use Tk::DialogBox;
my $main;
BEGIN {
$SIG{_ _WARN_ _} = sub {
if (defined $main) {
my $dialog = $main->DialogBox( -title => "Warning",
-buttons => [ "Acknowledge" ]);
$dialog->add("Label", -text => $_[0])->pack;
$dialog->Show;
} else {
print STDOUT join("\n", @_), "n";
}
};
}
$main = MainWindow->new();
$main->Button( -text => "Make A Warning",
-command => \&make_warning) ->pack(-side => "left");
$main->Button( -text => "Quit",
-command => sub { exit } ) ->pack(-side => "left");
MainLoop;
sub make_warning {
my $a;
my $b = 2 * $a;
}
use Tk;
$main = MainWindow->new();
$main->bind('<Configure>' => sub {
$xe = $main->XEvent;
$main->maxsize($xe->w, $xe->h);
$main->minsize($xe->w, $xe->h);
});
$widget->pack( -fill => "both", -expand => 1 );
$widget->pack( -fill => "x", -expand => 1 );
$mainarea->pack( -fill => "both", -expand => 1);
$menubar->pack( -fill => "x", -expand => 1 );
$menubar->pack (-fill => "x",
-expand => 1,
-anchor => "nw" );
use strict;
use Win32;
use Win32::Process;
Win32::Process::Create($Win32::Process::Create::ProcessObj,
'C:/perl5/bin/perl.exe', 'perl realprogram', 0, DETACHED_PROCESS, ".") or die print_error();
sub print_error() {
return Win32::FormatMessage( Win32::GetLastError() );
}
use POSIX;
use Term::Cap;
init(); zip(); finish(); exit();
sub clear_screen { $tcap->Tputs('cl', 1, *STDOUT) }
sub clear_end { $tcap->Tputs('cd', 1, *STDOUT) }
sub gotoxy {
my($x, $y) = @_;
$tcap->Tgoto('cm', $x, $y, *STDOUT);
}
sub init {
$| = 1;
$delay = (shift() || 0) * 0.005;
my $termios = POSIX::Termios->new();
$termios->getattr;
my $ospeed = $termios->getospeed;
$tcap = Term::Cap->Tgetent ({ TERM => undef, OSPEED => $ospeed });
$tcap->Trequire(qw(cl cm cd));
}
sub zip {
clear_screen();
($maxrow, $maxcol) = ($tcap->{_li} - 1, $tcap->{_co} - 1);
@chars = qw(* - / | \ _ );
sub circle { push(@chars, shift @chars); }
$interrupted = 0;
$SIG{INT} = sub { ++$interrupted };
$col = $row = 0;
($row_sign, $col_sign) = (1,1);
do {
gotoxy($col, $row);
print $chars[0];
select(undef, undef, undef, $delay);
$row += $row_sign;
$col += $col_sign;
if ($row == $maxrow) { $row_sign = -1; circle; }
elsif ($row == 0 ) { $row_sign = +1; circle; }
if ($col == $maxcol) { $col_sign = -1; circle; }
elsif ($col == 0 ) { $col_sign = +1; circle; }
} until $interrupted;
}
sub finish {
gotoxy(0, $maxrow);
clear_end();
}
use Tk;
use strict;
my $podfile; my $m; my $l; my ($up, $down); my @sections; my $all_pod;
$podfile = shift || "-";
undef $/;
open(F, "< $podfile")
or die "Can't open $podfile : $!\n";
$all_pod = <F>;
close(F);
@sections = split(/(?==head1)/, $all_pod);
@sections
foreach (@sections) {
/(.*)/;
$_ = [ $_, $1 ];
}
$m = MainWindow->new();
$l = $m->Listbox('-width' => 60)->pack('-expand' => 1, '-fill' => 'both');
foreach my $section (@sections) {
$l->insert("end", $section->[1]);
}
$l->bind( '<Any-Button>' => \&down );
$l->bind( '<Any-ButtonRelease>' => \&up );
$l->bind( '<Double-Button>' => \&view );
$m->bind( '<q>' => sub { exit } );
$m->bind( '<s>' => \&save );
MainLoop;
sub down {
my $self = shift;
$down = $self->curselection;;
}
sub up {
my $self = shift;
my $elt;
$up = $self->curselection;;
return if $down == $up;
$elt = $sections[$down];
splice(@sections, $down, 1);
splice(@sections, $up, 0, $elt);
$self->delete($down);
$self->insert($up, $sections[$up]->[1]);
}
sub save {
my $self = shift;
open(F, "> $podfile")
or die "Can't open $podfile for writing: $!";
print F map { $_->[0] } @sections;
close F;
exit;
}
sub view {
my $self = shift;
my $temporary = "/tmp/$$-section.pod";
my $popup;
open(F, "> $temporary")
or warn ("Can't open $temporary : $!\n"), return;
print F $sections[$down]->[0];
close(F);
$popup = $m->Pod('-file' => $temporary);
$popup->bind('<Destroy>' => sub { unlink $temporary } );
}
$output = `program args`; @output = `program args`; open(README, "program args |") or die "Can't run program: $!\n";
while(<README>) {
$output .= $_;
}
close(README);
`fsck -y /dev/rsd1a`; use POSIX qw(:sys_wait_h);
pipe(README, WRITEME);
if ($pid = fork) {
$SIG{CHLD} = sub { 1 while ( waitpid(-1, WNOHANG)) > 0 };
close(WRITEME);
} else {
die "cannot fork: $!" unless defined $pid;
open(STDOUT, ">&=WRITEME") or die "Couldn't redirect STDOUT: $!";
close(README);
exec($program, $arg1, $arg2) or die "Couldn't run $program : $!\n";
}
while (<README>) {
$string .= $_;
@strings}
close(README);
$status = system("vi $myfile");
$status = system("vi", $myfile);
system("cmd1 args | cmd2 | cmd3 >outfile");
system("cmd args <infile >outfile 2>errfile");
$status = system($program, $arg1, $arg);
die "$program exited funny: $?" unless $status == 0;
if (($signo = system(@arglist)) &= 127) {
die "program killed by signal $signo\n";
}
if ($pid = fork) {
local $SIG{INT} = sub { print "Tsk tsk, no process interruptus\n" };
waitpid($pid, 0);
} else {
die "cannot fork: $!" unless defined $pid;
$SIG{INT} = "IGNORE";
exec("summarize", "/etc/logfiles") or die "Can't exec: $!\n";
}
$shell = '/bin/tcsh';
system $shell '-csh'; system {'/bin/tcsh'} '-csh'; system {'/home/tchrist/scripts/expn'} 'vrfy', @ADDRESSES;
@args = ( "echo surprise" );
system @args; @argssystem { $args[0] } @args;
exec("archive *.data")
or die "Couldn't replace myself with archive: $!\n";
exec("archive", "accounting.data")
or die "Couldn't replace myself with archive: $!\n";
exec("archive accounting.data")
or die "Couldn't replace myself with archive: $!\n";
$pid = open(README, "program arguments |") or die "Couldn't fork: $!\n";
while (<README>) {
}
close(README) or die "Couldn't close: $!\n";
$pid = open(WRITEME, "| program arguments") or die "Couldn't fork: $!\n";
print WRITEME "data\n";
close(WRITEME) or die "Couldn't close: $!\n";
$pid = open(F, "sleep 100000|"); close(F); $pid = open(WRITEME, "| program args");
print WRITEME "hello\n"; close(WRITEME); $pager = $ENV{PAGER} || '/usr/bin/less'; open(STDOUT, "| $pager");
head(100);
while (<>) {
print;
}
sub head {
my $lines = shift || 20;
return if $pid = open(STDOUT, "|-");
die "cannot fork: $!" unless defined $pid;
while (<STDIN>) {
print;
last unless --$lines ;
}
exit;
}
1: > Welcome to Linux, version 2.0.33 on a i686
2: >
3: > "The software required `Windows 95 or better',
4: > so I installed Linux."
> 1: Welcome to Linux, Kernel version 2.0.33 on a i686
> 2:
> 3: "The software required `Windows 95 or better',
> 4: so I installed Linux."
number(); quote();
while (<>) { print;
}
close STDOUT; exit;
sub number {
my $pid;
return if $pid = open(STDOUT, "|-");
die "cannot fork: $!" unless defined $pid;
while (<STDIN>) { printf "%d: %s", $., $_ }
exit;
}
sub quote {
my $pid;
return if $pid = open(STDOUT, "|-");
die "cannot fork: $!" unless defined $pid;
while (<STDIN>) { print "> $_" }
exit;
}
@ARGV = map { /\.(gz|Z)$/ ? "gzip -dc $_ |" : $_ } @ARGV;
while (<>) {
}
@ARGV = map { m#^\w+://# ? "GET $_ |" : $_ } @ARGV;
while (<>) {
}
$pwdinfo = `domainname` =~ /^(\(none\))?$/
? '< /etc/passwd'
: 'ypcat passwd |';
open(PWD, $pwdinfo) or die "can't open $pwdinfo: $!";
print "File, please? ";
chomp($file = <>);
open (FH, $file) or die "can't open $file: $!";
$output = `cmd 2>&1`; $pid = open(PH, "cmd 2>&1 |"); while (<PH>) { } $output = `cmd 2>/dev/null`; $pid = open(PH, "cmd 2>/dev/null |"); while (<PH>) { } $output = `cmd 2>&1 1>/dev/null`; $pid = open(PH, "cmd 2>&1 1>/dev/null |"); while (<PH>) { } $output = `cmd 3>&1 1>&2 2>&3 3>&-`; $pid = open(PH, "cmd 3>&1 1>&2 2>&3 3>&-|"); while (<PH>) { } system("program args 1>/tmp/program.stdout 2>/tmp/program.stderr");
$output = `cmd 3>&1 1>&2 2>&3 3>&-`;
$fd3 = $fd1;
$fd1 = $fd2;
$fd2 = $fd3;
$fd3 = undef;
system("prog args 1>tmpfile 2>&1");
system("prog args 2>&1 1>tmpfile");
$fd1 = "tmpfile"; $fd2 = $fd1; $fd2 = $fd1; $fd1 = "tmpfile";
use IPC::Open2;
open2(*README, *WRITEME, $program);
print WRITEME "here's your input\n";
$output = <README>;
close(WRITEME);
close(README);
open(DOUBLE_HANDLE, "| program args |") use IPC::Open2;
use IO::Handle;
($reader, $writer) = (IO::Handle->new, IO::Handle->new);
open2($reader, $writer, $program);
eval {
open2($readme, $writeme, @program_and_arguments);
};
if ($@) {
if ($@ =~ /^open2/) {
warn "open2 failed: $!\n$@\n";
return;
}
die; }
@all = `($cmd | sed -e 's/^/stdout: /' ) 2>&1`;
for (@all) { push @{ s/stdout: // ? \@outlines : \@errlines }, $_ }
print "STDOUT:\n", @outlines, "\n";
print "STDERR:\n", @errlines, "\n";
open3(*WRITEHANDLE, *READHANDLE, *ERRHANDLE, "program to run");
use IPC::Open3;
$pid = open3(*HIS_IN, *HIS_OUT, *HIS_ERR, $cmd);
close(HIS_IN); @outlines = <HIS_OUT>; @errlines = <HIS_ERR>; print "STDOUT:\n", @outlines, "\n";
print "STDERR:\n", @errlines, "\n";
use IPC::Open3;
use IO::Select;
$cmd = "grep vt33 /none/such - /etc/termcap";
$pid = open3(*CMD_IN, *CMD_OUT, *CMD_ERR, $cmd);
$SIG{CHLD} = sub {
print "REAPER: status $? on $pid\n" if waitpid($pid, 0) > 0
};
print CMD_IN "This line has a vt33 lurking in it\n";
close(CMD_IN);
$selector = IO::Select->new();
$selector->add(*CMD_ERR, *CMD_OUT);
while (@ready = $selector->can_read) {
foreach $fh (@ready) {
if (fileno($fh) == fileno(CMD_ERR)) {print "STDERR: ", scalar <CMD_ERR>}
else {print "STDOUT: ", scalar <CMD_OUT>}
$selector->remove($fh) if eof($fh);
}
}
close(CMD_CUT);
close(CMD_ERR);
pipe(READER, WRITER);
if (fork) {
} else {
}
if ($pid = open(CHILD, "|-")) {
} else {
die "cannot fork: $!" unless defined $pid;
}
if ($pid = open(CHILD, "-|")) {
} else {
die "cannot fork: $!" unless defined $pid;
}
use IO::Handle;
pipe(READER, WRITER);
WRITER->autoflush(1);
if ($pid = fork) {
close READER;
print WRITER "Parent Pid $$ is sending this\n";
close WRITER;
waitpid($pid,0);
} else {
die "cannot fork: $!" unless defined $pid;
close WRITER;
chomp($line = <READER>);
print "Child Pid $$ just read this: `$line'\n";
close READER; exit;
}
use IO::Handle;
pipe(READER, WRITER);
WRITER->autoflush(1);
if ($pid = fork) {
close WRITER;
chomp($line = <READER>);
print "Parent Pid $$ just read this: `$line'\n";
close READER;
waitpid($pid,0);
} else {
die "cannot fork: $!" unless defined $pid;
close READER;
print WRITER "Child Pid $$ is sending this\n";
close WRITER; exit;
}
use IO::Handle;
if ($pid = open(CHILD, "|-")) {
CHILD->autoflush(1);
print CHILD "Parent Pid $$ is sending this\n";
close(CHILD);
} else {
die "cannot fork: $!" unless defined $pid;
chomp($line = <STDIN>);
print "Child Pid $$ just read this: `$line'\n";
exit;
}
use IO::Handle;
if ($pid = open(CHILD, "-|")) {
chomp($line = <CHILD>);
print "Parent Pid $$ just read this: `$line'\n";
close(CHILD);
} else {
die "cannot fork: $!" unless defined $pid;
STDOUT->autoflush(1);
print STDOUT "Child Pid $$ is sending this\n";
exit;
}
use IO::Handle;
pipe(PARENT_RDR, CHILD_WTR);
pipe(CHILD_RDR, PARENT_WTR);
CHILD_WTR->autoflush(1);
PARENT_WTR->autoflush(1);
if ($pid = fork) {
close PARENT_RDR; close PARENT_WTR;
print CHILD_WTR "Parent Pid $$ is sending this\n";
chomp($line = <CHILD_RDR>);
print "Parent Pid $$ just read this: `$line'\n";
close CHILD_RDR; close CHILD_WTR;
waitpid($pid,0);
} else {
die "cannot fork: $!" unless defined $pid;
close CHILD_RDR; close CHILD_WTR;
chomp($line = <PARENT_RDR>);
print "Child Pid $$ just read this: `$line'\n";
print PARENT_WTR "Child Pid $$ is sending this\n";
close PARENT_RDR; close PARENT_WTR;
exit;
}
use Socket;
use IO::Handle;
socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
or die "socketpair: $!";
CHILD->autoflush(1);
PARENT->autoflush(1);
if ($pid = fork) {
close PARENT;
print CHILD "Parent Pid $$ is sending this\n";
chomp($line = <CHILD>);
print "Parent Pid $$ just read this: `$line'\n";
close CHILD;
waitpid($pid,0);
} else {
die "cannot fork: $!" unless defined $pid;
close CHILD;
chomp($line = <PARENT>);
print "Child Pid $$ just read this: `$line'\n";
print PARENT "Child Pid $$ is sending this\n";
close PARENT;
exit;
}
socketpair(READER, WRITER, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
shutdown(READER, 1); shutdown(WRITER, 0);
open(FIFO, "< /path/to/named.pipe") or die $!;
while (<FIFO>) {
print "Got: $_";
}
close(FIFO);
open(FIFO, "> /path/to/named.pipe") or die $!;
print FIFO "Smoke this.\n";
close(FIFO);
while (1) {
open(FIFO, "> $ENV{HOME}/.plan")
or die "Couldn't open $ENV{HOME}/.plan for writing: $!\n";
print FIFO "The current time is ", scalar(localtime), "\n";
close FIFO;
sleep 1;
}
use IO::File;
$SIG{ALRM} = sub { close(FIFO) };
while (1) {
alarm(0); open(FIFO, "< /tmp/log") or die "Can't open /tmp/log : $!\n";
alarm(1);
$service = <FIFO>;
next unless defined $service; chomp $service;
$message = <FIFO>;
next unless defined $message; chomp $message;
alarm(0);
if ($service eq "http") {
} elsif ($service eq "login") {
if ( open(LOG, ">> /tmp/login") ) {
print LOG scalar(localtime), " $service $message\n";
close(LOG);
} else {
warn "Couldn't log $service $message to /var/log/login : $!\n";
}
}
}
use POSIX qw(:errno_h);
$SIG{PIPE} = 'IGNORE';
$status = print FIFO "Are you there?\n";
if (!$status && $! == EPIPE) {
warn "My reader has forsaken me!\n";
next;
}
use POSIX;
print _POSIX_PIPE_BUF, "\n";
use IPC::Shareable;
$handle = tie $buffer, 'IPC::Shareable', undef, { destroy => 1 };
$SIG{INT} = sub { die "$$ dying\n" };
for (1 .. 10) {
unless ($child = fork) { die "cannot fork: $!" unless defined $child;
squabble();
exit;
}
push @kids, $child; }
while (1) {
print "Buffer is $buffer\n";
sleep 1;
}
die "Not reached";
sub squabble {
my $i = 0;
while (1) {
next if $buffer =~ /^$$\b/o;
$handle->shlock();
$i++;
$buffer = "$$ $i";
$handle->shunlock();
}
}
%SIG$Configsig_nameuse Config;
defined $Config{sig_name} or die "No sigs?";
$i = 0; foreach $name (split(' ', $Config{sig_name})) {
$signo{$name} = $i;
$signame[$i] = $name;
$i++;
}
kill 9 => $pid; kill -1 => $pgrp; kill USR1 => $$; kill HUP => @pids; @pidsuse POSIX qw(:errno_h);
if (kill 0 => $minion) {
print "$minion is alive!\n";
} elsif ($! == EPERM) { print "$minion has escaped my control!\n";
} elsif ($! == ESRCH) {
print "$minion is deceased.\n"; } else {
warn "Odd; I couldn't check on the status of $minion: $!\n";
}
$SIG{QUIT} = \&got_sig_quit; $SIG{PIPE} = 'got_sig_pipe'; $SIG{INT} = sub { $ouch++ }; $SIG{INT} = 'IGNORE'; $SIG{STOP} = 'DEFAULT';
sub ding {
$SIG{INT} = \&ding;
warn "\aEnter your name!\n";
}
sub get_name {
local $SIG{INT} = \&ding;
my $name;
print "Kindly Stranger, please enter your name: ";
chomp( $name = <> );
return $name;
}
$SIG{INT} = \&got_int;
sub got_int {
$SIG{INT} = \&got_int; }
my $interrupted = 0;
sub got_int {
$interrupted = 1;
$SIG{INT} = 'DEFAULT'; die;
}
eval {
$SIG{INT} = \&got_int;
};
if ($interrupted) {
}
$SIG{INT} = \&catcher;
sub catcher {
$SIG{INT} = \&catcher;
}
use Config;
print "Hurrah!\n" if $Config{d_sigaction};
$SIG{INT} = 'IGNORE';
$SIG{INT} = \&tsktsk;
sub tsktsk {
$SIG{INT} = \&tsktsk; warn "\aThe long habit of living indisposeth us for dying.\n";
}
$SIG{CHLD} = 'IGNORE';
use POSIX ":sys_wait_h";
$SIG{CHLD} = \&REAPER;
sub REAPER {
my $stiff;
while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
}
$SIG{CHLD} = \&REAPER; }
$exit_value = $? >> 8;
$signal_num = $? & 127;
$dumped_core = $? & 128;
use POSIX qw(:signal_h :errno_h :sys_wait_h);
$SIG{CHLD} = \&REAPER;
sub REAPER {
my $pid;
$pid = waitpid(-1, &WNOHANG);
if ($pid == -1) {
} elsif (WIFEXITED($?)) {
print "Process $pid exited.\n";
} else {
print "False alarm on $pid.\n";
}
$SIG{CHLD} = \&REAPER; }
use Config;
$has_nonblocking = $Config{d_waitpid} eq "define" ||
$Config{d_wait4} eq "define";
use POSIX qw(:signal_h);
$sigset = POSIX::SigSet->new(SIGINT); $old_sigset = POSIX::SigSet->new;
unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset)) {
die "Could not block SIGINT\n";
}
unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset)) {
die "Could not unblock SIGINT\n";
}
use POSIX qw(:signal_h);
$sigset = POSIX::SigSet->new( SIGINT, SIGKILL );
$SIG{ALRM} = sub { die "timeout" };
eval {
alarm(3600);
alarm(0);
};
if ($@) {
if ($@ =~ /timeout/) {
} else {
alarm(0); die; }
}
use strict;
use vars qw( $NG_IS_DIR $MKNOD $FULLNAME $FIFO $ART $NEWS $SIGS $SEMA
$GLOBRAND $NAME );
use vars qw( $Home $Fortune_Path @Pwd );
gethome();
$NG_IS_DIR = 1;
$MKNOD = "/bin/mknod";
$FULLNAME = "$Home/.fullname";
$FIFO = "$Home/.signature";
$ART = "$Home/.article";
$NEWS = "$Home/News";
$SIGS = "$NEWS/SIGNATURES";
$SEMA = "$Home/.sigrandpid";
$GLOBRAND = 1/4;
$NAME = ''; @home
setup(); justme(); fork && exit;
open (SEMA, "> $SEMA") or die "can't write $SEMA: $!";
print SEMA "$$\n";
close(SEMA) or die "can't close $SEMA: $!";
for (;;) {
open (FIFO, "> $FIFO") or die "can't write $FIFO: $!";
my $sig = pick_quote();
for ($sig) {
s/^((:?[^\n]*\n){4}).*$/$1/s; s/^(.{1,80}).*? *$/$1/gm; }
if ($NAME) {
print FIFO $NAME, "\n" x (3 - ($sig =~ tr/\n//)), $sig;
} else {
print FIFO $sig;
}
close FIFO;
select(undef, undef, undef, 0.2); }
die "XXX: NOT REACHED";
sub setup {
$SIG{PIPE} = 'IGNORE';
unless (defined $NAME) { if (-e $FULLNAME) {
$NAME = `cat $FULLNAME`;
die "$FULLNAME should contain only 1 line, aborting"
if $NAME =~ tr/\n// > 1;
} else {
my($user, $host);
chop($host = `hostname`);
($host) = gethostbyname($host) unless $host =~ /\./;
$user = $ENV{USER} || $ENV{LOGNAME} || $Pwd[0]
or die "intruder alert";
($NAME = $Pwd[6]) =~ s/,.*//;
$NAME =~ s/&/\u\L$user/g; $NAME = "\t$NAME\t$user\@$host\n";
}
}
check_fortunes() if !-e $SIGS;
unless (-p $FIFO) { if (!-e _) {
system("$MKNOD $FIFO p") && die "can't mknod $FIFO";
warn "created $FIFO as a named pipe\n";
} else {
die "$0: won't overwrite file .signature\n";
}
} else {
warn "$0: using existing named pipe $FIFO\n";
}
srand(time() ^ ($$ + ($$ << 15)));
}
sub pick_quote {
my $sigfile = signame();
if (!-e $sigfile) {
return fortune();
}
open (SIGS, "< $sigfile" ) or die "can't open $sigfile";
local $/ = "%%\n";
local $_;
my $quip;
rand($.) < 1 && ($quip = $_) while <SIGS>;
close SIGS;
chomp $quip;
return $quip || "ENOSIG: This signature file is empty.\n";
}
sub signame {
(rand(1.0) > ($GLOBRAND) && open ART) || return $SIGS;
local $/ = '';
local $_ = <ART>;
my($ng) = /Newsgroups:\s*([^,\s]*)/;
$ng =~ s!\.!/!g if $NG_IS_DIR; %p%c $ng = "$NEWS/$ng/SIGNATURES";
return -f $ng ? $ng : $SIGS;
}
sub fortune {
local $_;
my $tries = 0;
do {
$_ = `$Fortune_Path -s`;
} until tr/\n// < 5 || $tries++ > 20;
s/^/ /mg;
$_ || " SIGRAND: deliver random signals to all processes.\n";
}
sub check_fortunes {
return if $Fortune_Path; for my $dir (split(/:/, $ENV{PATH}), '/usr/games') {
return if -x ($Fortune_Path = "$dir/fortune");
}
die "Need either $SIGS or a fortune program, bailing out";
}
sub gethome {
@Pwd = getpwuid($<);
$Home = $ENV{HOME} || $ENV{LOGDIR} || $Pwd[7]
or die "no home directory for user $<";
}
sub justme {
if (open SEMA) {
my $pid;
chop($pid = <SEMA>);
kill(0, $pid) and die "$0 already running (pid $pid), bailing out";
close SEMA;
}
}
use Socket;
$packed_ip = inet_aton("208.146.240.1");
$socket_name = sockaddr_in($port, $packed_ip);
use Socket;
$socket_name = sockaddr_un("/tmp/mysock");
($port, $packed_ip) = sockaddr_in($socket_name); ($filename) = sockaddr_un($socket_name); $ip_address = inet_ntoa($packed_ip);
$packed_ip = inet_aton("204.148.40.9");
$packed_ip = inet_aton("www.oreilly.com");
use IO::Socket;
$socket = IO::Socket::INET->new(PeerAddr => $remote_host,
PeerPort => $remote_port,
Proto => "tcp",
Type => SOCK_STREAM)
or die "Couldn't connect to $remote_host:$remote_port : $@\n";
print $socket "Why don't you call me anymore?\n";
$answer = <$socket>;
close($socket);
use Socket;
socket(TO_SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
$internet_addr = inet_aton($remote_host)
or die "Couldn't convert $remote_host into an Internet address: $!\n";
$paddr = sockaddr_in($remote_port, $internet_addr);
connect(TO_SERVER, $paddr)
or die "Couldn't connect to $remote_host:$remote_port : $!\n";
print TO_SERVER "Why don't you call me anymore?\n";
close(TO_SERVER);
$client = IO::Socket::INET->new("www.yahoo.com:80")
or die $@;
$s = IO::Socket::INET->new(PeerAddr => "Does not Exist",
Peerport => 80,
Type => SOCK_STREAM )
or die $@;
$s = IO::Socket::INET->new(PeerAddr => "bad.host.com",
PeerPort => 80,
Type => SOCK_STREAM,
Timeout => 5 )
or die $@;
$inet_addr = inet_aton("208.146.240.1");
$paddr = sockaddr_in($port, $inet_addr);
bind(SOCKET, $paddr) or die "bind: $!";
$inet_addr = gethostbyname("www.yahoo.com")
or die "Can't resolve www.yahoo.com: $!";
$paddr = sockaddr_in($port, $inet_addr);
bind(SOCKET, $paddr) or die "bind: $!";
use IO::Socket;
$server = IO::Socket::INET->new(LocalPort => $server_port,
Type => SOCK_STREAM,
Reuse => 1,
Listen => 10 ) or die "Couldn't be a tcp server on port $server_port : $@\n";
while ($client = $server->accept()) {
}
close($server);
use Socket;
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
$my_addr = sockaddr_in($server_port, INADDR_ANY);
bind(SERVER, $my_addr)
or die "Couldn't bind to port $server_port : $!\n";
listen(SERVER, SOMAXCONN)
or die "Couldn't listen on port $server_port : $!\n";
while (accept(CLIENT, SERVER)) {
}
close(SERVER);
use Socket;
while ($client_address = accept(CLIENT, SERVER)) {
($port, $packed_ip) = sockaddr_in($client_address);
$dotted_quad = inet_ntoa($packed_ip);
}
while ($client = $server->accept()) {
}
while (($client,$client_address) = $server->accept()) {
}
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
$flags = fcntl(SERVER, F_GETFL, 0)
or die "Can't get flags for the socket: $!\n";
$flags = fcntl(SERVER, F_SETFL, $flags | O_NONBLOCK)
or die "Can't set flags for the socket: $!\n";
print SERVER "What is your name?\n";
chomp ($response = <SERVER>);
defined (send(SERVER, $data_to_send, $flags))
or die "Can't send : $!\n";
recv(SERVER, $data_read, $maxlen, $flags)
or die "Can't receive: $!\n";
use IO::Socket;
$server->send($data_to_send, $flags)
or die "Can't send: $!\n";
$server->recv($data_read, $flags)
or die "Can't recv: $!\n";
use IO::Select;
$select = IO::Select->new();
$select->add(*FROM_SERVER);
$select->add($to_client);
@read_from = $select->can_read($timeout);
foreach $socket (@read_from) {
}
use Socket;
require "sys/socket.ph";
setsockopt(SERVER, SOL_SOCKET, &TCP_NODELAY, 1)
or die "Couldn't disable Nagle's algorithm: $!\n";
setsockopt(SERVER, SOL_SOCKET, &TCP_NODELAY, 0)
or die "Couldn't enable Nagle's algorithm: $!\n";
$rin = ''; vec($rin, fileno(SOCKET), 1) = 1;
$timeout = 10;
$nfound = select($rout = $rin, undef, undef, $timeout);
if (vec($rout, fileno(SOCKET),1)){
}
use Socket;
socket(SOCKET, PF_INET, SOCK_DGRAM, getprotobyname("udp"))
or die "socket: $!";
use IO::Socket;
$handle = IO::Socket::INET->new(Proto => 'udp')
or die "socket: $@"; $ipaddr = inet_aton($HOSTNAME);
$portaddr = sockaddr_in($PORTNO, $ipaddr);
send(SOCKET, $MSG, 0, $portaddr) == length($MSG)
or die "cannot send to $HOSTNAME($PORTNO): $!";
$portaddr = recv(SOCKET, $MSG, $MAXLEN, 0) or die "recv: $!";
($portno, $ipaddr) = sockaddr_in($portaddr);
$host = gethostbyaddr($ipaddr, AF_INET);
print "$host($portno) said $MSG\n";
send(MYSOCKET, $msg_buffer, $flags, $remote_addr)
or die "Can't send: $!\n";
use strict;
use Socket;
my ($host, $him, $src, $port, $ipaddr, $ptime, $delta);
my $SECS_of_70_YEARS = 2_208_988_800;
socket(MsgBox, PF_INET, SOCK_DGRAM, getprotobyname("udp"))
or die "socket: $!";
$him = sockaddr_in(scalar(getservbyname("time", "udp")),
inet_aton(shift || '127.1'));
defined(send(MsgBox, 0, 0, $him))
or die "send: $!";
defined($src = recv(MsgBox, $ptime, 4, 0))
or die "recv: $!";
($port, $ipaddr) = sockaddr_in($src);
$host = gethostbyaddr($ipaddr, AF_INET);
my $delta = (unpack("N", $ptime) - $SECS_of_70_YEARS) - time();
print "Clock on $host is $delta seconds ahead of this one.\n";
use IO::Socket;
$server = IO::Socket::INET->new(LocalPort => $server_port,
Proto => "udp")
or die "Couldn't be a udp server on port $server_port : $@\n";
while ($him = $server->recv($datagram, $MAX_TO_READ, $flags)) {
}
use strict;
use IO::Socket;
my($sock, $oldmsg, $newmsg, $hisaddr, $hishost, $MAXLEN, $PORTNO);
$MAXLEN = 1024;
$PORTNO = 5151;
$sock = IO::Socket::INET->new(LocalPort => $PORTNO, Proto => 'udp')
or die "socket: $@";
print "Awaiting UDP messages on port $PORTNO\n";
$oldmsg = "This is the starting message.";
while ($sock->recv($newmsg, $MAXLEN)) {
my($port, $ipaddr) = sockaddr_in($sock->peername);
$hishost = gethostbyaddr($ipaddr, AF_INET);
print "Client $hishost said ``$newmsg''\n";
$sock->send($oldmsg);
$oldmsg = "[$hishost] $newmsg";
}
die "recv: $!";
use IO::Socket;
use strict;
my($sock, $server_host, $msg, $port, $ipaddr, $hishost,
$MAXLEN, $PORTNO, $TIMEOUT);
$MAXLEN = 1024;
$PORTNO = 5151;
$TIMEOUT = 5;
$server_host = shift;
$msg = "@ARGV";
$sock = IO::Socket::INET->new(Proto => 'udp',
PeerPort => $PORTNO,
PeerAddr => $server_host)
or die "Creating socket: $!\n";
$sock->send($msg) or die "send: $!";
eval {
local $SIG{ALRM} = sub { die "alarm time out" };
alarm $TIMEOUT;
$sock->recv($msg, $MAXLEN) or die "recv: $!";
alarm 0;
1; } or die "recv from $server_host timed out after $TIMEOUT seconds.\n";
($port, $ipaddr) = sockaddr_in($sock->peername);
$hishost = gethostbyaddr($ipaddr, AF_INET);
print "Server $hishost responded ``$msg''\n";
use IO::Socket;
unlink "/tmp/mysock";
$server = IO::Socket::UNIX->new(Local => "/tmp/mysock",
Type => SOCK_DGRAM,
Listen => 5 )
or die $@;
$client = IO::Socket::UNIX->new(Peer => "/tmp/mysock",
Type => SOCK_DGRAM,
Timeout => 10 )
or die $@;
use Socket;
socket(SERVER, PF_UNIX, SOCK_STREAM, 0);
unlink "/tmp/mysock";
bind(SERVER, sockaddr_un("/tmp/mysock"))
or die "Can't create server: $!";
socket(CLIENT, PF_UNIX, SOCK_STREAM, 0);
connect(CLIENT, sockaddr_un("/tmp/mysock"))
or die "Can't connect to /tmp/mysock: $!";
use Socket;
$other_end = getpeername(SOCKET)
or die "Couldn't identify other end: $!\n";
($port, $iaddr) = unpack_sockaddr_in($other_end);
$ip_address = inet_ntoa($iaddr);
use Socket;
$other_end = getpeername(SOCKET)
or die "Couldn't identify other end: $!\n";
($port, $iaddr) = unpack_sockaddr_in($other_end);
$actual_ip = inet_ntoa($iaddr);
$claimed_hostname = gethostbyaddr($iaddr, AF_INET);
@name_lookup = gethostbyname($claimed_hostname)
or die "Could not look up $claimed_hostname : $!\n";
@resolved_ips = map { inet_ntoa($_) }
@name_lookup[ 4 .. $#ips_for_hostname ];
$packed_ip = gethostbyname($name) or die "Couldn't look up $name : $!\n";
$ip_address = inet_ntoa($packed_ip);
use Sys::Hostname;
$hostname = hostname();
use POSIX qw(uname);
($kernel, $hostname, $release, $version, $hardware) = uname();
$hostname = (uname)[1]; use Socket; $address = gethostbyname($hostname)
or die "Couldn't resolve $hostname : $!";
$hostname = gethostbyaddr($address, AF_INET)
or die "Couldn't re-resolve $hostname : $!";
shutdown(SOCKET, 0); shutdown(SOCKET, 1); shutdown(SOCKET, 2); $socket->shutdown(0); print SERVER "my request\n"; shutdown(SERVER, 1); $answer = <SERVER>;
use strict;
use IO::Socket;
my ($host, $port, $kidpid, $handle, $line);
unless (@ARGV == 2) { die "usage: $0 host port" }
($host, $port) = @ARGV;
$handle = IO::Socket::INET->new(Proto => "tcp",
PeerAddr => $host,
PeerPort => $port)
or die "can't connect to port $port on $host: $!";
$handle->autoflush(1); print STDERR "[Connected to $host:$port]\n";
die "can't fork: $!" unless defined($kidpid = fork());
if ($kidpid) {
while (defined ($line = <$handle>)) {
print STDOUT $line;
}
kill("TERM" => $kidpid); }
else {
while (defined ($line = <STDIN>)) {
print $handle $line;
}
}
exit;
my $byte;
while (sysread($handle, $byte, 1) == 1) {
print STDOUT $byte;
}
use POSIX qw(:sys_wait_h);
sub REAPER {
1 until (-1 == waitpid(-1, WNOHANG));
$SIG{CHLD} = \&REAPER; }
$SIG{CHLD} = \&REAPER;
while ($hisaddr = accept(CLIENT, SERVER)) {
next if $pid = fork; die "fork: $!" unless defined $pid; close(SERVER); exit; } continue {
close(CLIENT); }
use IO::Socket;
use Symbol;
use POSIX;
$server = IO::Socket::INET->new(LocalPort => 6969,
Type => SOCK_STREAM,
Proto => 'tcp',
Reuse => 1,
Listen => 10 )
or die "making socket: $@\n";
$PREFORK = 5; $MAX_CLIENTS_PER_CHILD = 5; %children = (); $children = 0;
sub REAPER { $SIG{CHLD} = \&REAPER;
my $pid = wait;
$children --;
delete $children{$pid};
}
sub HUNTSMAN { local($SIG{CHLD}) = 'IGNORE'; kill 'INT' => keys %children;
exit; }
for (1 .. $PREFORK) {
make_new_child();
}
$SIG{CHLD} = \&REAPER;
$SIG{INT} = \&HUNTSMAN;
while (1) {
sleep; for ($i = $children; $i < $PREFORK; $i++) {
make_new_child(); }
}
sub make_new_child {
my $pid;
my $sigset;
$sigset = POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset)
or die "Can't block SIGINT for fork: $!\n";
die "fork: $!" unless defined ($pid = fork);
if ($pid) {
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = 1;
$children++;
return;
} else {
$SIG{INT} = 'DEFAULT';
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
$client = $server->accept() or last;
}
exit;
}
}
use POSIX;
use IO::Socket;
use IO::Select;
use Socket;
use Fcntl;
use Tie::RefHash;
$port = 1685;
$server = IO::Socket::INET->new(LocalPort => $port,
Listen => 10 )
or die "Can't make server socket: $@\n";
%inbuffer = ();
%outbuffer = ();
%ready = ();
tie %ready, 'Tie::RefHash';
nonblock($server);
$select = IO::Select->new($server);
while (1) {
my $client;
my $rv;
my $data;
foreach $client ($select->can_read(1)) {
if ($client == $server) {
$client = $server->accept();
$select->add($client);
nonblock($client);
} else {
$data = '';
$rv = $client->recv($data, POSIX::BUFSIZ, 0);
unless (defined($rv) && length $data) {
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
$select->remove($client);
close $client;
next;
}
$inbuffer{$client} .= $data;
$ready while ($inbuffer{$client} =~ s/(.*\n)//) {
push( @{$ready{$client}}, $1 );
}
}
}
foreach $client (keys %ready) {
handle($client);
}
foreach $client ($select->can_write(1)) {
next unless exists $outbuffer{$client};
$rv = $client->send($outbuffer{$client}, 0);
unless (defined $rv) {
warn "I was told I could write, but I can't.\n";
next;
}
if ($rv == length $outbuffer{$client} ||
{$! == POSIX::EWOULDBLOCK) {
substr($outbuffer{$client}, 0, $rv) = '';
delete $outbuffer{$client} unless length $outbuffer{$client};
} else {
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};
$select->remove($client);
close($client);
next;
}
}
foreach $client ($select->has_exception(0)) { }
}
sub handle {
$ready $outbuffer my $client = shift;
my $request;
foreach $request (@{$ready{$client}}) {
$outbuffer }
delete $ready{$client};
}
sub nonblock {
my $socket = shift;
my $flags;
$flags = fcntl($socket, F_GETFL, 0)
or die "Can't get flags for socket: $!\n";
fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
or die "Can't make socket nonblocking: $!\n";
}
while ($inbuffer{$client} =~ s/(.*\n)//) {
push( @{$ready{$client}}, $1 );
}
$outbuffer{$client} .= $request;
use Socket;
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
bind(SERVER, sockaddr_in($server_port, INADDR_ANY))
or die "Binding: $!\n";
while (accept(CLIENT, SERVER)) {
$my_socket_address = getsockname(CLIENT);
($port, $myaddr) = sockaddr_in($my_socket_address);
}
$server = IO::Socket::INET->new(LocalPort => $server_port,
Type => SOCK_STREAM,
Proto => 'tcp',
Listen => 10)
or die "Can't create server socket: $@\n";
while ($client = $server->accept()) {
$my_socket_address = $client->sockname();
($port, $myaddr) = sockaddr_in($my_socket_address);
}
use Socket;
$port = 4269; $host = "specific.host.com";
socket(Server, PF_INET, SOCK_STREAM, getprotobyname("tcp"))
or die "socket: $!";
bind(Server, sockaddr_in($port, inet_aton($host)))
or die "bind: $!";
while ($client_address = accept(Client, Server)) {
}
chroot("/var/daemon")
or die "Couldn't chroot to /var/daemon: $!";
$pid = fork;
exit if $pid;
die "Couldn't fork: $!" unless defined($pid);
use POSIX;
POSIX::setsid()
or die "Can't start a new session: $!";
$time_to_die = 0;
sub signal_handler {
$time_to_die = 1;
}
$SIG{INT} = $SIG{TERM} = $SIG{HUP} = \&signal_handler;
$SIGPIPEuntil ($time_to_die) {
}
$SELF = "/usr/local/libexec/myd"; @ARGS = qw(-l /var/log/myd -d);
$SIG{HUP} = \&phoenix;
sub phoenix {
exec($SELF, @ARGS) or die "Couldn't restart: $!\n";
}
$CONFIG_FILE = "/usr/local/etc/myprog/server_conf.pl";
$SIG{HUP} = \&read_config;
sub read_config {
do $CONFIG_FILE;
}
May 25 15:50:22 coprolith sniffer: Connection from 207.46.131.141 to
207.46.130.164:echo
echo stream tcp nowait nobody /usr/scripts/snfsqrd sniffer
use Sys::Syslog;
use Socket;
$sockname = getsockname(STDIN)
or die "Couldn't identify myself: $!\n";
($port, $iaddr) = sockaddr_in($sockname);
$my_address = inet_ntoa($iaddr);
$service = (getservbyport ($port, "tcp"))[0] || $port;
$sockname = getpeername(STDIN)
or die "Couldn't identify other end: $!\n";
($port, $iaddr) = sockaddr_in($sockname);
$ex_address = inet_ntoa($iaddr);
openlog("sniffer", "ndelay", "daemon");
syslog("notice", "Connection from %s to %s:%s\n", $ex_address,
$my_address, $service);
closelog();
exit;
use strict; use Getopt::Long; use Net::hostent; Example 17-8 use IO::Socket; use POSIX ":sys_wait_h";
my (
%Children, $REMOTE, $LOCAL, $SERVICE, $proxy_server, $ME, );
($ME = $0) =~ s,.*/,,;
check_args(); start_proxy(); service_clients(); die "NOT REACHED";
sub check_args {
GetOptions(
"remote=s" => \$REMOTE,
"local=s" => \$LOCAL,
"service=s" => \$SERVICE,
) or die <<EOUSAGE;
usage: $0 [ --remote host ] [ --local interface ] [ --service service ]
EOUSAGE die "Need remote" unless $REMOTE;
die "Need local or service" unless $LOCAL || $SERVICE;
}
sub start_proxy {
my @proxy_server_config = (
Proto => 'tcp',
Reuse => 1,
Listen => SOMAXCONN,
);
push @proxy_server_config, LocalPort => $SERVICE if $SERVICE;
push @proxy_server_config, LocalAddr => $LOCAL if $LOCAL;
$proxy_server = IO::Socket::INET->new(@proxy_server_config)
or die "can't create proxy server: $@";
print "[Proxy server on ", ($LOCAL || $SERVICE), " initialized.]\n";
}
sub service_clients {
my (
$local_client, $lc_info, $remote_server, @rs_config, $rs_info, $kidpid, );
$SIG{CHLD} = \&REAPER;
accepting();
while ($local_client = $proxy_server->accept()) {
$lc_info = peerinfo($local_client);
set_state("servicing local $lc_info");
printf "[Connect from $lc_info]\n";
@rs_config = (
Proto => 'tcp',
PeerAddr => $REMOTE,
);
push(@rs_config, PeerPort => $SERVICE) if $SERVICE;
print "[Connecting to $REMOTE...";
set_state("connecting to $REMOTE"); $remote_server = IO::Socket::INET->new(@rs_config)
or die "remote server: $@";
print "done]\n";
$rs_info = peerinfo($remote_server);
set_state("connected to $rs_info");
$kidpid = fork();
die "Cannot fork" unless defined $kidpid;
if ($kidpid) {
$Children{$kidpid} = time(); close $remote_server; close $local_client; next; }
close $proxy_server;
$kidpid = fork();
die "Cannot fork" unless defined $kidpid;
if ($kidpid) {
set_state("$rs_info --> $lc_info");
select($local_client); $| = 1;
print while <$remote_server>;
kill('TERM', $kidpid); }
else {
set_state("$rs_info <-- $lc_info");
select($remote_server); $| = 1;
print while <$local_client>;
kill('TERM', getppid()); }
exit; } continue {
accepting();
}
}
sub peerinfo {
my $sock = shift;
my $hostinfo = gethostbyaddr($sock->peeraddr);
return sprintf("%s:%s",
$hostinfo->name || $sock->peerhost,
$sock->peerport);
}
sub set_state { $0 = "$ME [@_]" }
sub accepting {
set_state("accepting proxy for " . ($REMOTE || $SERVICE));
}
sub REAPER {
my $child;
my $start;
while (($child = waitpid(-1,WNOHANG)) > 0) {
if ($start = $Children{$child}) {
my $runtime = time() - $start;
printf "Child $child ran %dm%ss\n",
$runtime / 60, $runtime % 60;
delete $Children{$child};
} else {
print "Bizarre kid $child exited $?\n";
}
}
$SIG{CHLD} = \&REAPER;
};
use Socket;
@addresses = gethostbyname($name) or die "Can't resolve $name: $!\n";
@addresses = map { inet_ntoa($_) } @addresses[4 .. $#addresses];
@addressesuse Socket;
$address = inet_ntoa(inet_aton($name));
use Socket;
$name = gethostbyaddr(inet_aton($address), AF_INET)
or die "Can't resolve $address: $!\n";
use Socket;
$packed_address = inet_aton("208.146.140.1");
$ascii_address = inet_ntoa($packed_address);
$packed = gethostbyname($hostname)
or die "Couldn't resolve address for $hostname: $!\n";
$address = inet_ntoa($packed);
print "I will use $address as the address for $hostname\n";
use Socket;
$name = gethostbyaddr(inet_aton($address), AF_INET)
or die "Can't look up $address : $!\n";
@addr = gethostbyname($name)
or die "Can't look up $name : $!\n";
$found = grep { $address eq inet_ntoa($_) } @addr[4..$#addr];
use Net::DNS;
$host = shift;
$res = Net::DNS::Resolver->new();
@mx = mx($res, $host)
or die "Can't find MX records for $host (".$res->errorstring,")\n";
foreach $record (@mx) {
print $record->preference, " ", $record->exchange, "\n";
}
use Socket;
use Net::hostent;
$name = shift;
if ($hent = gethostbyname($name)) {
$name = $hent->name; $addr_ref = $hent->addr_list;
@addresses = map { inet_ntoa($_) } @$addr_ref;
}
print "$name => @addresses\n";
use Net::FTP;
$ftp = Net::FTP->new("ftp.host.com") or die "Can't connect: $@\n";
$ftp->login($username, $password) or die "Couldn't login\n";
$ftp->cwd($directory) or die "Couldn't change directory\n";
$ftp->get($filename) or die "Couldn't get $filename\n";
$ftp->put($filename) or die "Couldn't put $filename\n";
$ftp = Net::FTP->new("ftp.host.com",
Timeout => 30,
Debug => 1)
or die "Can't connect: $@\n";
$ftp->
login()
or die "Couldn't authenticate.\n";
$ftp->login($username)
or die "Still couldn't authenticate.\n";
$ftp->login($username, $password)
or die "Couldn't authenticate, even with explicit username
and password.\n";
$ftp->login($username, $password, $account)
or die "No dice. It hates me.\n";
$ftp->put($localfile, $remotefile)
or die "Can't send $localfile: $!\n";
$ftp->put(*STDIN, $remotefile)
or die "Can't send from STDIN: $!\n";
$ftp->get($remotefile, $localfile)
or die "Can't fetch $remotefile : $!\n";
$ftp->get($remotefile, *STDOUT)
or die "Can't fetch $remotefile: $!\n";
$ftp->cwd("/pub/perl/CPAN/images/g-rated");
print "I'm in the directory ", $ftp->pwd(), "\n";
$ftp->mkdir("/pub/gnat/perl", 1)
or die "Can't create /pub/gnat/perl recursively: $!\n";
@lines = $ftp->ls("/pub/gnat/perl")
or die "Can't get a list of files in /pub/gnat/perl: $!";
$ref_to_lines = $ftp->dir("/pub/perl/CPAN/src/latest.tar.gz")
or die "Can't check status of latest.tar.gz: $!\n";
$ftp->quit() or warn "Couldn't quit. Oh well.\n";
use Mail::Mailer;
$mailer = Mail::Mailer->new("sendmail");
$mailer->open({ From => $from_address,
To => $to_address,
Subject => $subject,
})
or die "Can't open: $!\n";
print $mailer $body;
$mailer->
close();
open(SENDMAIL, "|/usr/lib/sendmail -oi -t -odq")
or die "Can't fork for sendmail: $!\n";
print SENDMAIL <<"EOF";
From: User Originating Mail <me\@host>
To: Final Destination <you\@otherhost>
Subject: A relevant subject line
Body of the message goes here, in as many lines as you like.
EOFclose(SENDMAIL) or warn "sendmail didn't close nicely";
$mailer = Mail::Mailer->new("sendmail");
$mailer = Mail::Mailer->new("mail", "/u/gnat/bin/funkymailer");
$mailer = Mail::Mailer->new("smtp", "mail.myisp.com");
eval {
$mailer = Mail::Mailer->new("bogus", "arguments");
};
if ($@) {
print "Couldn't send mail: $@\n";
} else {
print "The authorities have been notified.\n";
}
$mailer->open( 'From' => 'Nathan Torkington <gnat@frii.com>',
'To' => 'Tom Christiansen <tchrist@perl.com>',
'Subject' => 'The Perl Cookbook' );
print $mailer <<EO_SIG;
Are we ever going to finish this book?
My wife is threatening to leave me.
She says I love EMACS more than I love her.
Do you have a recipe that can help me?
Nat
EO_SIGclose($mailer) or die "can't close mailer: $!";
open(SENDMAIL, "|/usr/sbin/sendmail -oi -t -odq")
or die "Can't fork for sendmail: $!\n";
print SENDMAIL <<"EOF";
From: Tom Christiansen <tchrist\@perl.com>
To: Nathan Torkington <gnat\@frii.com>
Subject: Re: The Perl Cookbook
(1) We will never finish the book.
(2) No man who uses EMACS is deserving of love.
(3) I recommend coq au vi.
tom
EOFclose(SENDMAIL);
use Net::NNTP;
$server = Net::NNTP->new("news.host.dom")
or die "Can't connect to news server: $@\n";
($narticles, $first, $last, $name) = $server->group( "misc.test" )
or die "Can't select misc.test\n";
$headers = $server->head($first)
or die "Can't get headers from article $first in $name\n";
$bodytext = $server->body($first)
or die "Can't get body from article $first in $name\n";
$article = $server->article($first)
or die "Can't get article $first from $name\n";
$server->
postok()
or warn "Server didn't tell me I could post.\n";
$server->post( [ @lines ] )
or die "Can't post: $!\n";
<0401@jpl-devvax.JPL.NASA.GOV>
$server = Net::NNTP->new("news.mycompany.com")
or die "Couldn't connect to news.mycompany.com: $@\n";
$grouplist = $server->
list()
or die "Couldn't fetch group list\n";
foreach $group (keys %$grouplist) {
if ($grouplist->{$group}->[2] eq 'y') {
}
}
($narticles, $first, $last, $name) = $server->group("comp.lang.perl.misc")
or die "Can't select comp.lang.perl.misc\n";
@lines = $server->article($message_id)
or die "Can't fetch article $message_id: $!\n";
@group = $server->group("comp.lang.perl.misc")
or die "Can't select group comp.lang.perl.misc\n";
@lines = $server->head($group[1])
or die "Can't get headers from first article in comp.lang.perl.misc\n";
$server->post(@message)
or die "Can't post\n";
unless ($server->
postok()
) {
warn "You may not post.\n";
}
$pop = Net::POP3->new($mail_server)
or die "Can't open connection to $mail_server : $!\n";
defined ($pop->login($username, $password))
or die "Can't authenticate: $!\n";
$messages = $pop->list
or die "Can't get list of undeleted messages: $!\n";
foreach $msgid (keys %$messages) {
$message = $pop->get($msgid);
unless (defined $message) {
warn "Couldn't fetch $msgid from server: $!\n";
next;
}
$pop->delete($msgid);
}
$pop = Net::POP3->new( "pop.myisp.com" )
or die "Can't connect to pop.myisp.com: $!\n";
$pop = Net::POP3->new( "pop.myisp.com",
Timeout => 30 )
or die "Can't connect to pop.myisp.com : $!\n";
defined ($pop->login("gnat", "S33kr1T Pa55w0rD"))
or die "Hey, my username and password didn't work!\n";
defined ($pop->login( "midget" )) or die "Authentication failed.\n";
defined ($pop->
login())
or die "Authentication failed. Miserably.\n";
$pop->apop( $username, $password )
or die "Couldn't authenticate: $!\n";
%undeleted = $pop->
list();
foreach $msgnum (keys %undeleted) {
print "Message $msgnum is $undeleted{$msgnum} bytes long.\n";
}
print "Retrieving $msgnum : ";
$message = $pop->get($msgnum);
if ($message) {
print "\n";
print @$message; } else {
print "failed ($!)\n";
}
use Net::Telnet;
$t = Net::Telnet->new( Timeout => 10,
Prompt => '/%/',
Host => $hostname );
$t->login($username, $password);
@files = $t->cmd("ls");
$t->print("top");
(undef, $process_string) = $t->waitfor('/\d+ processes/');
$t->close;
/[\$%#>] $/
$telnet = Net::Telnet->new( Errmode => sub { main::log(@_) }, ... );
$telnet->login($username, $password)
or die "Login failed: @{[ $telnet->errmsg() ]}\n";
$telnet->waitfor('/--more--/')
$telnet->waitfor(String => 'greasy smoke', Timeout => 30)
use Net::Ping;
$p = Net::Ping->new()
or die "Can't create new ping object: $!\n";
print "$host is alive" if $p->ping($host);
$p->close;
$pong = Net::Ping->new( $> ? "tcp" : "icmp" );
(defined $pong)
or die "Couldn't create Net::Ping object: $!\n";
if ($pong->ping("kingkong.com")) {
print "The giant ape lives!\n";
} else {
print "All hail mighty Gamera, friend of children!\n";
}
use Net::Whois;
$domain_obj = Net::Whois::Domain->new($domain_name)
or die "Couldn't get information on $domain_name: $!\n";
$d = Net::Whois::Domain->new( "perl.org" )
or die "Can't get information on perl.org\n";
print "The domain is called ", $d->domain, "\n";
print "Its tag is ", $d->tag, "\n";
print "Mail for ", $d->name, " should be sent to:\n";
print map { "\t$_\n" } $d->address;
print "\t", $d->country, "\n";
$contact_hash = $d->contacts;
if ($contact_hash) {
print "Contacts:\n";
foreach $type (sort keys %$contact_hash) {
print " $type:\n";
foreach $line (@{$contact_hash->{$type}}) {
print " $line\n";
}
}
} else {
print "No contact information.\n";
}
@frii@frii@mail@frii@frii@deimos@frii@mail@frii@mail@friiuse strict;
use IO::Socket;
use Sys::Hostname;
my $fetch_mx = 0;
eval {
require Net::DNS;
Net::DNS->import('mx');
$fetch_mx = 1;
};
my $selfname = hostname();
die "usage: $0 address\@host ...\n" unless @ARGV;
my $VERB = ($0 =~ /ve?ri?fy$/i) ? 'VRFY' : 'EXPN';
my $multi = @ARGV > 1;
my $remote;
foreach my $combo (@ARGV) {
my ($name, $host) = split(/\@/, $combo);
my @hosts;
$host ||= 'localhost';
@hosts = map { $_->exchange } mx($host) if $fetch_mx;
@hosts = ($host) unless @hosts;
foreach my $host (@hosts) {
print $VERB eq 'VRFY' ? "Verify" : "Expand",
"ing $name at $host ($combo):";
$remote = IO::Socket::INET->new(
Proto => "tcp",
PeerAddr => $host,
PeerPort => "smtp(25)",
);
unless ($remote) {
warn "cannot connect to $host\n";
next;
}
print "\n";
$remote->autoflush(1);
print $remote "HELO $selfname\015\012";
print $remote "$VERB $name\015\012";
print $remote "quit\015\012";
while (<$remote>) {
/^220\b/ && next;
/^221\b/ && last;
s/250\b[\-\s]+//;
print;
}
close($remote) or die "can't close socket: $!";
print "\n"; @ARGV }
}
@myplace:gatekeeper
use strict;
use CGI qw(:standard escapeHTML);
my $value = param('PARAM_NAME');
print header(), start_html("Howdy there!"),
p("You typed: ", tt(escapeHTML($value))),
end_html();
use CGI qw(:standard);
$who = param("Name");
$phone = param("Number");
@picks = param("Choices");
print header( -TYPE => 'text/plain',
-EXPIRES => '+3d' );
use CGI::Carp;
warn "This is a complaint";
die "But this one is serious";
BEGIN {
use CGI::Carp qw(carpout);
open(LOG, ">>/var/local/cgi-logs/mycgi-log")
or die "Unable to append to mycgi-log: $!\n";
carpout(*LOG);
}
use CGI::Carp qw(fatalsToBrowser);
die "Bad error here";
print "Content-Type: text/plain\n\n";
print "Running as ", scalar getpwuid($>), "\n";
$| = 1;
open(FH, "> $ARGV[0]") or die;
$file = $ARGV[0]; unless ($file =~ m#^([\w.-]+)$#) { die "filename '$file' has invalid characters.\n";
}
$file = $1; unless (-e $filename) { open(FH, "> $filename");
}
system("command $input @files"); system("command", $input, @files); chomp($now = `date`);
@output = `grep $input @files`;
die "cannot fork: $!" unless defined ($pid = open(SAFE_KID, "|-"));
if ($pid == 0) {
exec('grep', $input, @files) or die "can't exec grep: $!";
} else {
@output = <SAFE_KID>;
close SAFE_KID; }
open(KID_TO_READ, "$program @options @args |"); die "cannot fork: $!" unless defined($pid = open(KID_TO_READ, "-|"));
if ($pid) { while (<KID_TO_READ>) {
}
close(KID_TO_READ) or warn "kid exited $?";
} else { exec($program, @options, @args) or die "can't exec program: $!";
}
open(KID_TO_WRITE, "|$program $options @args"); $pid = open(KID_TO_WRITE, "|-");
die "cannot fork: $!" unless defined($pid = open(KID_TO_WRITE, "|-"));
$SIG{ALRM} = sub { die "whoops, $program pipe broke" };
if ($pid) { for (@data) { print KID_TO_WRITE $_ }
close(KID_TO_WRITE) or warn "kid exited $?";
} else { exec($program, @options, @args) or die "can't exec program: $!";
}
print ol( li([ qw(red blue green)]) );
@names = qw(Larry Moe Curly);
print ul( li({ -TYPE => "disc" }, \@names) );
print li("alpha");
print li( [ "alpha", "omega"] );
use CGI qw(:standard :html3);
%hash = (
"Wisconsin" => [ "Superior", "Lake Geneva", "Madison" ],
"Colorado" => [ "Denver", "Fort Collins", "Boulder" ],
"Texas" => [ "Plano", "Austin", "Fort Stockton" ],
"California" => [ "Sebastopol", "Santa Rosa", "Berkeley" ],
);
$\ = "\n";
print "<TABLE> <CAPTION>Cities I Have Known</CAPTION>";
print Tr(th [qw(State Cities)]);
for $k (sort keys %hash) {
print Tr(th($k), td( [ sort @{$hash{$k}} ] ));
}
print "</TABLE>";
print table
caption('Cities I have Known'),
Tr(th [qw(State Cities)]),
map { Tr(th($_), td( [ sort @{$hash{$_}} ] )) } sort keys %hash;
use DBI;
use CGI qw(:standard :html3);
$limit = param("LIMIT");
print header(), start_html("Salary Query"),
h1("Search"),
start_form(),
p("Enter minimum salary", textfield("LIMIT")),
submit(),
end_form();
if (defined $limit) {
$dbh = DBI->connect("dbi:mysql:somedb:server.host.dom:3306",
"username", "password")
or die "Connecting: $DBI::errstr";
$sth = $dbh->prepare("SELECT name,salary FROM employees
WHERE salary > $limit")
or die "Preparing: ", $dbh->errstr;
$sth->execute
or die "Executing: ", $sth->errstr;
print h1("Results"), "<TABLE BORDER=1>";
while (@row = $sth->fetchrow()) {
print Tr( td( \@row ) );
}
print "</TABLE>\n";
$sth->finish;
$dbh->disconnect;
}
print end_html();
$url = "http://www.perl.com/CPAN/";
print "Location: $url\n\n";
exit;
use CGI qw(:cgi);
$oreo = cookie( -NAME => 'filling',
-VALUE => "vanilla crème",
-EXPIRES => '+3M', -DOMAIN => '.perl.com');
$whither = "http://somewhere.perl.com/nonesuch.html";
print redirect( -URL => $whither,
-COOKIE => $oreo);
%E4me $dir = 'http://www.wins.uva.nl/%7Emes/jargon';
for ($ENV{HTTP_USER_AGENT}) {
$page = /Mac/ && 'm/Macintrash.html'
|| /Win(dows )?NT/ && 'e/evilandrude.html'
|| /Win|MSIE|WebTV/ && 'm/MicroslothWindows.html'
|| /Linux/ && 'l/Linux.html'
|| /HP-UX/ && 'h/HP-SUX.html'
|| /SunOS/ && 's/ScumOS.html'
|| 'a/AppendixB.html';
}
print "Location: $dir/$page\n\n";
use CGI qw(:standard);
print header( -STATUS => '204 No response' );
cat <<EOCAT
Status: 204 No response
EOCAT
use strict;
use HTTP::Daemon;
my $server = HTTP::Daemon->new(Timeout => 60);
print "Please contact me at: <URL:", $server->url, ">\n";
while (my $client = $server->accept) {
CONNECTION:
while (my $answer = $client->get_request) {
print $answer->as_string;
$client->autoflush;
RESPONSE:
while (<STDIN>) {
last RESPONSE if $_ eq ".\n";
last CONNECTION if $_ eq "..\n";
print $client $_;
}
print "\nEOF\n";
}
print "CLOSE: ", $client->reason, "\n";
$client->close;
undef $client;
}
% GET -esuSU http://mox.perl.com/perl/bogotic
$preference_value = cookie("preference name");
$packed_cookie = cookie( -NAME => "preference name",
-VALUE => "whatever you'd like",
-EXPIRES => "+2y");
print header(-COOKIE => $packed_cookie);
use CGI qw(:standard);
use strict;
my $cookname = "favorite ice cream";
my $favorite = param("flavor");
my $tasty = cookie($cookname) || 'mint';
unless ($favorite) {
print header(), start_html("Ice Cookies"), h1("Hello Ice Cream"),
hr(), start_form(),
p("Please select a flavor: ", textfield("flavor",$tasty)),
end_form(), hr();
exit;
}
my $cookie = cookie(
-NAME => $cookname,
-VALUE => $favorite,
-EXPIRES => "+2y",
);
print header(-COOKIE => $cookie),
start_html("Ice Cookies, #2"),
h1("Hello Ice Cream"),
p("You chose as your favorite flavor `$favorite'.");
print textfield("SEARCH");
$ENV{IFS}='';
$ENV{PATH}='/bin:/usr/bin';
use CGI qw(:standard);
print header(), start_html("Query Users"), h1("Search");
print start_form(), p("Which user?", textfield("WHO")); submit(), end_form();
$name = param("WHO");
if ($name) {
print h1("Results");
$html = '';
foreach (`who`) {
next unless /^$name\s/o; s/&/&/g; s/</</g;
s/>/>/g;
$html .= $_;
}
$html = $html || "$name is not logged in";
print pre($html);
}
print end_html();
use CGI qw(:standard);
print hidden("bacon");
print submit(-NAME => ".State", -VALUE => "Checkout");
sub to_page { return submit( -NAME => ".State", -VALUE => shift ) }
$page = param(".State") || "Default";
if ($page eq "Default") {
front_page();
} elsif ($page eq "Checkout") {
checkout();
} else {
no_such_page(); }
%States = (
'Default' => \&front_page,
'Shirt' => \&shirt,
'Sweater' => \&sweater,
'Checkout' => \&checkout,
'Card' => \&credit_card,
'Order' => \&order,
'Cancel' => \&front_page,
);
if ($States{$page}) {
$States{$page}->(); } else {
no_such_page();
}
while (($state, $sub) = each %States) {
$sub->( $page eq $state );
}
sub t_shirt {
my $active = shift;
unless ($active) {
print hidden("size"), hidden("color");
return;
}
print p("You want to buy a t-shirt?");
print p("Size: ", popup_menu('size', [ qw(XL L M S XS) ]));
print p("Color:", popup_menu('color', [ qw(Black White) ]));
print p( to_page("Shoes"), to_page("Checkout") );
}
print header("Program Title"), start_html();
print standard_header(), begin_form();
while (($state, $sub) = each %States) {
$sub->( $page eq $state );
}
print standard_footer(), end_form(), end_html();
open(FH, ">>/tmp/formlog") or die "can't append to formlog: $!";
flock(FH, 2) or die "can't flock formlog: $!";
use CGI qw(:standard);
save_parameters(*FH);
use CGI;
$query = CGI->new();
$query->save(*FH);
close(FH) or die "can't close formlog: $!";
use CGI qw(:standard);
open(MAIL, "|/usr/lib/sendmail -oi -t") or die "can't fork sendmail: $!";
print MAIL <<EOF;
From: $0 (your cgi script)
To: hisname\@hishost.com
Subject: mailed form submission
EOFsave_parameters(*MAIL);
close(MAIL) or die "can't close sendmail: $!";
param("_timestamp", scalar localtime);
param("_environs", %ENV);
use CGI;
open(FORMS, "< /tmp/formlog") or die "can't read formlog: $!";
flock(FORMS, 1) or die "can't lock formlog: $!";
while ($query = CGI->new(*FORMS)) {
last unless $query->param(); %his_env = $query->param('_environs');
$count += $query->param('items requested')
unless $his_env{REMOTE_HOST} =~ /(^|\.)perl\.com$/
}
print "Total orders: $count\n";
use strict;
use CGI qw(:standard);
use CGI::Carp qw(fatalsToBrowser);
my %States; my $Current_Screen;
%States = (
'Default' => \&front_page,
'Shirt' => \&shirt,
'Sweater' => \&sweater,
'Checkout' => \&checkout,
'Card' => \&credit_card,
'Order' => \&order,
'Cancel' => \&front_page,
);
$Current_Screen = param(".State") || "Default";
die "No screen for $Current_Screen" unless $States{$Current_Screen};
standard_header();
while (my($screen_name, $function) = each %States) {
$function->($screen_name eq $Current_Screen);
}
standard_footer();
exit;
sub standard_header {
print header(), start_html(-Title => "Shirts", -BGCOLOR=>"White");
print start_form(); }
sub standard_footer { print end_form(), end_html() }
sub shop_menu {
print p(defaults("Empty My Shopping Cart"),
to_page("Shirt"),
to_page("Sweater"),
to_page("Checkout"));
}
sub front_page {
my $active = shift;
return unless $active;
print "<H1>Hi!</H1>\n";
print "Welcome to our Shirt Shop! Please make your selection from ";
print "the menu below.\n";
shop_menu();
}
sub shirt {
my $active = shift;
my @sizes = qw(XL L M S);
my @colors = qw(Black White);
my ($size, $color, $count) =
(param("shirt_size"), param("shirt_color"), param("shirt_count"));
if ($count) {
$color = $colors[0] unless grep { $_ eq $color } @colors;
$size = $sizes[0] unless grep { $_ eq $size } @sizes;
param("shirt_color", $color);
param("shirt_size", $size);
}
unless ($active) {
print hidden("shirt_size") if $size;
print hidden("shirt_color") if $color;
print hidden("shirt_count") if $count;
return;
}
print h1("T-Shirt");
print p("What a shirt! This baby is decked out with all the options.",
"It comes with full luxury interior, cotton trim, and a collar",
"to make your eyes water! Unit price: \$33.00");
print h2("Options");
print p("How Many?", textfield("shirt_count"));
print p("Size?", popup_menu("shirt_size", \@sizes ),
"Color?", popup_menu("shirt_color", \@colors));
shop_menu();
}
sub sweater {
my $active = shift;
my @sizes = qw(XL L M);
my @colors = qw(Chartreuse Puce Lavender);
my ($size, $color, $count) =
(param("sweater_size"), param("sweater_color"), param("sweater_count"));
if ($count) {
$color = $colors[0] unless grep { $_ eq $color } @colors;
$size = $sizes[0] unless grep { $_ eq $size } @sizes;
param("sweater_color", $color);
param("sweater_size", $size);
}
unless ($active) {
print hidden("sweater_size") if $size;
print hidden("sweater_color") if $color;
print hidden("sweater_count") if $count;
return;
}
print h1("Sweater");
print p("Nothing implies preppy elegance more than this fine",
"sweater. Made by peasant workers from black market silk,",
"it slides onto your lean form and cries out ``Take me,",
"for I am a god!''. Unit price: \$49.99.");
print h2("Options");
print p("How Many?", textfield("sweater_count"));
print p("Size?", popup_menu("sweater_size", \@sizes));
print p("Color?", popup_menu("sweater_color", \@colors));
shop_menu();
}
sub checkout {
my $active = shift;
return unless $active;
print h1("Order Confirmation");
print p("You ordered the following:");
print order_text();
print p("Is this right? Select 'Card' to pay for the items",
"or 'Shirt' or 'Sweater' to continue shopping.");
print p(to_page("Card"),
to_page("Shirt"),
to_page("Sweater"));
}
sub credit_card {
my $active = shift;
my @widgets = qw(Name Address1 Address2 City Zip State Phone Card Expiry);
unless ($active) {
print map { hidden($_) } @widgets;
return;
}
print pre(p("Name: ", textfield("Name")),
p("Address: ", textfield("Address1")),
p(" ", textfield("Address2")),
p("City: ", textfield("City")),
p("Zip: ", textfield("Zip")),
p("State: ", textfield("State")),
p("Phone: ", textfield("Phone")),
p("Credit Card #: ", textfield("Card")),
p("Expiry: ", textfield("Expiry")));
print p("Click on 'Order' to order the items. Click on 'Cancel' to return
shopping.");
print p(to_page("Order"), to_page("Cancel"));
}
sub order {
my $active = shift;
unless ($active) {
return;
}
print h1("Ordered!");
print p("You have ordered the following toppings:");
print order_text();
print p(defaults("Begin Again"));
}
sub order_text {
my $html = '';
if (param("shirt_count")) {
$html .= p("You have ordered ", param("shirt_count"),
" shirts of size ", param("shirt_size"),
" and color ", param("shirt_color"), ".");
}
if (param("sweater_count")) {
$html .= p("You have ordered ", param("sweater_count"),
" sweaters of size ", param("sweater_size"),
" and color ", param("sweater_color"), ".");
}
$html = p("Nothing!") unless $html;
$html .= p("For a total cost of ", calculate_price());
return $html;
}
sub calculate_price {
my $shirts = param("shirt_count") || 0;
my $sweaters = param("sweater_count") || 0;
return sprintf("\$%.2f", $shirts*33 + $sweaters * 49.99);
}
sub to_page { submit(-NAME => ".State", -VALUE => shift) }
http://www.perl.com/CPAN/modules/by-category/15_World_Wide_Web_HTML_HTTP_CGI/
use LWP::Simple;
$content = get($URL);
use LWP::Simple;
unless (defined ($content = get $URL)) {
die "could not get $URL\n";
}
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Response;
use URI::Heuristic;
my $raw_url = shift or die "usage: $0 url\n";
my $url = URI::Heuristic::uf_urlstr($raw_url);
$| = 1; printf "%s =>\n\t", $url;
my $ua = LWP::UserAgent->new();
$ua->agent("Schmozilla/v9.14 Platinum"); my $req = HTTP::Request->new(GET => $url);
$req->referer("http://wizard.yellowbrick.oz");
my $response = $ua->request($req);
if ($response->is_error()) {
printf " %s\n", $response->status_line;
} else {
my $count;
my $bytes;
my $content = $response->content();
$bytes = length $content;
$count = ($content =~ tr/\n/\n/);
printf "%s (%d lines, %d bytes)\n", $response->title(), $count, $bytes; }
use LWP::Simple;
use URI::URL;
my $url = url('http://www.perl.com/cgi-bin/cpan_mod');
$url->query_form(module => 'DB_File', readme => 1);
$content = get($url);
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
$ua = LWP::UserAgent->new();
my $req = POST 'http://www.perl.com/cgi-bin/cpan_mod',
[ module => 'DB_File', readme => 1 ];
$content = $ua->request($req)->as_string;
field1=value1&field2=value2&field3=value3
http://www.site.com/path/to/
script.cgi?field1=value1&field2=value2&field3=value3
http://www.site.com/path/to/
script.cgi?arg=%22this+isn%27t+%3CEASY%3E+%26+%3CFUN%3E%22
$ua->proxy(['http', 'ftp'] => 'http://proxy.myorg.com:8081');
use HTML::LinkExtor;
$parser = HTML::LinkExtor->new(undef, $base_url);
$parser->parse_file($filename);
@links = $parser->links;
foreach $linkarray (@links) {
my @element = @$linkarray;
my $elt_type = shift @element;
while (@element) {
my ($attr_name, $attr_value) = splice(@element, 0, 2);
}
}
<A HREF="http://www.perl.com/">Home page</A>
<IMG SRC="images/big.gif" LOWSRC="images/big-lowres.gif">
[
[ a, href => "http://www.perl.com/" ],
[ img, src => "images/big.gif",
lowsrc => "images/big-lowres.gif" ]
]
if ($elt_type eq 'a' && $attr_name eq 'href') {
print "ANCHOR: $attr_value\n"
if $attr_value->scheme =~ /http|ftp/;
}
if ($elt_type eq 'img' && $attr_name eq 'src') {
print "IMAGE: $attr_value\n";
}
use HTML::LinkExtor;
use LWP::Simple;
$base_url = shift;
$parser = HTML::LinkExtor->new(undef, $base_url);
$parser->parse(get($base_url))->eof;
@links = $parser->links;
foreach $linkarray (@links) {
my @element = @$linkarray;
my $elt_type = shift @element;
while (@element) {
my ($attr_name , $attr_value) = splice(@element, 0, 2);
$seen{$attr_value}++;
}
}
for (sort keys %seen) { print $_, "\n" }
@ftp<URL:http://www.perl.com>
@URLs = ($message =~ /<URL:(.*?)>/g);
use HTML::Entities;
$_ = encode_entities($_, "\200-\377");
if (/^\s/) {
s{(.*)$} {<PRE>\n$1</PRE>\n}s; } else {
s{^(>.*)} {$1<BR>}gm; s{<URL:(.*?)>} {<A HREF="$1">$1</A>}gs ||
s{(http:\S+)} {<A HREF="$1">$1</A>}gs; s{\*(\S+)\*} {<STRONG>$1</STRONG>}g; s{\b_(\S+)\_\b} {<EM>$1</EM>}g; s{^} {<P>\n}; }
BEGIN {
print "<TABLE>";
$_ = encode_entities(scalar <>);
s/\n\s+/ /g; while ( /^(\S+?:)\s*(.*)$/gm ) { print "<TR><TH ALIGN='LEFT'>$1</TH><TD>$2</TD></TR>\n";
}
print "</TABLE><HR>";
}
$ascii = `lynx -dump $filename`;
use HTML::FormatText;
use HTML::Parse;
$html = parse_htmlfile($filename);
$formatter = HTML::FormatText->new(leftmargin => 0, rightmargin => 50);
$ascii = $formatter->format($html);
use HTML::TreeBuilder;
use HTML::FormatText;
$html = HTML::TreeBuilder->new();
$html->parse($document);
$formatter = HTML::FormatText->new(leftmargin => 0, rightmargin => 50);
$ascii = $formatter->format($html);
($plain_text = $html_text) =~ s/<[^>]*>//gs; use HTML::Parse;
use HTML::FormatText;
$plain_text = HTML::FormatText->new->format(parse_html($html_text));
{
local $/; $html = <FILE>;
$html =~ s/<[^>]*>//gs;
}
package MyParser;
use HTML::Parser;
use HTML::Entities qw(decode_entities);
@ISA = qw(HTML::Parser);
sub text {
my($self, $text) = @_;
print decode_entities($text);
}
package main;
MyParser->new->parse_file(*F);
($title) = ($html =~ m#<TITLE>\s*(.*?)\s*</TITLE>#is);
die "usage: $0 url ...\n" unless @ARGV;
require LWP;
foreach $url (@ARGV) {
$ua = LWP::UserAgent->new();
$res = $ua->request(HTTP::Request->new(GET => $url));
print "$url: " if @ARGV > 1;
if ($res->is_success) {
print $res->title, "\n";
} else {
print $res->status_line, "\n";
}
}
use HTML::LinkExtor;
use LWP::Simple qw(get head);
$base_url = shift
or die "usage: $0 <start_url>\n";
$parser = HTML::LinkExtor->new(undef, $base_url);
$parser->parse(get($base_url));
@links = $parser->links;
print "$base_url: \n";
foreach $linkarray (@links) {
my @element = @$linkarray;
my $elt_type = shift @element;
while (@element) {
my ($attr_name , $attr_value) = splice(@element, 0, 2);
if ($attr_value->scheme =~ /\b(ftp|https?|file)\b/) {
print " $attr_value: ", head($attr_value) ? "OK" : "BAD", "\n";
}
}
}
use LWP::UserAgent;
use HTTP::Request;
use URI::URL qw(url);
my($url, %Date);
my $ua = LWP::UserAgent->new();
while ( $url = url(scalar <>) ) {
my($req, $ans);
next unless $url->scheme =~ /^(file|https?)$/;
$ans = $ua->request(HTTP::Request->new("HEAD", $url));
if ($ans->is_success) {
$Date{$url} = $ans->last_modified || 0; } else {
print STDERR "$url: Error [", $ans->code, "] ", $ans->message, "!\n";
}
}
foreach $url ( sort { $Date{$b} <=> $Date{$a} } keys %Date ) {
printf "%-25s %s\n", $Date{$url} ? (scalar localtime $Date{$url})
: "<NONE SPECIFIED>", $url;
}
sub template {
my ($filename, $fillings) = @_;
my $text;
local $/; local *F; open(F, "< $filename\0") || return;
$text = <F>; close(F); $text =~ s{ %% ( .*? ) %% }
{ exists( $fillings->{$1} )
? $fillings->{$1}
: ""
}gsex;
return $text;
}
%username%username%username%count%total %fields = (
username => $whats_his_name,
count => $login_count,
total => $minute_used,
);
print template("/home/httpd/templates/simple.template", \%fields);
use DBI;
use CGI qw(:standard);
$user = param("username") or die "No username";
$dbh = DBI->connect("dbi:mysql:connections:mysql.domain.com:3306",
"connections", "seekritpassword") or die "Couldn't connect\n";
$sth = $dbh->prepare(<<"END_OF_SELECT") or die "Couldn't prepare SQL";
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECT
if (@row = $sth->fetchrow()) {
($count, $seconds) = @row;
} else {
($count, $seconds) = (0,0);
}
$sth->finish();
$dbh->disconnect;
print header();
print template("report.tpl", {
'username' => $user,
'count' => $count,
'total' => $total
});
You owe: {$total}
The average was {$count ? ($total/$count) : 0}.
use Text::Template;
use DBI;
use CGI qw(:standard);
$tmpl = "/home/httpd/templates/fancy.template";
$template = Text::Template->new(-type => "file", -source => $tmpl);
$user = param("username") or die "No username";
$dbh = DBI->connect("dbi:mysql:connections:mysql.domain.com:3306",
"connections", "secret passwd") or die "Couldn't db connect\n";
$sth = $dbh->prepare(<<"END_OF_SELECT") or die "Couldn't prepare SQL";
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username='$user'
END_OF_SELECT
$sth->execute() or die "Couldn't execute SQL";
if (@row = $sth->fetchrow()) {
($count, $total) = @row;
} else {
$count = $total = 0;
}
$sth->finish();
$dbh->disconnect;
print header();
print $template->fill_in();
use LWP::Simple;
mirror($URL, $local_filename);
use LWP::RobotUA;
$ua = LWP::RobotUA->new('websnuffler/0.1', 'me@wherever.com');
403 (Forbidden) Forbidden by robots.txt
while (<LOGFILE>) {
my ($client, $identuser, $authuser, $date, $time, $tz, $method,
$url, $protocol, $status, $bytes) =
/^(\S+) (\S+) (\S+) \[([^:]+):(\d+:\d+:\d+) ([^\]]+) "(\S+) (.*?) (\S+)" (\S+) (\S+)$/ or next;
}
$lastdate = "";
daily_logs();
summary();
exit;
sub daily_logs {
while (<>) {
($type, $what) = /"(GET|POST)\s+(\S+?) \S+"/ or next;
($host, undef, undef, $datetime) = split;
($bytes) = /\s(\d+)\s*$/ or next;
($date) = ($datetime =~ /\[([^:]*)/);
$posts += ($type eq POST);
$home++ if m, / ,;
if ($date ne $lastdate) {
if ($lastdate) { write_report() }
else { $lastdate = $date }
}
$count++;
$hosts{$host}++;
$what{$what}++;
$bytesum += $bytes;
}
write_report() if $count;
}
sub summary {
$lastdate = "Grand Total";
*count = *sumcount;
*bytesum = *bytesumsum;
*hosts = *allhosts;
*posts = *allposts;
*what = *allwhat;
*home = *allhome;
write;
}
sub write_report {
write;
$lastdate = $date;
$sumcount += $count;
$bytesumsum += $bytesum;
$allposts += $posts;
$allhome += $home;
$posts = $count = $bytesum = $home = 0;
@allwhat{keys %what} = keys %what;
@allhosts{keys %hosts} = keys %hosts;
%hosts = %what = ();
}
format STDOUT_TOP =
@|||||||||| @|||||| @||||||| @||||||| @|||||| @|||||| @|||||||||||||
"Date", "Hosts", "Accesses", "Unidocs", "POST", "Home", "Bytes"
----------- ------- -------- -------- ------- ------- --------------
.
format STDOUT =
@>>>>>>>>>> @>>>>>> @>>>>>>> @>>>>>>> @>>>>>> @>>>>>> @>>>>>>>>>>>>>
$lastdate, scalar(keys %hosts),
$count, scalar(keys %what),
$posts, $home, $bytesum
.
use Logfile::Apache;
$l = Logfile::Apache->new(
File => "-", Group => [ Domain, File ]);
$l->report(Group => Domain, Sort => Records);
$l->report(Group => File, List => [Bytes,Records]);
@aas
sub usage { die "Usage: $0 <from> <to> <file>...\n" }
my $from = shift or usage;
my $to = shift or usage;
usage unless @ARGV;
package MyFilter;
require HTML::Filter;
@ISA=qw(HTML::Filter);
use HTML::Entities qw(decode_entities encode_entities);
sub text
{
my $self = shift;
my $text = decode_entities($_[0]);
$text =~ s/\Q$from/$to/go; $self->SUPER::text(encode_entities($text));
}
package main;
foreach (@ARGV) {
MyFilter->new->parse_file($_);
}
@aas
sub usage { die "Usage: $0 <from> <to> <file>...\n" }
my $from = shift or usage;
my $to = shift or usage;
usage unless @ARGV;
package MyFilter;
require HTML::Filter;
@ISA=qw(HTML::Filter);
use HTML::Entities qw(encode_entities);
sub start {
my($self, $tag, $attr, $attrseq, $orig) = @_;
if ($tag eq 'a' && exists $attr->{href}) {
if ($attr->{href} =~ s/\Q$from/$to/g) {
my $tmp = "<$tag";
for (@$attrseq) {
my $encoded = encode_entities($attr->{$_});
$tmp .= qq( $_="$encoded ");
}
$tmp .= ">";
$self->output($tmp);
return;
}
}
$self->output($orig);
}
package main;
foreach (@ARGV) {
MyFilter->new->parse_file($_);
}