Select Code to Download

use IPC::Open3 qw( open3 );

...
}

waitpid($pid, 0);

use IPC::Open3 qw( open3 );

...
}

waitpid($pid, 0);

>type script.bat
@echo off
...
echo today=%today%
for /f "usebackq delims=" %%q in (`perl -MPOSIX -E"say strftime('%Y%m%
+d', localtime)"`) do set today=%%q
echo today=%today%

perl -MDateTime -E"say DateTime->today( time_zone => 'local' )->ymd"

>type script.bat
@echo off
...
testb=
testa=abc
testb=def

package My::XML::Generator;

...
            ]),
        ]);
    }

#!/bin/bash
exec 3>&2 2>&1
err=$( perl -e'print "O\n"; warn "E\n"' 3>&2 2>&1 1>&3 )
exec 2>&3 3>&-
echo "[STDERR:$err]" >&2

$ x
O
...

$ x 1>/dev/null
[STDERR:E]

# Set your timezone to America/New_York before running.
# In this time zone, DST ends on Nov 2, 2008 at 2:00 AM.
...
use POSIX;
print( strftime( "%m-%d\n", localtime( 86400 * $_ + $time ) ) )
   for 1..30;

10-29
10-30
...
11-25
11-26
       > 11-27 didn't get created

   +-------------+    +-------------+    +-------------+
   | Document    |    | Linkage     |    | Animal      |
...
   +-------------+    +-------------+    +-------------+

P - Primary key (Unique, Not NULL)

SELECT Document.data
  FROM Document
...
               ON Animal.id = Linkage.b
            WHERE Animal.name IN (?, ?, ...)
       )

SELECT Document.data
  FROM Document
...
            GROUP BY Linkage.a
            HAVING COUNT(*) = ?
       )

use IO::Handle ();  # For "flush" method.

...
}

print("crlf\n");

use IO::Handle ();  # For "flush" method.

...
STDOUT_BIN->flush();     

print("crlf\n");

>perl -v

...
-D100 L10
0B27:0100  63 72 6C 66 0D 0A 72 61-77 0A 63 72 6C 66 0D 0A   crlf..raw
+.crlf..
-Q

use strict;
use warnings;
...

for (         $min .. $max) { print(":"); <STDIN>; last; }  # 2.2MB
for ( reverse $min .. $max) { print(":"); <STDIN>; last; }  # 239MB

use File::Basename  qw( fileparse );
use IO::Dir         qw( );
...

   return "$d${n}[$max]$e";
}

