My mini tutorials (Follow link, then click Search)
My tutorials (Follow link, then click Search)
Jargon relating to Perl strings
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),
]),
]);
}
Re: meaning of '@' sigil on a hash?
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 $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
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
|
