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

bart's scratchpad

by bart (Canon)
on Jun 01, 2004 at 13:11 UTC ( #358025=scratchpad: print w/ replies, xml ) Need Help??

The problem with a tied $_

local $_; doesn't break a tie of $_. Code:
#! 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"; } }
Result, on 5.12.2:
> "perl" test.pl Use of uninitialized value $value in concatenation (.) or string at te +st.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)

Simplifying a regex charclass and convert to Javascript escape notation

Save the script as UTF8, or you'll lose characters, or get invalid results.
#! 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 Unicod +e no warnings; if(chr($ord) =~ /[גדהו&#257;&#259;&#261;בא]/) { 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";
Note: &#257;&#259;&#261; is actually "āăą"

Result: /[\u00e0-\u00e5\u0101\u0103\u0105]/

Suppressing warnings on unclean conversion from string to number

Converting a string like "123 foo" to a number 123 takes time. How much time?
#! 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 }, };

Benchmark results:

Rate capture local suppress lexical substr cle +an capture 195157/s -- -25% -73% -86% -88% -9 +2% local 261057/s 34% -- -64% -81% -84% -8 +9% suppress 721504/s 270% 176% -- -47% -57% -7 +0% lexical 1371744/s 603% 425% 90% -- -18% -4 +3% substr 1679632/s 761% 543% 133% 22% -- -3 +1% clean 2427737/s 1144% 830% 236% 77% 45% +--

What does insert or replace on SQLite do?

Let's test:
use DBIx::Simple; unlink 'testdb.sqlite'; # drop the database file my $db = DBIx::Simple->connect('dbi:SQLite:testdb.sqlite'); # recreat +e 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' } @$_; }

Output:

YYYNY 1 foo one 1 3 baz three 3 4 bar replaces NULL

so a plain INSERT in 4 fails due to a unique key violation (name = 'foo'), but the "insert or replace" actually drops the row with name = 'bar' before inserting a new row:

  • The id is now 4 instead of 2, so all data in other tables link to this row loses its link
  • Any values you didn't set get set to the default value for INSERT, here a NULL

Bummer. I can't say this is very useful.

But at least, a failed insert doesn't needlessly increment the autoincrement counter for id.


Apache 2 troubles

The next piece in an Apache *.conf file produces a parsing error:
<perl> warn "first block"; </perl> <perl> warn "second block"; </perl>

output:

Syntax error on line 33 of /etc/apache2/listen.conf: syntax error at /etc/apache2/listen.conf line 36, near "perl>"\n
(line 33 is the line of the first warning; line 36 is the line of the second "<perl>")

And meanwhile, the following abomination works:

<perl> warn "first block"; " </perl> <perl> # "; warn "second block"; </perl>
Result:
first block at /etc/apache2/listen.conf line 33. second block at /etc/apache2/listen.conf line 39. Syntax OK

-->

Little script for Windows, to parse `net use`

and even reconnect to a particular drive letter, if connection is broken

The good thing about using net use to reconnect, as opposed to Windows API calls, is that nowhere you have to store or type in the password. Somewhere, Windows remembers it, and it uses that directly.

Example command line:

perl reconnect.pl G: H:
If no parameters are given, tries to reconnect to all drive letters.
#! 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 usin +g 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; }

CSS for Perlmonks, to ignore user Kevin_Raymer

.chatfrom_599759:after { content:" ..."; } .chatfrom_599759 .content { display:none; } span.chatfrom_599759:hover .content { display:inline; } span.chatfrom_599759:hover:after { content: ""; }

and here is Perl code, to generate that CSS, to ignore multiple users! (Including me, heh :))

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

hexdump routine: module HexDump.pm

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;
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 studying the Monastery: (11)
As of 2014-10-20 09:55 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (75 votes), past polls