Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

ikegami's scratchpad

by ikegami (Pope)
on Aug 16, 2004 at 23:32 UTC ( #383504=scratchpad: print w/ replies, xml ) Need Help??

?node_id=3989;HIT=Mini-Tutorial%3A;HIS=%3B;a=ikegami;re=N
?node_id=3989;a=ikegami;re=N;Tu
Jargon relating to Perl strings


For davido,

The segfault occurs within a m// in Perl code. Regex matching used recursion in older version of Perl to the point that it could exhaust the C stack. I suspect this is happening here.

Program received signal SIGSEGV, Segmentation fault. 0x00000000004d406e in S_regmatch (prog=Cannot access memory at address + 0x3e4dd10ce38 ) at regexec.c:2031 2031 { (gdb) bt #0 0x00000000004d406e in S_regmatch (prog=Cannot access memory at add +ress 0x3e4dd10ce38 ) at regexec.c:2031 #1 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #2 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #3 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #4 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #5 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #6 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #7 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #8 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #9 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 #10 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:3093 ... #6884 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:30 +93 #6885 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:30 +93 #6886 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:30 +93 #6887 0x00000000004d8770 in S_regmatch (prog=0xa96e18) at regexec.c:30 +93 #6888 0x00000000004d8770 in S_regmatch (prog=0xa96ed0) at regexec.c:30 +93 #6889 0x00000000004d785e in S_regmatch (prog=0xa96e08) at regexec.c:29 +00 #6890 0x00000000004d8770 in S_regmatch (prog=0xa96ee0) at regexec.c:30 +93 #6891 0x00000000004d785e in S_regmatch (prog=0xa96df4) at regexec.c:29 +00 #6892 0x00000000004d3fc6 in S_regtry (prog=0xa96d90, startpos=0xb715c2 + 'a' <repeats 200 times>...) at regexec.c:1913 #6893 0x00000000004d2534 in Perl_regexec_flags (prog=0xa96d90, stringa +rg=0xb715c2 'a' <repeats 200 times>..., strend=0xb795c4 "", strbeg=0xb715c0 "[\"", 'a' <repeats 198 times>..., minend=0, sv=0x +b292b0, data=0x0, flags=10) at regexec.c:1510 #6894 0x0000000000464020 in Perl_pp_match () at pp_hot.c:1337 #6895 0x000000000043e20c in Perl_runops_debug () at dump.c:1639 #6896 0x0000000000459750 in S_run_body (oldscope=1) at perl.c:2448 #6897 0x0000000000459275 in perl_run (my_perl=0x792700) at perl.c:2368 #6898 0x000000000041ff67 in main (argc=3, argv=0x3e4dd90b478, env=0x3e +4dd90b498) at perlmain.c:109

For Xiong,

use IPC::Open3 qw( open3 ); # Avoid having our STDIN closed. open(local *TO_CHILD, '<', '/dev/null') or die $!; my $pid = open3( '<&TO_CHILD', local *FROM_CHILD, '>&STDERR', '-', # fork without exec ); if (!$pid) { # Child my $command = qq{script -f}; $terminal->feed_child( "$command\n" ); exit(0); } while (<FROM_CHILD>) { ... } waitpid($pid, 0);

For Xiong,

use IPC::Open3 qw( open3 ); # Avoid having our STDIN closed. open(local *TO_CHILD, '<', '/dev/null') or die $!; my $pipe = "..."; # Use File::Temp mkfifo($pipe, 0700) or die $!; my $pid = open3( '<TO_CHILD', '>STDOUT', '>STDERR', '-', # fork without exec ); if (!$pid) { # Child my $command = qq{script -f -a $pipe}; $terminal->feed_child( "$command\n" ); exit(0); } open(my $fh, '<', $pipe) or die $!; while (<$fh>) { ... } waitpid($pid, 0);

For thezip,

>type script.bat @echo off set today= 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%

With DateTime, it would be:

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

For metalgear119,

>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

For Jurassic Monk,

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_eleme +nt ); 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', 'A +mount' => $tax_and_surch), ]), gen_element('TotalFare', 'Amount' => $total), ]), ]); }

#!/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 [STDERR:E] $ x 2>/dev/null O $ x 1>/dev/null [STDERR:E]

But err=$( ... ) flattens whitespace.


For mr_mischief,

# Set your timezone to America/New_York before running. # In this time zone, DST ends on Nov 2, 2008 at 2:00 AM. # "Sets" the current time to 5 seconds past midnight on Oct 28, 2008. use Time::Local qw( timelocal ); my $time = timelocal(5,0,0,28,10-1,2008); use POSIX; print( strftime( "%m-%d\n", localtime( 86400 * $_ + $time ) ) ) for 1..30;

Output

10-29 10-30 10-31 11-01 11-02 \ 11-02 got created twice 11-02 / 11-03 11-04 11-05 11-06 11-07 11-08 11-09 11-10 11-11 11-12 11-13 11-14 11-15 11-16 11-17 11-18 11-19 11-20 11-21 11-22 11-23 11-24 11-25 11-26 > 11-27 didn't get created

Re: meaning of '@' sigil on a hash?


Say you have records of class Document and of class Animal and there is a n:n relationship between them. The logical database representation would be:

+-------------+ +-------------+ +-------------+ | Document | | Linkage | | Animal | +-------------+ +-------------+ +-------------+ | P1 id | | P1 web_page | | P1 id | | data | | P1 animal | | P2 name | | | | data? | | data | +-------------+ +-------------+ +-------------+ P - Primary key (Unique, Not NULL)

Given that above schema, the following query selects all documents associated with *any* of a given list of animals (say dog, cat and plesiosaur).

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

What would be the query to select all documents associated with *all* of a given list of animals?

Update: This is a good solution:

SELECT Document.data FROM Document WHERE Document.id IN ( SELECT Linkage.a FROM Linkage INNER JOIN Animal ON Linkage.b = Animal.id WHERE Animal.name IN (?, ?, ...) GROUP BY Linkage.a HAVING COUNT(*) = ? )

Update: Changed name = ? OR name = ? OR ... to name IN (?, ?, ...).

Update: Changed "TableA" and "TableB" to "Document" and "Animal" to ease comprehension.

Thank clinton and olus.


Index


Inline and block elements in HTML 4.01 (strict)

The distinction between inline and block is only meaninful to descendants of BODY, so anything that can't be a descendant of BODY is neither. Any instance of an element that isn't a descendant of BODY (e.g. a SCRIPT element in the header) is neither.

Inline
text TT I B BIG SMALL EM STRONG DFN CODE SAMP KBD VAR CITE ABBR ACRONYM A IMG OBJECT BR SCRIPT*1 MAP Q SUB SUP SPAN BDO INPUT SELECT TEXTAREA LABEL BUTTON
Block
P H1 H2 H3 H4 H5 H6 UL OL PRE DL DIV NOSCRIPT BLOCKQUOTE FORM HR TABLE FIELDSET ADDRESS
Both*2
INS DEL

*1 — SCRIPT can also appear as a direct child of BODY and BLOCKQUOTE where only block elements are normally allowed.

*2 — They can be used as both, but a particular instance of these elements is either one or the other, not both.


Working with Odd/Even Elements

Moved to Mini-Tutorial: Working with Odd/Even Elements


Toggling binmode in Perl v5.6.1

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");

Alternative:

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");

(See Mini-Tutorial: Scoped changes to PerlIO layers)


for (reverse a..b) Still Inefficient

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(":"); <STDIN>; last; } # 2.2MB for ( reverse $min .. $max) { print(":"); <STDIN>; last; } # 239MB