sub get_iter {
   my $pass = 0;
...
while ($_ = $i->()) {
   print("$_\n");
}

sub get_iter {
   my $pass = 0;
...
while ($_ = $i->()) {
   print("$_\n");
}

sub get_fibonacci_iter {
   my ($x, $y) = (0, 1);
...
my $i = get_fibonacci_iter();
print($i->(), "\n")
   for 1..40;

my $mask = 0x06000003; # or whatever

...
   last if not $val;
   $val = ($val - 1) & $mask;
}

0x00000000
0x00000001
...
0x06000001
0x06000002
0x06000003

sub slice_ref {
   return \@_;
...
print("After inserting into bar:\n");    # Doesn't work:
print('foo: ', join(', ', @foo), "\n");  # foo: a, 2, 3, 4, 5
print('bar: ', join(', ', @bar), "\n");  # bar: a, 6, 2, 3

perl -M"ActivePerl::DocTools"
     -e"ActivePerl::DocTools::UpdateHTML();
        ActivePerl::DocTools::WriteTOC();"

use URI ();
use File::Spec::Unix ();
...
# ------
# http://www.faqs.org/rfcs/
# http://www.server.com/

system("... ...")
system("...", "...", "...")
...
IPC::Open3
IPC::Run
IPC::Run3

/^(?:(?!$re).)*$/          # NOT re
/$re1|$re2/                # re1 OR re2
/^(?=.*$re1)(?=.*$re2)/    # re1 AND re2

sub create_closure {
   my $var = shift;
...
# around $var. I don't know if "closes"
# is the official terminology, but
# that's what's happening.

sub scale_dimentions {
   my ($width, $height, $max_width, $max_height) = @_;
...

printf("%d,%d$/", scale_dimentions(2272, 1704, 150, 150));  # 150,112
printf("%d,%d$/", scale_dimentions(1704, 2272, 150, 150));  # 112,150

my @ranges = (
   [ 0 .. 2 ],
...

print(join(' ', @$_), $/)
   foreach @results;

my @lists = (
   [ ... ],
...

print(join(' ', @$_), $/)
   foreach @results;

# Add $value to sorted @array, if it's not already there.
my $idx = binsearch { $a <=> $b } $value, @array;
splice(@array, ~$idx, 0, $value) if $idx < 0;

sub binsearch(&$\@) {
   my  $compare = $_[0];
...
}

sub _unsigned_to_signed { unpack('j', pack('J', $_[0])) }

$i = 4;       print($i)   while ($i--);  #  3210
$i = 4;  do { print($i) } while ($i--);  # 43210

$a = something;  # something is executed in a scalar context.
@a = something;  # something is executed in a list   context.
...
   print(scalar(localtime));  # Fri Oct  1 15:05:32 2004
}
# Refer to wantarray in perlfunc.

sub nearest {
   my ($num) = @_;
...

   return int($num + 0.5) * $f;
}

sub nearest {
   my ($num, $digits) = @_;
...

   return int($num + 0.5) * $f;
}

$stmt = 'SELECT Field1, Field2 FROM Table';
$href = { map { @$_ } @{$dbh->selectall_arrayref($stmt)} };
...
#    Row2Field1 => Row2Field2,
#    ...
# };

$stmt = 'SELECT Field1, Field2 FROM Table';
$href = $dbh->selectall_hashref($stmt, 'Field1');
...
#    Row2Field1 => { Field1 => Row2Field1, Field2 => Row2Field2 },
#    ...
# };

# Serializes an array, a hash or a list which contains only
# strings and undefs. Everything else will be stringified.
...
      )
   } split(/\|/, $_[0]);
}

# Untested.

...
# End HTML.
print($q->end_form());
print($q->end_html());

sub flush {
   my $h = select($_[0]); my $af=$|; $|=1; $|=$af; select($h);
}

package MyStruct;

...
   $x->Counter++;                      print($x->Counter, "\n");  # 5
   $x->Counter += 1;                   print($x->Counter, "\n");  # 6
}

# This \$var syntax of open() requires Perl 5.8.0 or higher.
use 5.8.0;
...
}

print("\$output contains:\n$output");

Windows Registry Editor Version 5.00

...

[HKEY_CLASSES_ROOT\Drive\shell\cmd\command]
@="cmd.exe /k \"cd %L\""

use strict;
use warnings;
...
test 3: bypassed
test 4: bypassed
test 5: bypassed

@status = sort {
   my $mtime_a = (stat("$target_dir\\$a"))[9];
   my $mtime_b = (stat("$target_dir\\$b"))[9];
   $mtime_a <=> $mtime_b
} @status;

@status = (
   map  { $_->[0] }
...
   map  { [ $_, stat("$target_dir\\$_"))[9] ] }
   @status
);

use Alorithm::Loops;

...
   ];
}

use strict;
use warnings;
...
my $a = $p->[0];    ## Gives no warnings!!
my $q = undef;
my $b = ${$q}[0];   ## Gives no warnings!!

...
print("$p\n");  # ARRAY(0x1abefa0)
print("$q\n");  # ARRAY(0x1abf054)

# Create some subroutines to find:
sub PACKAGEA::PACKAGEB::test {}
...

print(join(', ', check_for_sub('test')), $/);
# Prints "main, PACKAGEA::PACKAGEB, PACKAGED"

# Create some packages for testing:
$PACKAGEA::ANYVAR = 1;
...
PACKAGEA exists
PACKAGEA::PACKAGEB exists
PACKAGEC doesn't exist

# Create some packages for testing:
$PACKAGEA::ANYVAR = 1;
...
IO
CORE
main

$color = substr($color, -6);
$color .= '0' x length(6-$color);
$color =~ s/[^0-9A-Fa-f]/0/g;
$color = hex($color);

// K&R C:
char string[6] = "hello";  // Initializes string[] to "hello\0".
...

a1 = "Greetings";  // ERROR
a2 = "Greetings";  // OK