#! perl -w -l print $]; tie $_, 'MyTie'; $_ = 123; { local $_ = 456; print; } print; { package MyTie; sub TIESCALAR { my $class = shift; my $scalar; return bless \$scalar, $class; } sub FETCH { my $this = shift; local $\ = "\n"; print "FETCH from $this: $$this"; return $$this; } sub STORE { my $this = shift; my $value = shift; local $\ = "\n"; print "STORE to $this: $value"; $$this = $value; } sub DESTROY { my $this = shift; local $\ = "\n"; print "DESTROY $this"; } sub UNTIE { my $this = shift; local $\ = "\n"; print "UNTIE $this"; } } #### > "perl" test.pl Use of uninitialized value $value in concatenation (.) or string at test.pl line 32. 5.012002 STORE to MyTie=SCALAR(0x326328): 123 FETCH from MyTie=SCALAR(0x326328): 123 STORE to MyTie=SCALAR(0x326328): STORE to MyTie=SCALAR(0x326328): 456 FETCH from MyTie=SCALAR(0x326328): 456 456 STORE to MyTie=SCALAR(0x326328): 123 FETCH from MyTie=SCALAR(0x326328): 123 123 DESTROY MyTie=SCALAR(0x326328) #### #! perl -w use utf8; my $set = ''; my @set; for(my $ord = 1; $ord < 64*1024; $ord++) { eval { # not every "character" composed this way is valid Unicode no warnings; if(chr($ord) =~ /[גדהוāăąבא]/) { push @set, $ord; vec($set, $ord, 1) = 1; } } } # "toggle list" AKA inversion list my $toggle = 0; my @list; foreach my $window (0 .. length($set)) { next if vec($set, $window, 8) == $toggle; for my $i (8*$window .. 8*$window+7) { next if (vec($set, $i, 1) == ($toggle ? 1 : 0)); push @list, $i; $toggle = $toggle ? 0 : 255; } } # back to charclass, for Javascript my $class = ''; for(my $i = 0; $i < @list; $i+=2) { $class .= sprintf '\\u%04x', $list[$i]; next if $list[$i+1] == $list[$i]+1; $class .= sprintf '-\\u%04x', $list[$i+1]-1; } print "/[$class]/\n"; #### /[\u00e0-\u00e5\u0101\u0103\u0105]/ #### #! perl -w use Benchmark qw(:all); use 5.010; my $s = "123 foo"; my $n = "123 "; cmpthese -1, { clean => sub { return "$n"<=>100 }, local => sub { local $^W; return "$s"<=>100 }, lexical => sub { no warnings 'numeric'; return "$s"<=>100 }, capture => sub { my($x)= $s =~ /(\d+)/; return $x<=>100 }, suppress => sub { (my $x = $s)=~s/ .*//; return $x<=>100 }, substr => sub { return substr($s, 0, index $s, ' ')<=>100 }, }; #### Rate capture local suppress lexical substr clean capture 195157/s -- -25% -73% -86% -88% -92% local 261057/s 34% -- -64% -81% -84% -89% suppress 721504/s 270% 176% -- -47% -57% -70% lexical 1371744/s 603% 425% 90% -- -18% -43% substr 1679632/s 761% 543% 133% 22% -- -31% clean 2427737/s 1144% 830% 236% 77% 45% -- #### use DBIx::Simple; unlink 'testdb.sqlite'; # drop the database file my $db = DBIx::Simple->connect('dbi:SQLite:testdb.sqlite'); # recreate an empty database file $db->query(<<'^CREATE^'); create table test ( id integer not null primary key, name text not null unique, value text, num integer ) ^CREATE^ print $db->query("insert into test (name, value, num) values (?, ?, ?)", 'foo', 'one', 1)->rows ? 'Y' : 'N'; print $db->query("insert into test (name, value, num) values (?, ?, ?)", 'bar', 'two', 2)->rows ? 'Y' : 'N'; print $db->query("insert into test (name, value, num) values (?, ?, ?)", 'baz', 'three', 3)->rows ? 'Y' : 'N'; print $db->query("insert into test (name, value, num) values (?, ?, ?)", 'foo', 'fails', 4)->rows ? 'Y' : 'N'; #won't work = OK print $db->query("insert or replace into test (name, value) values (?, ?)", 'bar', 'replaces')->rows ? 'Y' : 'N'; # no number print "\n"; foreach ($db->query('select * from test')->arrays) { local($\, $,) = ("\n", "\t"); print map { defined $_ ? $_ : 'NULL' } @$_; } #### YYYNY 1 foo one 1 3 baz three 3 4 bar replaces NULL #### warn "first block"; warn "second block"; #### Syntax error on line 33 of /etc/apache2/listen.conf: syntax error at /etc/apache2/listen.conf line 36, near "perl>"\n #### warn "first block"; " # "; warn "second block"; #### first block at /etc/apache2/listen.conf line 33. second block at /etc/apache2/listen.conf line 39. Syntax OK #### C:\Documents and Settings\Bart\Mijn Documenten>perl -MExtUtils::Liblist -MData::Dumper -le "print Dumper(ExtUtils::Liblist->ext('-lJudy', 1))" Set up gcc environment - 3.4.5 (mingw-vista special r3) Potential libraries are '-lJudy -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lmsvcrt': '-lJudy' not found as '/lib\libJudy.a' '-lJudy' not found as 'C:\Perl\lib/CORE\libJudy.a' '-lJudy' not found as 'd:/Devel/MinGW/lib\libJudy.a' '-lJudy' not found as '/lib\Judy.a' '-lJudy' not found as 'C:\Perl\lib/CORE\Judy.a' '-lJudy' not found as 'd:/Devel/MinGW/lib\Judy.a' Note (probably harmless): No library found for -lJudy '-lkernel32' not found as '/lib\libkernel32.a' '-lkernel32' not found as 'C:\Perl\lib/CORE\libkernel32.a' '-lkernel32' found as 'd:/Devel/MinGW/lib\libkernel32.a' '-luser32' not found as '/lib\libuser32.a' '-luser32' not found as 'C:\Perl\lib/CORE\libuser32.a' '-luser32' found as 'd:/Devel/MinGW/lib\libuser32.a' '-lgdi32' not found as '/lib\libgdi32.a' '-lgdi32' not found as 'C:\Perl\lib/CORE\libgdi32.a' '-lgdi32' found as 'd:/Devel/MinGW/lib\libgdi32.a' '-lwinspool' not found as '/lib\libwinspool.a' '-lwinspool' not found as 'C:\Perl\lib/CORE\libwinspool.a' '-lwinspool' found as 'd:/Devel/MinGW/lib\libwinspool.a' '-lcomdlg32' not found as '/lib\libcomdlg32.a' '-lcomdlg32' not found as 'C:\Perl\lib/CORE\libcomdlg32.a' '-lcomdlg32' found as 'd:/Devel/MinGW/lib\libcomdlg32.a' '-ladvapi32' not found as '/lib\libadvapi32.a' '-ladvapi32' not found as 'C:\Perl\lib/CORE\libadvapi32.a' '-ladvapi32' found as 'd:/Devel/MinGW/lib\libadvapi32.a' '-lshell32' not found as '/lib\libshell32.a' '-lshell32' not found as 'C:\Perl\lib/CORE\libshell32.a' '-lshell32' found as 'd:/Devel/MinGW/lib\libshell32.a' '-lole32' not found as '/lib\libole32.a' '-lole32' not found as 'C:\Perl\lib/CORE\libole32.a' '-lole32' found as 'd:/Devel/MinGW/lib\libole32.a' '-loleaut32' not found as '/lib\liboleaut32.a' '-loleaut32' not found as 'C:\Perl\lib/CORE\liboleaut32.a' '-loleaut32' found as 'd:/Devel/MinGW/lib\liboleaut32.a' '-lnetapi32' not found as '/lib\libnetapi32.a' '-lnetapi32' not found as 'C:\Perl\lib/CORE\libnetapi32.a' '-lnetapi32' found as 'd:/Devel/MinGW/lib\libnetapi32.a' '-luuid' not found as '/lib\libuuid.a' '-luuid' not found as 'C:\Perl\lib/CORE\libuuid.a' '-luuid' found as 'd:/Devel/MinGW/lib\libuuid.a' '-lws2_32' not found as '/lib\libws2_32.a' '-lws2_32' not found as 'C:\Perl\lib/CORE\libws2_32.a' '-lws2_32' found as 'd:/Devel/MinGW/lib\libws2_32.a' '-lmpr' not found as '/lib\libmpr.a' '-lmpr' not found as 'C:\Perl\lib/CORE\libmpr.a' '-lmpr' found as 'd:/Devel/MinGW/lib\libmpr.a' '-lwinmm' not found as '/lib\libwinmm.a' '-lwinmm' not found as 'C:\Perl\lib/CORE\libwinmm.a' '-lwinmm' found as 'd:/Devel/MinGW/lib\libwinmm.a' '-lversion' not found as '/lib\libversion.a' '-lversion' not found as 'C:\Perl\lib/CORE\libversion.a' '-lversion' found as 'd:/Devel/MinGW/lib\libversion.a' '-lodbc32' not found as '/lib\libodbc32.a' '-lodbc32' not found as 'C:\Perl\lib/CORE\libodbc32.a' '-lodbc32' found as 'd:/Devel/MinGW/lib\libodbc32.a' '-lodbccp32' not found as '/lib\libodbccp32.a' '-lodbccp32' not found as 'C:\Perl\lib/CORE\libodbccp32.a' '-lodbccp32' found as 'd:/Devel/MinGW/lib\libodbccp32.a' '-lmsvcrt' not found as '/lib\libmsvcrt.a' '-lmsvcrt' not found as 'C:\Perl\lib/CORE\libmsvcrt.a' '-lmsvcrt' found as 'd:/Devel/MinGW/lib\libmsvcrt.a' Result: d:\Devel\MinGW\lib\libkernel32.a d:\Devel\MinGW\lib\libuser32.a d:\Devel\MinGW\lib\libgdi32.a d:\Devel\MinGW\lib\libwinspool.a d:\Devel\MinGW\lib\libcomdlg32.a d:\Devel\MinGW\lib\libadvapi32.a d:\Devel\MinGW\lib\libshell32.a d:\Devel\MinGW\lib\libole32.a d:\Devel\MinGW\lib\liboleaut32.a d:\Devel\MinGW\lib\libnetapi32.a d:\Devel\MinGW\lib\libuuid.a d:\Devel\MinGW\lib\libws2_32.a d:\Devel\MinGW\lib\libmpr.a d:\Devel\MinGW\lib\libwinmm.a d:\Devel\MinGW\lib\libversion.a d:\Devel\MinGW\lib\libodbc32.a d:\Devel\MinGW\lib\libodbccp32.a d:\Devel\MinGW\lib\libmsvcrt.a $VAR1 = 'd:\\Devel\\MinGW\\lib\\libkernel32.a d:\\Devel\\MinGW\\lib\\libuser32.a d:\\Devel\\MinGW\\lib\\libgdi32.a d:\\Devel\\MinGW\\lib\\libwinspool.a d:\\Devel\\MinGW\\lib\\libcomdlg32.a d:\\Devel\\MinGW\\lib\\libadvapi32.a d:\\Devel\\MinGW\\lib\\libshell32.a d:\\Devel\\MinGW\\lib\\libole32.a d:\\Devel\\MinGW\\lib\\liboleaut32.a d:\\Devel\\MinGW\\lib\\libnetapi32.a d:\\Devel\\MinGW\\lib\\libuuid.a d:\\Devel\\MinGW\\lib\\libws2_32.a d:\\Devel\\MinGW\\lib\\libmpr.a d:\\Devel\\MinGW\\lib\\libwinmm.a d:\\Devel\\MinGW\\lib\\libversion.a d:\\Devel\\MinGW\\lib\\libodbc32.a d:\\Devel\\MinGW\\lib\\libodbccp32.a d:\\Devel\\MinGW\\lib\\libmsvcrt.a'; $VAR2 = ''; $VAR3 = 'd:\\Devel\\MinGW\\lib\\libkernel32.a d:\\Devel\\MinGW\\lib\\libuser32.a d:\\Devel\\MinGW\\lib\\libgdi32.a d:\\Devel\\MinGW\\lib\\libwinspool.a d:\\Devel\\MinGW\\lib\\libcomdlg32.a d:\\Devel\\MinGW\\lib\\libadvapi32.a d:\\Devel\\MinGW\\lib\\libshell32.a d:\\Devel\\MinGW\\lib\\libole32.a d:\\Devel\\MinGW\\lib\\liboleaut32.a d:\\Devel\\MinGW\\lib\\libnetapi32.a d:\\Devel\\MinGW\\lib\\libuuid.a d:\\Devel\\MinGW\\lib\\libws2_32.a d:\\Devel\\MinGW\\lib\\libmpr.a d:\\Devel\\MinGW\\lib\\libwinmm.a d:\\Devel\\MinGW\\lib\\libversion.a d:\\Devel\\MinGW\\lib\\libodbc32.a d:\\Devel\\MinGW\\lib\\libodbccp32.a d:\\Devel\\MinGW\\lib\\libmsvcrt.a'; $VAR4 = ''; C:\Documents and Settings\Bart\Mijn Documenten> #### perl reconnect.pl G: H: #### #! perl -wl my %net_use; foreach (net_use()) { push @{$net_use{uc $_->[1]}}, $_; } # use Data::Dumper; # print Dumper \%net_use; @ARGV or @ARGV = keys %net_use; foreach my $drive (@ARGV) { $drive =~ s/^([a-z]):?$/\U$1:/i or $drive = ''; if(my $ary = $net_use{$drive}) { print STDERR "Processing $drive"; foreach my $connect (@$ary) { unless($connect->[0] =~ /\bok\b/i) { my $cmd = "net use $connect->[1] \"$connect->[2]\""; print STDERR $cmd; system($cmd) and print ' FAILED'; } } } else { print STDERR "Skipping $drive"; } } sub net_use { # return a data structure parsing the info from NET USE my @net = grep /\S/, `net use`; # parse the title (after searching for the underline line and using the line in front of it) to extract table structure my($hr) = grep $net[$_] =~ /^([^\s\w])\1+$/, 1 .. $#net; my @right; while($net[$hr-1] =~ /\S+(?:\ \S+)*/g) { push @right, $-[0]; } $right[0] = 0; # drop title and underline splice @net, 0, $hr+1; # process lines my $unpack = join '', map "A$_", map($right[$_]-$right[$_-1], 1 .. $#right), '*'; # print $unpack; return grep $_->[2] =~ /^\\\\/, map [ unpack $unpack, $_ ], @net; } #### .chatfrom_599759:after { content:" ..."; } .chatfrom_599759 .content { display:none; } span.chatfrom_599759:hover .content { display:inline; } span.chatfrom_599759:hover:after { content: ""; } #### print ignore_css(qw(190859 599759)); sub ignore_css { if(my @ignored = @_) { local $" = ",\n"; return <<"^CSS^"; @{[map sprintf('.chatfrom_%d:after', $_), @ignored]} { content:" ..."; } @{[map sprintf('.chatfrom_%d .content', $_), @ignored]} { display:none; } @{[map sprintf('span.chatfrom_%d:hover .content', $_), @ignored]} { display:inline; } @{[map sprintf('span.chatfrom_%d:hover:after', $_), @ignored]} { content: ""; } ^CSS^ } return ""; } #### #! perl -w { package Report; use strict; sub TIESCALAR { my $class = shift; printf "The Start\n"; bless \(my $scalar), $class; } sub FETCH { my $self = shift; printf STDERR "Fetch %s\n", $$self; return $$self; } sub STORE { my $self = shift; my $value = shift; printf STDERR "Store %s\n", $value; $$self = $value; } sub DESTROY { my $self = shift; printf STDERR "The End\n"; } } tie $_ => 'Report'; $\ = "\n"; $_ = 'outside'; foo(qw(one two three)); print; sub foo { local $_ = 'inside'; while(@_) { $_ = shift; print; } } #### The Start Store outside Fetch outside Store Store inside Store one Fetch one one Store two Fetch two two Store three Fetch three three Store outside Fetch outside outside The End #### local *_ = \undef; #### # The metrics_path is used to locate metrics files # use Config; my $path_sep = $Config{path_sep}; my $metrics_path = $ENV{METRICS} || join $path_sep, grep -d, '/usr/lib/afm', '/usr/local/lib/afm', '/usr/openwin/lib/fonts/afm/', '.', map "$_/Font/afm", @INC; $metrics_path =~ tr&\\&/& if $path_sep eq ';'; my @metrics_path = split(/$path_sep/, $metrics_path); foreach (@metrics_path) { s,/$,, } # remove trailing slashes #### --- C:\Documents and Settings\All Users\Documenten\Downloads\Font\AFM.pm Sun Dec 25 22:20:34 2005 +++ C:\PERL\site\lib\Font\AFM.pm Wed Jun 27 08:26:12 2001 @@ -192,10 +192,14 @@ # The metrics_path is used to locate metrics files # -my $metrics_path = $ENV{METRICS} || - "/usr/lib/afm:/usr/local/lib/afm:/usr/openwin/lib/fonts/afm/:."; -my @metrics_path = split(/:/, $metrics_path); -foreach (@metrics_path) { s,/$,, } # reove trailing slashes +use Config; +my $path_sep = $Config{path_sep}; +my $metrics_path = $ENV{METRICS} || join $path_sep, grep -d, + '/usr/lib/afm', '/usr/local/lib/afm', '/usr/openwin/lib/fonts/afm/', '.', + map "$_/Font/afm", @INC; +$metrics_path =~ tr&\\&/& if $path_sep eq ';'; +my @metrics_path = split(/$path_sep/, $metrics_path); +foreach (@metrics_path) { s,/$,, } # remove trailing slashes @ISOLatin1Encoding = qw( .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef @@ -253,7 +257,10 @@ } } } - open(AFM, $file) or croak "Can't find the AFM file for $fontname"; + open(AFM, $file) or do { + local $" = ':'; + croak "Can't find the AFM file for $fontname\nSearched in @metrics_path."; + }; my $self = bless { }, $class; local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR while () { #### package HexDump; $VERSION = "0.12"; use Exporter; @ISA = 'Exporter'; @EXPORT = 'hexdump'; use Encode(); sub hexdump { use bytes; my $length; my %opt = ( -offset => 0 ); if(ref $_[0] eq 'HASH') { my $opts = shift; @opt{keys %$opts} = values %$opts; } foreach(@_) { $length += length; } my $digits = length $length; my $format = " %${digits}d %1s %-47s %-16s\n"; my $offset = $opt{-offset}; while(@_) { local $_ = shift; my $is_utf8 = Encode::is_utf8($_); my $i = 0; { (my $clean = my $cut = substr($_, $i, CHUNKLENGTH)) =~ tr/\0-\37\177/./; printf $format, $offset + $i, $is_utf8 ? '*': '', join(" ", unpack('H*', $cut) =~ /../g), $clean; redo if ($i += CHUNKLENGTH) < length; } $offset += length; } } 1;