>type script.bat @echo off set testa= set testb= echo testa=%testa% echo testb=%testb% for /f "usebackq delims=" %%f in (`perl script.pl`) do %%f echo testa=%testa% echo testb=%testb% >type script.pl print("set testa=abc\n"); print("set testb=def\n"); >script testa= testb= testa=abc testb=def #### package My::XML::Generator; use strict; use warnings; use Exporter qw( import ); use XML::LibXML qw( ); our @EXPORT_OK = qw( gen_document gen_root_element gen_element gen_data_element ); our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); # -------------------- # Public Functions sub gen_document { my $doc = XML::LibXML::Document->new('1.0', 'UTF-8'); $doc->setDocumentElement(gen_root_element(@_)); return $doc->toString(); } # Can't use objects passed as children after calling this. sub gen_root_element { my $name = shift; my $children = pop; my $root = XML::LibXML::Element->new($name); while (@_) { my $key = shift; my $val = shift; if ($key eq '__NAMESPACE') { $root->setNamespace($val); } else { $root->setAttribute($key, $val); } } foreach (@$children) { $root->addChild($_); } return $root; } # Can't use objects passed as children after calling this. sub gen_element { my $name = shift; my $children = @_ % 2 == 1 ? pop : []; my $ele = XML::LibXML::Element->new($name); while (@_) { $ele->setAttribute(shift, shift); } foreach (@$children) { $ele->addChild($_); } return $ele; } sub gen_data_element { my $name = shift; my $text = shift; my $ele = XML::LibXML::Element->new($name); while (@_) { $ele->setAttribute(shift, shift); } $ele->appendTextNode($text); return $ele; } 1; __END__ =head1 NAME My::XML::Generator - A fast XML generator. =head1 SYNOPSIS use My::XML::Generator qw( gen_document gen_element gen_data_element ); sub gen_breakdown { ... return gen_element('PTC_Farebreakdown', [ gen_element('PassengerTypeQuantity', 'Code' => format_pax_type($pax_type), 'Quantity' => $pax_qty, ), gen_element('PassengerFare', [ gen_element('BaseFare', 'Amount' => $base_fare), gen_element('Taxes', [ gen_data_element('Tax', 'Taxes and Surcharges', 'Amount' => $tax_and_surch), ]), gen_element('TotalFare', 'Amount' => $total), ]), ]); } #### use IO::Handle (); # For "flush" method. print("crlf\n"); { STDOUT->flush(); my $fileno = fileno(STDOUT); local *STDOUT; open(STDOUT, ">&$fileno") or die("Unable to dup STDOUT: $!\n"); binmode(STDOUT); print("raw\n"); } print("crlf\n"); #### use IO::Handle (); # For "flush" method. open(STDOUT_BIN, ">&STDOUT") or die("Unable to dup STDOUT: $!\n"); binmode(STDOUT_BIN); print("crlf\n"); # Flush STDOUT when switching to STDOUT_BIN. STDOUT->flush(); print STDOUT_BIN ("raw\n"); # Flush STDOUT_BIN when switching to STDOUT. STDOUT_BIN->flush(); print("crlf\n"); #### >perl -v This is perl, v5.6.1 built for MSWin32-x86-multi-thread (with 1 registered patch, see perl -V for more detail) ... >perl script.pl > out >debug out -RCX CX 0010 : -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; print("$]\n"); # 5.008008 # Don't inline these. It will cause the # memory to be allocated at compile time. my $min = 0; my $max = 10_000_000; for ( $min .. $max) { print(":"); ; last; } # 2.2MB for ( reverse $min .. $max) { print(":"); ; last; } # 239MB #### use File::Basename qw( fileparse ); use IO::Dir qw( ); sub find_unique_name { my ($file_name) = @_; return $file_name if not -e $file_name; my ($n, $d, $e) = fileparse($file_name, qr/\.[^.]*/); my $max; if ($n =~ s/\[(\d+)\]\z//) { $max = $1; } else { $max = 0; } # XXX Should the program fall back to using # -e in a loop if the dir can't be read? my $dh = IO::Dir->new("$d.") or die("Unable to list contents of directory \"$d\": $!\n"); my $re = qr/^\Q$n\E\[(\d+)\]\Q$e\E\z/; while (defined(my $f = $dh->read())) { $max = $1 if $f =~ /$re/ && $max < $1; } $max++; return "$d${n}[$max]$e"; } #### sub get_iter { my $pass = 0; return sub { ++$pass; if ($pass == 1) { print("Before 1: "); return 1; } if ($pass == 2) { print("Before 2: "); return 2; } return; } } my $i = get_iter(); while ($_ = $i->()) { print("$_\n"); } #### sub get_iter { my $pass = 0; return sub { ++$pass; return if $pass > 2; print("Before $pass: "); return $pass; } } my $i = get_iter(); while ($_ = $i->()) { print("$_\n"); } #### sub get_fibonacci_iter { my ($x, $y) = (0, 1); return sub { ($x, $y) = ($y, $x+$y); return $x; } } my $i = get_fibonacci_iter(); print($i->(), "\n") for 1..40; #### my $mask = 0x06000003; # or whatever my $val = $mask; for (;;) { #printf("0x%08X\n", $val); # Print big to small. printf("0x%08X\n", $mask-$val); # Print small to big. last if not $val; $val = ($val - 1) & $mask; } #### 0x00000000 0x00000001 0x00000002 0x00000003 0x02000000 0x02000001 0x02000002 0x02000003 0x04000000 0x04000001 0x04000002 0x04000003 0x06000000 0x06000001 0x06000002 0x06000003 #### sub slice_ref { return \@_; } my @foo = (1..5); # If a ref is ok: #my $bar = slice_ref @foo[0..2]; # If an array is prefered: our @bar; *bar = slice_ref @foo[0..2]; print('foo: ', join(', ', @foo), "\n"); # foo: 1, 2, 3, 4, 5 print('bar: ', join(', ', @bar), "\n"); # bar: 1, 2, 3 print("\n"); $bar[0] = 'a'; print("After changing bar0:\n"); # Works: print('foo: ', join(', ', @foo), "\n"); # foo: a, 2, 3, 4, 5 print('bar: ', join(', ', @bar), "\n"); # bar: a, 2, 3 print("\n"); splice(@bar, 1, 0, 6); 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 (); foreach ( "http://www.faqs.org/rfcs/rfc1738.html", "http://www.server.com/math.cgi?eval=4/5", ) { my $uri = URI->new($_); $uri->query(undef); $uri->path( File::Spec::Unix->catpath( (File::Spec::Unix->splitpath($uri->path()))[0,1])); print($uri, $/); } # output # ------ # http://www.faqs.org/rfcs/ # http://www.server.com/ #### system("... ...") system("...", "...", "...") system("...&") system("start ...") system("start /min ...") system("start /wait ...") system 1, exec fork+exec `` and qx() open("...|") open("|...") Win32::Process IPC::Open2 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; return sub { print($var, "\n"); }; } my $sub1 = create_closure("foo"); my $sub2 = create_closure("bar"); # $var is no longer is scope, # but a copy of it lives on in # $sub1 and another in $sub2. &$sub1(); # Prints foo. &$sub2(); # Prints bar. # You can say that the anonymous sub # returned by create_closure closes # 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) = @_; my $width_factor; my $height_factor; my $factor; $width_factor = $max_width / $width; $height_factor = $max_height / $height; return ($width, $height) if ($width_factor >= 1 && $height_factor >= 1); if ($width_factor < $height_factor) { $factor = $width_factor; } else { $factor = $height_factor; } return ( int($width * $factor + 0.5), int($height * $factor + 0.5), ); } printf("%d,%d$/", scale_dimentions(2272, 1704, 800, 600)); # 800,600 printf("%d,%d$/", scale_dimentions(1704, 2272, 800, 600)); # 450,600 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 ], [ 0 .. 2 ], [ 0 .. 2 ], [ 0 .. 2 ], ); my $glob_string = join '\\ ', map { '{'.join(',', @$_).'}' } @ranges; my @results; while (glob($glob_string)) { my $i = 0; push(@results, [ map { $ranges[$i++][$_] } split ]); } print(join(' ', @$_), $/) foreach @results; #### my @lists = ( [ ... ], [ ... ], [ ... ], [ ... ], ); my @ranges = map { [ 0..$#$_ ] } @lists; my $glob_string = join '\\ ', map { '{'.join(',', @$_).'}' } @ranges; my @results; while (glob($glob_string)) { my $i = 0; push(@results, [ map { $lists[$i++][$_] } split ]); } 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]; #my $value = $_[1]; my $array = $_[2]; my $min = $_[3] // 0; my $max = $_[4] // $#$array; my $min = 0; my $max = $#$array; return -1 if $max == -1; my $ap = do { no strict 'refs'; \*{caller().'::a'} }; local *$ap; my $bp = do { no strict 'refs'; \*{caller().'::b'} }; local *$bp; *$ap = \($_[1]); while ($min <= $max) { my $mid = int(($min+$max)/2); *$bp = \($array->[$mid]); my $cmp = $compare->() or return $mid; if ($cmp < 0) { $max = $mid - 1; } else { $min = $mid + 1; } } return _unsigned_to_signed(~$min); } 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. something; # something is executed in a void context. # Arrays return their number of elements in a scalar context: @b = qw( a b c ); print( @b , "\n"); # abc print(scalar(@b), "\n"); # 3 # print accepts a list, but scalar() forced scalar context. # Arithmetic forces scalar context: print(@b,"\n"); # abc print(@b."\n"); # 3 # Not just string arithmetic: print(@b, "\n"); # abc print(@b+0, "\n"); # 3 # Functions can examine their context: { local $, = ", "; local $\ = "\n"; print( localtime ); # 59, 14, 15, 1, 9, 104, 5, 274, 1 print(scalar(localtime)); # Fri Oct 1 15:05:32 2004 } # Refer to wantarray in perlfunc. #### sub nearest { my ($num) = @_; $num += 0; return 0 unless $num; my $f = $num <=> 0; $num = abs($num); while ($num >= 10) { $num /= 10; $f *= 10; } while ($num < 1) { $num *= 10; $f /= 10; } return int($num + 0.5) * $f; } #### sub nearest { my ($num, $digits) = @_; $num += 0; $digits ||= 1; return 0 unless $num; my $f = $num <=> 0; $num = abs($num); my $d = 1; $d *= 10 while (--$digits); while ($num < $d) { $num *= 10; $f /= 10; } $d *= 10; while ($num >= $d) { $num /= 10; $f *= 10; } return int($num + 0.5) * $f; } #### $stmt = 'SELECT Field1, Field2 FROM Table'; $href = { map { @$_ } @{$dbh->selectall_arrayref($stmt)} }; # Returns: # $href = { # Row1Field1 => Row1Field2, # Row2Field1 => Row2Field2, # ... # }; #### $stmt = 'SELECT Field1, Field2 FROM Table'; $href = $dbh->selectall_hashref($stmt, 'Field1'); # Returns: # $href = { # Row1Field1 => { Field1 => Row1Field1, Field2 => Row1Field2 }, # Row2Field1 => { Field1 => Row2Field1, Field2 => Row2Field2 }, # ... # }; #### # Serializes an array, a hash or a list which contains only # strings and undefs. Everything else will be stringified. # Use FreezeThaw for more complicated structures. sub serialize_string_list { return join('|', map { (defined($_) ? do { local $_=$_; s/\^/^1/g; s/\|/^2/g; $_ } : '^0' ) } @_ ); } # Deserializes a list serialized with serialize_string_list. sub deserialize_string_list { return map { ($_ eq '^0' ? undef : do { local $_=$_; s/\^2/|/g; s/\^1/^/g; $_ } ) } split(/\|/, $_[0]); } #### # Untested. use CGI; $q = new CGI(); # Input. my $num1 = $q->param('num1'); my $num2 = $q->param('num2'); $num1 = undef if ($q->param{'clear_num1'}); $num2 = undef if ($q->param{'clear_num2'}); # Validate. $num1 = undef unless (defined($num1) && $num1 =~ /^\d+$/); $num2 = undef unless (defined($num2) && $num2 =~ /^\d+$/); # Start HTML. print($q->header()); print($q->start_html(-title=>'Price guide')); print($q->start_form()); # Display num1 and operations for num1. print('First number: '); if (defined($num1)) { print($num1, $q->hidden(-name=>'num1', -default=>$num1)); print(' '); print($q->submit(-name=>'clear_num1', -value=>'Clear'); } else { print($q->textfield(-name=>'num1')); } print($q->br); # Display num2 and operations for num2. print('Second number: '); if (defined($num2)) { print($num2, $q->hidden(-name=>'num2', -default=>$num2)); print(' '); print($q->submit(-name=>'clear_num2', -value=>'Clear'); } else { print($q->textfield(-name=>'num2')); } print($q->br); print($q->submit()); # End HTML. print($q->end_form()); print($q->end_html()); #### sub flush { my $h = select($_[0]); my $af=$|; $|=1; $|=$af; select($h); } #### package MyStruct; sub new { my $class = shift(@_); return bless({@_}, $class); } sub Counter : lvalue { my $self = shift(@_); $self->{'Counter'} = $_[0] if (scalar(@_)); $self->{'Counter'} } package main; { my $x = MyStruct->new(Counter=>0); print($x->Counter, "\n"); # 0 $x->Counter($x->Counter + 1); print($x->Counter, "\n"); # 1 $x->Counter = $x->Counter + 1; print($x->Counter, "\n"); # 2 ++($x->Counter); print($x->Counter, "\n"); # 3 ++$x->Counter; print($x->Counter, "\n"); # 4 $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; my $input = "test\nfoo\nbar\n"; my $output; { local *STDIN; open(STDIN, '<', \$input) or die("Can't open string for reading.\n"); local *STDOUT; open(STDOUT, '>', \$output) or die("Can't open string for writing.\n"); print while (); } print("\$output contains:\n$output"); #### Windows Registry Editor Version 5.00 [HKEY_CLASSES_ROOT\Directory\shell\cmd] @="Open &Command Prompt Here" [HKEY_CLASSES_ROOT\Directory\shell\cmd\command] @="cmd.exe /k \"cd %L\"" [HKEY_CLASSES_ROOT\Drive\shell\cmd] @="Open &Command Prompt Here" [HKEY_CLASSES_ROOT\Drive\shell\cmd\command] @="cmd.exe /k \"cd %L\"" #### use strict; use warnings; sub test ($;$$$) { shift(@_) unless ($_[0] =~ /^\d/); printf("test %d: %s\n", @_[0,1]); } my @extra_args = qw( bypassed foo bar ); test(1, @extra_args); &test(2, @extra_args); { local @_ = (3, @extra_args); &test; } &{\&test}(4, @extra_args); main->test(5, @extra_args); __END__ output ====== test 1: 3 test 2: bypassed 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] } sort { $a->[1] <=> $b->[1] } map { [ $_, stat("$target_dir\\$_"))[9] ] } @status ); #### use Alorithm::Loops; sub transpose_AoS { # [ [ # 'aeh', # 'abcd', 'bfi', # 'efg', ==> 'cgj', # 'hijkl', 'd k', # ' l', # ] ] return [ MapCarU { join('', map { defined($_) ? $_ : ' ' } @_) } map { [ /(.)/sg ] } @{$_[0]} ]; } #### use strict; use warnings; my $p = undef; 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 {} sub PACKAGED::test {} sub test {} # Create some packages without the subroutine: $PACKAGEA::PACKAGEB::PACKAGEC::ANYVAR = 1; $PACKAGEE::ANYVAR = 1; sub find_sub { my ($sub_name) = @_; my @pkgs_with_sub; my $helper; # $helper must be initialized seperately from its definition. $helper = sub { my ($pkg_name) = @_; my $pkg = do { no strict 'refs'; \%{$pkg_name.'::'} }; push(@pkgs_with_sub, $pkg_name) if $pkg->{$sub_name} && *{$pkg->{$sub_name}}{CODE}; my $pkg_name_ = ($pkg_name eq 'main' ? '' : $pkg_name.'::' ); /^(.*)::$/ && $1 ne 'main' && &$helper($pkg_name_.$1) foreach (keys(%$pkg)); }; &$helper('main'); return @pkgs_with_sub; } print(join(', ', check_for_sub('test')), $/); # Prints "main, PACKAGEA::PACKAGEB, PACKAGED" #### # Create some packages for testing: $PACKAGEA::ANYVAR = 1; $PACKAGEA::PACKAGEB::VARANY = 1; foreach (qw( PACKAGEA PACKAGEA::PACKAGEB PACKAGEC )) { my @pkg; my $pkg; @pkg = split(/::/, $_); $pkg = \%main::; $pkg = $pkg->{shift(@pkg).'::'} while ($pkg && scalar(@pkg)); print($_, ' ', $pkg ? 'exists' : 'doesn\'t exist', "\n"); } __END__ output: ======= PACKAGEA exists PACKAGEA::PACKAGEB exists PACKAGEC doesn't exist #### # Create some packages for testing: $PACKAGEA::ANYVAR = 1; $PACKAGEA::PACKAGEB::ANYVAR = 1; $PACKAGEA::PACKAGEB::PACKAGEC::ANYVAR = 1; #my $pkg_name = 'main'; #my $pkg_name = 'PACKAGEA::PACKAGEB'; my $pkg_name = 'Authorizations'; my @pkg; my $pkg; @pkg = split(/::/, $pkg_name); $pkg = \%main::; $pkg = $pkg->{shift(@pkg).'::'} while ($pkg && scalar(@pkg)); $pkg or die("Package ${pkg_name} doesn't exist.\n"); $, = "\n"; print( map { substr($_, 0, -2) } ( grep { substr($_, -2) eq '::' } ( keys(%$pkg) ) ) ); __END__ output for $pkg_name eq 'main': =============================== attributes DB UNIVERSAL DynaLoader Win32 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". char chars[5] = "hello"; // ERROR at compile-time. // ANSI C: char string[6] = "hello"; // Initializes string[] to "hello\0". char chars[5] = "hello"; // Initializes chars[] to "hello". char bad[4] = "hello"; // ERROR. Only a trailing nul can be cut. // Not the same. char a1[6] = "hello"; char *a2 = "hello"; a1[0] = 'H'; // OK a2[0] = 'H'; // ERROR a1 = "Greetings"; // ERROR a2 = "Greetings"; // OK