Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

ChemBoy's scratchpad

by ChemBoy (Priest)
on Jun 01, 2004 at 19:33 UTC ( [id://358458]=scratchpad: print w/replies, xml ) Need Help??
Public ScratchpadDownload, 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

[download]

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)

[download]

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;

[download]

SimpleCase.pm

package SimpleCase;

our @ISA; # not explicitly set

sub new {
    return "This is a very simple case";
}

1;

[download]

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

[download]

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

[download]

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

[download]

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

[download]

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('&')
}

[download]

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)

[download]

Fun with HTML::TEmplate

<table>
<TMPL_LOOP name=ROWS>
  <TR><TD><TMPL_VAR name=key></td><td><TMPL_VAR name=value></td</tr>
</TMPL_LOOP>
</table>

[download]
Then... 
$tmpl->param(ROWS =>
  [ map +{key =>$_, value => $data{$_} }, keys %data ]
)

[download]

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

[download]

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{$_}++;
    }
  }
}

[download]

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')
+;
}

[download]

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;

[download]

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

[download]

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
+)

[download]

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.

[download]

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

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

[download]

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)

[download]

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)

[download]

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>
           &nbsp;&nbsp;&nbsp;&nbsp;--Michael Flanders</i></p>

[download]

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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others pondering the Monastery: (3)
As of 2025-01-24 18:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Which URL do you most often use to access this site?












    Results (68 votes). Check out past polls.