#! 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;