| Public Scratchpad | Download, Select Code To D/L |
[Tue Mar 27 11:33:03 2007] testcore.cgi: install_driver(Oracle) failed +: Can't load '/usr/people/chemboy/lib/perl5/site_perl/5.8.1/i586-linu +x-thread-multi/auto/DBD/Oracle/Oracle.so' for module DBD::Oracle: lib +clntsh.so.9.0: cannot open shared object file: No such file or direct +ory at /usr/lib/perl5/5.8.1/i586-linux-thread-multi/DynaLoader.pm lin +e 229. [Tue Mar 27 11:33:03 2007] testcore.cgi: at (eval 27) line 3 [Tue Mar 27 11:33:03 2007] testcore.cgi: Compilation failed in require + at (eval 27) line 3. [Tue Mar 27 11:33:03 2007] testcore.cgi: Perhaps a required shared lib +rary or dll isn't installed where expected
Oracle Fun
merge into some_table OLD using ( select ? "A", ? "B", ? "C", ? "D" from dual ) NEW on (OLD.A = NEW.A and OLD.B = NEW.B) when matched then update set calc_date = sysdate, C = NEW.C, D = NEW.D when not matched then insert(A,B,C,D,calc_date) values(NEW.A,NEW.B,NEW.C,NEW.D,sysdate)
Segfaults?
At this point, this only segfaults on 5.8.1 on Linux (2.4.21-303-smp4G). I've had versions of it that segfault on 5.6.1 on Linux, but I'm curiously unable to get that to happen at the moment (at one point, it segfaulted on 5.6.1 on one Linux but not another, which annoyed the heck out of me). On 5.6.1 on SGI/Irix, I haven't been able to get segfaults at all.
AutoRequire.pm
package AutoRequire; use 5.006; use strict; no strict 'refs'; use warnings; our $VERSION = substr q$Revision: 1.0$, 9; my %loadable; our $AUTOLOAD; sub import { my $self = shift; foreach (@_) { my $PACKAGE = $_; $DB::single=1; (my $pfile = "$PACKAGE.pm") =~ s#::#/#g; $loadable{$PACKAGE} = 1; my $full_auto = $PACKAGE . "::AUTOLOAD"; *{$full_auto} = sub { my $subname = $AUTOLOAD; my ($pkg,$sub) = $AUTOLOAD =~ / ^ ( \w+ (?: :: \w+)* ) :: ( \w+ ) \z /x; if ( delete $loadable{$PACKAGE} ) { require $pfile; # commenting out this line removes the segfault delete ${$PACKAGE."::"}{AUTOLOAD}; if ($PACKAGE eq $pkg) { print STDERR "This is the branch we execute\n"; goto &$subname; } } } } } 1;
SimpleCase.pm
package SimpleCase; our @ISA; # not explicitly set sub new { return "This is a very simple case"; } 1;
bug.pl
#!/usr/local/bin/perl use lib '.'; use AutoRequire 'SimpleCase'; print STDERR "Still alive...\n"; my $var = SimpleCase->new; print STDERR "We never get here\n";
DBI fun
sub findMagicname { my @userids = @_; my ($sth, $dbh,@ret); $dbh=DBI->connect_cached('DBI:ODBC:CHDDB', 'someid', 'somepass', {Ra +iseError =>1, PrintError =>0, ShowErrorStatement =>0}); $sth = $dbh->prepare_cached( "SELECT [Last Name] AS Last, [First Nam +e] AS First FROM _SMDBA_.[Support Staff] WHERE [Login ID]=?",{ChopBla +nks=>1} ); foreach my $userid (@userids) { $sth->execute($userid); my $row = $sth->fetchrow_hashref; push @ret, "$row->{First} $row->{Last}"; $sth->finish(); } wantarray ? @ret : $ret[0] } sub findMagicname { my @userids = @_; my ($sth, $dbh); #$userid = "l373l8"; $dbh=DBI->connect_cached('DBI:ODBC:CHDDB', 'someid', 'somepass', {Ra +iseError =>1, PrintError =>0, ShowErrorStatement =>0}); $sth = $dbh->prepare_cached( "SELECT [Last Name] AS Last, [First Nam +e] AS First FROM _SMDBA_.[Support Staff] WHERE [Login ID]=?", {'ChopB +lanks' => 1 } ); $sth->execute($userid); $sth->; #----Removes extra spaces from fixed char fields. See netToo +ls_help.doc. my $row = $sth->fetchrow_hashref; $sth->finish(); return $row->{First}. " " .$row->{Last}; }
Shared?
Purpose: produce a constructor that maintains a 1:1 mapping between one argument ("ID", usually) and objects returned, then falls back on a superclass to do the actual construction work.
install_unique_constructor($new_child_class,"id"); sub install_unique_constructor { no strict 'refs'; my ($unique,$class) = @_; $class ||= caller; my %singleton; eval "package $class;" . q| sub new { my $class = shift; # this behavior should be consistent: my %args = 1 == @_ ? (id=>@_) : @_; my $key = $args{$unique}; my $self = $singleton{$key}; unless ( $self ) { $self = $class->SUPER::new(@_); $singleton{$key} = $self; } return $self; }; 1; |; }
This raises "will not stay shared" errors on $unique and %singleton.
inside-out accessor/mutator generator
sub scalar_install { no strict 'refs'; my ($class,$field) = @_; my %closed; *{$class . "::$field" } = sub { my $self = shift; if (@_) { $closed{$self} = $_[0]; } else { $closed{$self} } }; 1; }
Javascript fun
function wwwEncodeObject(o) { var params = new Array(); for (var f in o) { var fieldname = escape(f).replace(/\+/g,'%2B'); var value = o[f]; switch(typeof(value)) { case 'string': case 'number': params.push(fieldname + "=" + escape(value).replace(/\+/g, +'%2B')); break; case 'boolean': params.push(fieldname + (value ? "=1" : "=")); break; case 'object': //Handle arrays logically. Other objects, die if(value.constructor != Array) throw("Can't handle non-Arr +ay objects"); for (var i = 0; i < value.length; i++) params.push(fieldname + "=" + escape(value[i]).replace +(/\+/g,'%2B')); } } return params.join('&') }
MySQL
mysql> select count(1) from foo where remote in (select remote from ba +r); +----------+ | count(1) | +----------+ | 5750 | +----------+ 1 row in set (0.30 sec) mysql> select count(1) from foo ; +----------+ | count(1) | +----------+ | 94587 | +----------+ 1 row in set (0.01 sec) mysql> select count(1) from foo where remote not in (select remote fro +m bar); +----------+ | count(1) | +----------+ | 56 | +----------+ 1 row in set (0.45 sec)
Fun with HTML::TEmplate
Then...<table> <TMPL_LOOP name=ROWS> <TR><TD><TMPL_VAR name=key></td><td><TMPL_VAR name=value></td</tr> </TMPL_LOOP> </table>
$tmpl->param(ROWS => [ map +{key =>$_, value => $data{$_} }, keys %data ] )
Autoload trickery
require subs; my @autogen = qw(Foo Bar Trope Cliche); foreach my $thing (@autogen) { my @subs = map "$_$thing", qw(High Low Middle); push @EXPORT_OK, @subs; subs->import(@subs); } sub AUTOLOAD { if ($AUTOLOAD =~ /@{[__PACKAGE__]}::(High|Low|Middle)(\w+)$/ and grep($2 eq $_, @autogen) ) { my $sub = $dispatch{$1}; my $thing = $2; *$AUTOLOAD = sub { $sub->(thing => $thing, args => [@_]) }; goto &$AUTOLOAD; } else { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } }
For review (I didn't write it! Honest!)
$query = $ENV{QUERY_STRING}; if (defined($query) && $query ne '') { foreach (split (/&/, $query)) { #change to /[&;]/, right? y/+/ /; s/%(..)/sprintf("%c", hex($1))/ge; # unquote %-quoted #change above to chr hex $1? if (/(\S+)=(.*)/) { # change \S to [^=], I'd say $input{$1} = $2 if ($2 ne ""); #and what if it is? } else { $input{$_}++; } } }
For Zaxo to poke:
while (<>) { push @input, lc =~ /[a-z]/g; while ( @input > 1 ) { my ($let1,$let2) = splice @input,0,2; if ($let2 eq $let1) { unshift @input, $let2; $let2 = ($let2 eq 'x') ? 'z': 'x'; } push @output, transcribe ($let1,$let2); } } if (@input) { push @output, transcribe ($input[0],($input[0] eq 'x') ? 'z': 'x') +; }
eeee!
The Module
package Crash; use 5.006; use strict; use warnings; use Carp; use overload '0+' => sub {$_[0]}, '""' => sub {my $self = shift; ref ($self).' => '.$self->getPK}, eq => sub { ref $_[1] eq ref $_[0] ? $_[0] == $_[1] : "$_[0]" eq " +$_[1]" }, fallback => 1; sub new {bless {}, __PACKAGE__} sub getPK {"Fred"} 1;
The debugging session
% perl -MCrash -de1 Default die handler restored. Loading DB routines from perl5db.pl version 1.07 Editor support available. Enter h or `h h' for help, or `man perldebug' for more help. main::(-e:1): 1 DB<1> $a = Crash->new DB<2> $b = Crash->new DB<3> s $a eq $b main::((eval 6)[/usr/local/lib/perl5/5.6.1/perl5db.pl:1521]:3): 3: $a eq $b; DB<<4>> s Crash::CODE(0x1021d1b8)(Crash.pm:11): 11: eq => sub { ref $_[1] eq ref $_[0] ? $_[0] == $_[1] : "$_[ +0]" eq "$_[1]" }, DB<<4>> x $_ Signal BUS at /usr/local/lib/perl5/5.6.1/perl5db.pl line 1399 DB::DB called at Crash.pm line 11 Crash::__ANON__[Crash.pm:11]('Crash => Fred', 'Crash => Fred', + '') called at (eval 6)[/usr/local/lib/perl5/5.6.1/perl5db.pl:1521] l +ine 3 eval '($@, $!, $^E, $,, $/, $\\, $^W) = @saved;package main; $ +^D = $^D | $DB::db_stop; $DB::single = 1; $a eq $b; ;' called at /usr/local/lib/perl5/5.6.1/perl5db.pl line 1521 DB::eval called at /usr/local/lib/perl5/5.6.1/perl5db.pl line +1399 DB::DB called at -e line 1 Abort
Linux connundrum
Expected startup message is something like this (cribbed from here):
tulip.c:v0.91 4/14/99 <EMAIL: PROTECTED> eth0: Digital DS21140 Tulip rev 18 at 0xd000, 00:00:C0:31:35:E4, IRQ 1 +2. eth0: Old format EEPROM on `SMC9332DST` board. Using substitute media + control info. eth0: EEPROM default media type Autosense. eth0: Index #0 - Media 10baseT (#0) described by a 21140 non-MII (0) +block. eth0: Index #1 - Media 100baseTx (#3) described by a 21140 non-MII (0 +)
But what I get is this:
Linux Tulip driver version 0.9.15-pre7 (Oct 2, 2001) PCI: Enabling device 00:0e.0 (0004->0007) tulip0: Old format EEPROM on 'Asante' board. Using substitute media co +ntrol info. eth0: Digital DS21140 Tulip rev 32 at 0xcb937000, <HWADDY SUPPRESSED>, + IRQ 24.
Vital stats:
Yellow Dog Linux 2.1
Kernel 2.4.10-12a
Asante Etherfast 10/100 card (I think).
Card is known to work with this hardware (PM 7300) under MacOS 7.5.5
DB<45> T $ = XML::ValidWriter::_self called from file `site_perl/XML/ValidWrite +r.pm' line 1232 $ = XML::ValidWriter::setDoctype(ref(XML::ValidWriter), ref(XML::Docty +pe)) called from file `site_perl/XML/ValidWriter.pm' line 518 $ = XML::ValidWriter::import('XML::ValidWriter', ':all', ':dtd_tags') +called from file `scratch/validwriter_fun' line 18
sub setDoctype { my XML::ValidWriter $self = &_self ; $self->{DOCTYPE} = shift if @_ ; return ; } sub _self { ## MUST be called as C< &_self ;> ## If it's a reference to anything but a plain old hash, then the ## first param is either an XML::ValidWriter, a reference to a glob ## a reference to a SCALAR, or a reference to an IO::Handle. return shift if ( @_ && ref $_[0] && isa( $_[0], 'XML::ValidWriter' + ) ) ; my $callpkg = caller(1) ; croak "No default XML::ValidWriter declared for package '$callpkg'" unless $pkg_writers{$callpkg} ; return $pkg_writers{$callpkg} ; }
Key:
- method 1
- Original setup
- method 2
- Using array access and testing only relevant elements
- method 3
- tye's table lookup scheme, testing all bytes
- method 4
- logical combination of 2 and 3.
On Irix (275 MHz R12000)
Benchmarks for method 1: total: 347 secs (315.12 usr 0.86 sys = 315.98 cpu) overhead: 0 secs ( 0.00 usr 0.00 sys = 0.00 cpu) loop: 347 secs (315.12 usr 0.86 sys = 315.98 cpu) Benchmarks for method 2: total: 178 secs (166.28 usr 0.65 sys = 166.93 cpu) overhead: 1 secs ( 0.17 usr 0.01 sys = 0.18 cpu) loop: 177 secs (166.11 usr 0.64 sys = 166.75 cpu) Benchmarks for method 3: total: 157 secs (148.77 usr 0.86 sys = 149.63 cpu) overhead: 31 secs (29.17 usr 0.36 sys = 29.53 cpu) loop: 126 secs (119.60 usr 0.50 sys = 120.10 cpu) Benchmarks for method 4: total: 95 secs (84.78 usr 0.57 sys = 85.35 cpu) overhead: 14 secs (13.68 usr 0.16 sys = 13.84 cpu) loop: 81 secs (71.10 usr 0.41 sys = 71.51 cpu)
On Linux (1GHz PIII)
Benchmarks for method 1: total: 64 wallclock secs (60.37 usr + 1.82 sys = 62.19 CPU) overhead: 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU) loop: 64 wallclock secs (60.37 usr + 1.82 sys = 62.19 CPU) Benchmarks for method 2: total: 45 wallclock secs (42.75 usr + 1.36 sys = 44.11 CPU) overhead: 0 wallclock secs ( 0.05 usr + 0.00 sys = 0.05 CPU) loop: 45 wallclock secs (42.70 usr + 1.36 sys = 44.06 CPU) Benchmarks for method 3: total: 56 wallclock secs (53.67 usr + 1.16 sys = 54.83 CPU) overhead: 17 wallclock secs (16.56 usr + 0.05 sys = 16.61 CPU) loop: 39 wallclock secs (37.11 usr + 1.11 sys = 38.22 CPU) Benchmarks for method 4: total: 35 wallclock secs (32.78 usr + 1.33 sys = 34.11 CPU) overhead: 8 wallclock secs ( 7.74 usr + 0.01 sys = 7.75 CPU) loop: 27 wallclock secs (25.04 usr + 1.32 sys = 26.36 CPU)
ChemBoy's bug-inducing sig:
<p><br><hr><i>If God had meant us to fly, he would *never* have given +us the railroads.<br> --Michael Flanders</i></p>
Refs for mr_mischief
- For the President's Eyes Only, Christopher Andrew
- A nice general survey of U.S. Intelligence operations--mostly 20th Century, but with a chapter on the previous bits as well.
- Inside the CIA's Private World, H. Bradford Westerfield (editor).
- An entirely different beast: selected articles from the CIA in-house journal, sanitized as necessary. A very interesting read.
- The Spy who Saved the World, Jerrold Schecter and Peter Deriabin.
- Biographical work about Oleg Penkovskiy. Also quite good, but much more focused (obviously) on a particular period of only a few years.