bart's scratchpad

Public Scratchpad

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";
    }
}
[download]

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)
[download]

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";
[download]

Note: āăą 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 },
};
[download]

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%       
+--
[download]

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' } @$_;
}
[download]

Output:

YYYNY
1    foo    one    1
3    baz    three    3
4    bar    replaces    NULL
[download]

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>
[download]

output:

Syntax error on line 33 of /etc/apache2/listen.conf:
syntax error at /etc/apache2/listen.conf line 36, near "perl>"\n
[download]

(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>
[download]

Result:

first block at /etc/apache2/listen.conf line 33.
second block at /etc/apache2/listen.conf line 39.
Syntax OK
[download]

-->

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:
[download]

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;
}
[download]

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: "";
}
[download]

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 "";
}
[download]

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;
[download]