Generating a Unique File Name

This will generate a unique file name, IE-style. (filename.ext -> filename[1].ext -> filename[2].ext).

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"; }

Mutual Use of Exporting Modules

Moved to Mini-Tutorial: Mutual Use of Exporting Modules


Dereferencing Syntax

Moved to Mini-Tutorial: Dereferencing Syntax


Examples of Functions as Iterators

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;

Listing Numbers Matching a Mask

The following loops efficiently through the numbers matching a provided mask.

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; }

Output:

0x00000000 0x00000001 0x00000002 0x00000003 0x02000000 0x02000001 0x02000002 0x02000003 0x04000000 0x04000001 0x04000002 0x04000003 0x06000000 0x06000001 0x06000002 0x06000003

Hole in use strict 'refs'

&{\&$function_name}(...) and
(\&$function_name)->(...)
call a function by symbol while strict 'refs' is on. Just like
$pkg->$method_name(...) and
$obj->$method_name(...)

Tested on v5.6.1 and v5.8.0.


Aliasing an Array to a Slice of an Array

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

Info About FTP


Updating ActivePerl's Docs

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

Removing the File Component from a URL

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/

Ways to Launch Another Program

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

TODO: Make a table illustrating the different features and problems each method has. Important information includes:

  • Overwrites current process, or not.
  • Executes in parallel, or waits.
  • Accepts a handle to use as the child's STDIN, or not.
  • Accepts a handle to use as the child's STDOUT, or not.
  • Accepts a handle to use as the child's STDERR, or not.
  • Access to the system call's error code, or not.
  • Access to the child's return code, or not.
  • Limit on the size of the command.
  • OS compatibility.
  • Source of further documentation.

TODO: Add ways of executing Perl code in the current process.


Boolean Logic in Regular Expression

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

The NOT regexp must be anchored on both ends, but it doesn't have to be with ^ and $.

The AND regexp doesn't have to be anchored, but if the start is anchored (with ^ or by some other means), it should speed up the case where there is no match.

