?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 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
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.
Moved to Mini-Tutorial: Working with Odd/Even Elements
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)
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
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";
}
Moved to Mini-Tutorial: Mutual Use of Exporting Modules
Moved to Mini-Tutorial: Dereferencing Syntax
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;
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
&{\&$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.
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
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.
/^(?:(?!$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.
Moved to Re: Look-Arounds in Regexes are Hard (Common Use of a Negative Lookahead)
TODO: Read the following and implement something
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
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.
# 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])) }
$i = 4; print($i) while ($i--); # 3210
$i = 4; do { print($i) } while ($i--); # 43210
If there's any doubt that spyware is harmful, consider that 20% of Dell's service calls are spyware related. (Oct 2004 figure)
$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.
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;
}
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;
}
$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 },
# ...
# };
# 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.
# 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);
}
IO::Handle also has a flush method.
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).
# 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");
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\""
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
Check out 389211 and Win32::PerfLib
@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
);
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!!
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.
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"
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
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
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"
// 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
|