The two instances of .* in the AND regexp may need to be replaced with something less general so it doesn't look too far ahead.


The Common Use of a Negative Lookahead

Moved to Re: Look-Arounds in Regexes are Hard (Common Use of a Negative Lookahead)

TODO: Read the following and implement something


Closures Illustrated

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.

Maintaining Proportions When Scaling an Image

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

Using glob to Permute

A solution that only works with numbers:

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;

A more generalized solution:

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;

It can also be written as a generator.


Flexible Binary Search Function

# 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 $i = 0; my $j = $#$array; return $j if $j == -1; my $ap = do { no strict 'refs'; \*{caller().'::a'} }; local *$ap; my $bp = do { no strict 'refs'; \*{caller().'::b'} }; local *$bp; *$ap = \($_[1]); for (;;) { my $k = int(($i+$j)/2); *$bp = \($array->[$k]); my $cmp = $compare->() or return $k; if ($cmp < 0) { $j = $k-1; return _unsigned_to_signed(~$k) if $i > $j; } else { $i = $k+1; return _unsigned_to_signed(~$i) if $i > $j; } } } sub _unsigned_to_signed { unpack('j', pack('J', $_[0])) }

stmt while vs do while

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

A Comment on Spyware

If there's any doubt that spyware is harmful, consider that 20% of Dell's service calls are spyware related. (Oct 2004 figure)


Scalar vs List Context

$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.

Rounding to One Significant Digit

This handles any floats, including those which are negative and those between +-1 and 0.

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; }

Rounding to X Significant Digits

This handles any floats, including those which are negative and those between +-1 and 0.

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; }

DB Table as a Hash

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

This is not the same as fetchall_hashref/selectall_hashref:

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

Serializing a List

# 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]); }

For example,
serialize_string_list('apple' => 'red', 'junk'  => '^|^|^|^', 'undef' => undef);
returns
apple|red|junk|^1^2^1^2^1^2^1|undef|^0

I didn't use a single-character escape mechanism (such as preceeding metacharacters with a slash) since it makes deserialization hard. (i.e. "Should I split on this pipe, or is that an escaped pipe?") The escape mechanism I used -- replacing the seperator character with another character -- avoids that problem, simplifying parsing. IP over Serial Line (SLIP) and maybe Point to Point Protocol (PPP) use a similar escaping algorithm to escape packet delimiters because the delimiters cannot appear inside a packet.


State Passing in CGI Via Hidden Fields

# 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());

Flushing a File Handle

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

IO::Handle also has a flush method.


Returning an lvalue

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 }

return $var does not return an lvalue, even if the lvalue attribute is present. That means if (condition) { return $var; } won't work as expected. However, condition ? $var1 : $var2 at the end of the function does return an lvalue as expected (if the lvalue attribute is present).


Redirecting STDIN and STDOUT to a string

# 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 (<STDIN>); } print("\$output contains:\n$output");

Command Prompt Here

The following is file Add 'Open Command Prompt Here' to directories.reg (for Win2k and WinXP). Once you merge this into your registry, you can right-click on any folder or drive icon in Explorer to open a command prompt with that directory as the current directory (although you may start on the wrong drive). To use the directory currently being viewed, right-click on the system menu (the top left icon) of the Explorer window.

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\""

Bypassing Prototypes

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

Logging and Analysing Performance Counters in Windows

Check out 389211 and Win32::PerfLib


Textbook Case for the Use of the Schwartzian Transform

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

is very expensive because stat can be called multiple times for each file. The workaround is:

@status = ( map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, stat("$target_dir\\$_"))[9] ] } @status );

Parsing


Transposing an Array of Strings

use Alorithm::Loops; sub transpose_AoS { # [ [ # 'aeh', # 'abcd', 'bfi', # 'efg', ==> 'cgj', # 'hijkl', 'd k', # ' l', # ] ] return [ MapCarU { join('', map { defined($_) ? $_ : ' ' } @_) } map { [ /(.)/sg ] } @{$_[0]} ]; }

A Bug in use warnings;

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

This is not a bug. It's a case of auto-vivification. If you observe $p and $q after executing the above, you'll notice they now have values:

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

I wish there was a means of turning off auto-vivification.


Symtab Exploration

Finding All Packages with a Specified Subroutine
# 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"

Symtab Exploration

Checking If a List of Packages Exist
# 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

Symtab Exploration

Listing Subpackages of a Specified Package
# 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 <none> DynaLoader Win32 IO CORE main

IE's Handling of <FONT COLOR>

Without semicolon:
a t   d e m e p h q
---
With semicolon:
a t   d e m e p h q
---
Removed first digit and replaced semicolon with zero:
a t   d e m e p h q

It appears that IE does:

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

Thus,
color="amanda"
is interpreted as:
color="#A0A0DA"


C String Assignments

// 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
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (7)
As of 2014-12-18 02:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (41 votes), past polls