jZed's scratchpad

Public Scratchpad

Web Host woes

me   : I have accounts A and B, I want a third account C
them : ok, we added C and deleted B
me   : no, I need B
them : ok, we restored B and deleted A
me   : no, I need A
them : ok, we restored A but not A's ability to edit files
me   : no, A needs to be able to edit files
them : ok, we restored A's ability to edit all files except  those starting with a dot like .htaccess
me   : nevermind, I'll change that myself.

My Mason apache.conf

  PerlModule HTML::Mason::ApacheHandler
  <Location /~jeff/mason>
    PerlSetVar   MasonCompRoot  /home/jeff/public_html/mason
    SetHandler   perl-script
    PerlHandler  HTML::Mason::ApacheHandler
  </Location>
[download]

For hacker

my %uri = (
    dl      => 'http://www.plkr.org/download',
    snaps   => 'http://www.plkr.org/developers/snapshots',
    tools   => 'http://www.plkr.org/developers/tools',
    history => 'http://www.plkr.org/about',
    irc     => 'http://www.plkr.org/users/chat',
);

my $wanted_uri = $uri{$apr->param('a')||''};
if( $wanted_uri ){
    print $apr->redirect(
        -status => 301,
        -uri    => $wanted_uri
    ); 
    exit;
}
[download]

For bhorton63

#!/usr/bin/perl
use warnings;
use strict;
use DBI;
my $dbh=DBI->connect('dbi:CSV:',undef,undef,{RaiseError=>1});
$dbh->do($_) for(
    "DROP TABLE IF EXISTS updateTest",
    "CREATE TABLE updateTest (phrase TEXT)",
    "INSERT INTO updateTest (phrase) VALUES('old')"
);
my($old) = $dbh->selectrow_array("
    SELECT phrase FROM updateTest
");
$dbh->do("
    UPDATE updateTest SET phrase=? WHERE phrase=?
",{},'new','old');
my($new) = $dbh->selectrow_array("
    SELECT phrase FROM updateTest
");
print "OLD: $old\nNEW: $new\n";
$dbh->do("
    DROP TABLE updateTest
");
$dbh->disconnect;
__END__
[download]

For hacker

# PREPARE ONLY ONCE, NOT EVERYTIME THROUGH THE LOOP
my $word = $dbh->prepare(qq{SELECT term from dream_terms where term=?}
+);

sub link_lookup {
    my $lookup_word = shift;
    $word->execute($lookup_word);
    # YOU ONLY WANT ONE ROW, SO JUST FETCH ONE ROW
    # YOU ARE ONLY FETCHING ONE COLUMN SO JUST FETCH IT, DON"T BIND IT
    my($found_it) = $sth->fetchrow_array;
    # CHECK IF YOU FOUND SOMETHING BEFORE TRYING TO lcfirst NOTHING
    if ($found_it and $lookup_word eq lcfirst($found_it)) {
            print "FOUND A MATCH!<br />";
            $linked_word = qq{
        <a href="#$success_fail"> $lookup_word </a><br />
             };
    }
    else {
            print "YOU ARE HERE<br />";
            $linked_word = $lookup_word;
    }
    $word->finish;
    return $linked_word;
}
[download]

For perllove

#!/usr/bin/perl
use warnings;
use strict;
use CGI;
my $tail = qx(tail mvc.txt);
print CGI::header(), qq{
<html>
    <head>
        <meta http-equiv="refresh" content="24" />
    </head>
    <body>
        <pre>$tail</pre>
    </body>
</html>
}
[download]

For Bart

<script>
var foo = { a:1
          , b:2
          , c:3
          };
alert( foo['b'] );
</script>
[download]

CSS Quiz

What color is bar?

<style>
#foo #bar { color:red;   }
#bar      { color:green; }
</style>
<div id="foo">
    <div id="bar">bar</div>
</div>
[download]

For grant123

#!/usr/bin/perl
use warnings;
use strict;

print match("one two three","four five six");
print match("one two three","four onefive six");
print match("one two three","three five six");

sub match {
    my @left  = split /\s+/, $_[0];
    my @right = split /\s+/, $_[1];
    return
      ( join( ',', ',', @left, ',' ) =~
        /,(${\join'|',map quotemeta $_, @right}),/
      )
      ? 1
      : 0;
}
[download]

A simple Mason server

#!/usr/bin/perl
use strict;
use HTML::Mason;
use CGI;
use CGI::Carp qw(fatalsToBrowser);

my $cgi = CGI->new();
my $fn  = ( $cgi->param('fn') || 'list/list_items' ) . '.mas';
open(IN,"<",$fn) or die $!;
my $templateStr  = join '',<IN>;
close IN;

my $interpreter  = HTML::Mason::Interp->new( );
my $component    = $interpreter->make_component(comp_source=>$template
+Str);
my %args         = $cgi->Vars;

print $cgi->header();
$interpreter->exec($component,%args);
[download]

For farhan

my $in_file = "bill";
my $out_file = "far2";
open IF, "$in_file" or die $!;
open OF, ">$out_file" or die $!;
while(<IF>) {
    chomp;
    print OF $_;
    if($. == 4012) {
        print OF "... test"; 
    } 
    print OF "\n"; 
} 
print "Done\n";
close(IF);
close(OF);
[download]

CGI.pm sticky forms

#!/usr/bin/perl -w
use strict;
use CGI;
my $q = CGI->new;
print $q->header,
    , $q->start_form(-action=>$q->url)
    , $q->textfield(-name=>'foo')
    , $q->submit
    , $q->end_form
;
print "You entered :" . $q->param('foo') if $q->param;
[download]

Inheritance in JavaScript

<script src="/js/prototype.js"></script>
<script src="/js/extend.js"></script>
<script>
var myBaseClass = Class.create({
    initialize : function( seed ) { this.seed = seed },
    show       : function() { alert( this.seed ) }
});
var myInheritedClass = myBaseClass.extend({
    show : function() { this.seed += 5; this.SUPER() }
});

myInstance = new myBaseClass(6);
myInstance.show();          // result = 6

myInheritedInstance = new myInheritedClass(6);
myInheritedInstance.show(); // result = 11
</script>
[download]

DBD::CSV addition function

$dbh->do("CREATE FUNCTION MyAdd");
sub MyAdd {
    my($self,$sth,$rowhash,@params)=@_;
    my $sum;
    $sum += $_ for @params;
    return $sum
}
my $sth = $dbh->prepare("
    SELECT myAdd(id,9) AS foo FROM test
");
[download]

SQL::Translator - trying to get column defs in a structure

The code below produces:"ERROR (line 1): Invalid statement: Was expecting create, or comment on ..."

#!perl -w
use strict;
use SQL::Translator;
use SQL::Translator::Schema;
use SQL::Translator::Parser::PostgreSQL;
use Data::Dumper;

my $sql = "CREATE TABLE foo (id INT PRIMARY KEY,bar VARCHAR(30)";
my $translator = SQL::Translator->new;
SQL::Translator::Parser::PostgreSQL::parse($translator,$sql);
[download]

Text::CSV_XS for demerphq

#!perl -w
use strict;
use Text::CSV_XS;
use IO::File;
my $csv = Text::CSV_XS->new( {binary=>1} );
my $fh  = IO::File->new('tmp.csv');
while (my $cols = $csv->getline($fh)) {
    last unless @$cols;
    printf "%s\n", join ':',@$cols;
}
[download]

utf-8

#!perl -w
use strict;
require IO::Scalar;
use Text::CSV_XS;
use encoding 'utf-8';
my $csv = Text::CSV_XS->new( {binary=>1} );
my $fh  = new IO::Scalar;
use Test::More tests => 4;

my $old  = "\x{263A}";
$fh->open(\$old);
my $cols = $csv->getline($fh);
my $new  = $cols->[0];
ok($old eq $new,'$old eq $new');
ok($old =~ /$new/,'$old =~ /$new/');
ok($old =~ /\Q$new/,'$old =~ /\Q$new/');
ok($new =~ /$old/,'$new =~ /$old/');
ok($new =~ /\Q$old/,'$new =~ /\Q$old/');
[download]

SELECT foo, bar
  FROM baz JOIN qux
 WHERE quimble = ?
   AND bop = ?
[download]

MCB Bookmarks.html

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
    <title>MCB Bookmarks</title>
    <base target="main">
    <link rel="stylesheet" href="mcb.css" type="text/css">
</head>
<body>
<a href="http://www.perlmonks.org/?node=Newest%20Nodes">Newest Nodes</
+a><br />
<a href="http://www.perlmonks.org/?node=Recently%20Active%20Threads">R
+ecently Active Threads</a><br />
<a href="http://www.perlmonks.org/?node_id=358896">View Scratchpad</a>
+<br />

<a href="http://www.perlmonks.org/?displaytype=edit;node_id=358896">Ed
+it Scratchpad</a><br />
<a href="http://tinymicros.com/pm/">PM Stats</a><br />
<a href="http://www.perlmonk.org/~mojotoad/cbs/">CB Stats</a><br />
<a href="http://www.perlmonks.org/?displaytype=raw;xmlstyle=clean;node
+=XP XML Ticker">XP</a><br />
</body>
</html>
[download]

DB Contractor Questions - For Limbic~Region

I usually start from the big picture and work down:

  What domain of information is the database about?
  (teaching assignments)

  What reports do you want to generate from the db?
  (list subjects taught by prof X)
  (list profs who teach subject Y)
  (list all profs and for each list all subjects they teach)

  Are there other reports you might want in the future?
 
  Based on the above, key entites are prof and subject.
  are there any other relevant entities?

  What is the relation between the entities
  (each prof can teach many subjects, 

   each subject can be taught by many profs)

  Any other potential relations?

  What are the attributes for each entity?
  (each prof has a name, each subject has a title)

  Any other potential attributes?

  Which attributes uniquely identify each entity?
  (none, we have two profs named "Joe Clark")

  Are the unique attributes guaranteed to be unique?
  (nope)

  Shall we use arbitrary unique identifiers?
  (please do)

  Based on what you've said so far, your database
  should be composed of three tables with the 
  structure indicated below, does that sound right?
  +-------+       +--------+       +---------+
  | prof  |       | lookup |       | subject |
  +-------+       +--------+       +---------+
  | *pid  | <-->> | *pid   |       | stitle  |
  | pname |       | *sid   | <<--> | *sid    |
  +-------+       +--------+       +---------+

  If not, find out why not and refactor.

  Continue with more specific questions about field
  definitions for each table, etc. ....

STDIN issues

This works


% cat > dbish.txt
    /format box
    DROP TABLE IF EXISTS x;
    CREATE TABLE x (num INT, let CHAR);
    INSERT INTO x VALUES (1,'a');
    INSERT INTO x VALUES (2,'b');
    SELECT * FROM x;
% perl -MDBI::Shell -e 'DBI::Shell->new("--batch","dbi:DBM:")->run' < 
+dbish.txt;
[download]

This doesn't:

#!/usr/bin/perl -w
use strict;
use DBI::Shell;
my $str="   /format box
    DROP TABLE IF EXISTS x;
    CREATE TABLE x (num INT, let CHAR);
    INSERT INTO x VALUES (1,'a');
    INSERT INTO x VALUES (2,'b');
    SELECT * FROM x;
";
open STDIN, '<', \$str;
DBI::Shell->new('--batch','dbi:DBM:')->run;
[download]

dual boot problems

I have a winXP system, I installed debian sarge on a partition with Lilo in th e MBR. It boots straight to Linux with no menu and I can't boot to winXP at all. Here's the relevant parts of /etc/lilo.conf.

boot=/dev/sda    # the raw device (i.e. lilo in mbr)
root=/dev/sda5   # the linux partition
install=menu     # we want a menu
other=/dev/sda2  # the winXP c:\ partition

Text::CSV_XS proposed new methods

 use Text::CSV_XS;
 $c = Text::CSV_XS->new;              # use default separator,delimite
+r,escape
 or $c = Text::CSV_XS->new(%attr);    # set your own separators,delims
+,escapes

 $c->open_file($filename)             # open a CSV file
 $c->open_string($string)             # open a CSV string

 @row   = $c->fetchrow_array           # fetch one row into an array
 $row   = $c->fetchrow_hashref         # fetch one row into a hashref
 $table = $c->fetchall_arrayref        # fetch all rows into an array 
+of arrays
 $table = $c->fetchall_hashref($key)   # fetch all rows into a hashref

 $c->write_row( @array )               # insert a row from an array of
+ values
 $c->write_table($filename,$arrayref)  # create a CSV file from  an ar
+rayref
 $c->write_table($filename,$hashref)   # create a CSV file from a hash
+ref


 $c = open_file( $filename );          # loop through a file fetching 
+hashrefs
 while(my $row = $c->fetchrow_hashref){
    if($row->{$column_name} eq $value){
        # do something
    }
 }

There are two interfaces to this module, the new interface (shown abov
+e) has convenient shortcuts, the older interface is for backwards com
+patibility for previous users.  B<Please note>: in the new interface 
+binary mode defaults to true, whereas in the older interface it defau
+lts to false.  This means that the new interface methods will, by def
+ault, handle embedded newlines and binary characters, whereas if you 
+want that behaviour with the old methods, you must manually set binar
+y=>1 in the call to new().
[download]

Text::CSV_XS change for escape_char

The char used for escaping certain characters inside quoted fields,
by default the same character as the quote_char. (C<">).

If quote_char is specified in the call to new() and escape_char is not
+,
the escape_char becomes the same as the specified quote_char.  A liter
+al
value for the quote character thus becomes "" if quote_char is " and '
+' if
quote_char is ' and just " or ' if quote_char is specified as undef.  
+However 
if the escape_char is specified in the call to new() as something else
+, 
that value will be used.

These examples should all parse properly as a single CSV field:

 $csv = Text::CSV_XS->new();
 $csv->parse(q["Joe ""the giant"" Jackson"])  or die $csv->error_input
+;

 $csv = Text::CSV_XS->new({ quote_char=>q['] });
 $csv->parse(q['Joe ''the giant'' Jackson']) or die $csv->error_input;


 $csv=Text::CSV_XS->new({quote_char=>undef});
 $csv->parse(q[17" monitor]) or die $csv->error_input;

 $csv = Text::CSV_XS->new({ quote_char=>q['], escape_char=>q[\\]});
 $csv->parse(q['Joe \'the giant\' Jackson']) or die $csv->error_input;

 $csv = Text::CSV_XS->new({ escape_char => q[\\]  });
 $csv->parse(q["Joe \"the giant\" Jackson"]) or die $csv->error_input;
[download]

Text::xSV

#!perl -w
use strict;
use Text::xSV;
my($cols,$data) = ( ['Name','City','Num'], [] );
for my $num(0..4999) {
    push @$data, ["myself\nme","Portland,Oregon",$num];
}
create_xSV('test.xSV',$cols,$data);
read_xSV('test.xSV');

sub create_xSV {
    my($fname,$cols,$data) = @_;
    my $csv = Text::xSV->new( filename => $fname
                            , header   => $cols
                            );
    $csv->print_header();
    $csv->print_row(@$_) for @$data;
}
sub read_xSV {
    my $fname = shift;
    my $csv = Text::xSV->new( filename=>$fname, close_fh=>1);
    $csv->read_header();
    my $count=0;
    while ($csv->get_row()) {
        print "$count ...";
        my @row = $csv->extract(qw(Name City Num));
        die 'Bad Read' unless "@row" eq "@{$data->[$count++]}";
    }
    print "Done!";
}
__END__
[download]

Tree structure with theorbtwo's Require Finder

#!/usr/bin/perl -w
use strict;
use vars qw/ $mods $files %ismod/;
use FindRequires;
use DBI;
my $dbh=DBI->connect('dbi:DBM(RaiseError=1):');
recurse($mods->[0],'');
sub recurse {
    my($mod,$insert)=@_;
    return unless $mod;
    print "$insert$mod\n";
    $insert .= '   ';
    for my $modfile(@{$files->{$mod}}) {
        recurse($modfile,$insert);
    }
}

package FindRequires;
# by [theorbtwo]
use warnings;
use strict;
my $reallibimport;

use lib;
BEGIN {
    $reallibimport = \&lib::import;
}

{
    no warnings 'redefine';
    sub lib::import {
        $reallibimport->(@_);
       ($INC[0], $INC[1]) = ($INC[1], $INC[0]);
    }
}
unshift @INC, sub {
    my ($self, $lookingfor) = @_;

    # != works if it is OK, but if it's not, this is probably a string
+.
    # Use ne to avoid warning, even though we're about to die.
    if ($INC[0] ne $self) {
        die "\@INC got messed up";
    }

    #  return if $lookingfor =~ /\.al$/;
    if ($lookingfor =~ /\.pm$/) {
        $lookingfor =~ s![:/]!::!g;
        $lookingfor =~ s/\.pm$//;
    }

    my ($filename, $line,@mods);
    my $level=0;
    while (1) {
        (undef, $filename, $line) = caller($level);
        last unless $filename =~ /^\(eval/;
        $level++;
    }
    my $modfile = $filename;
    for my $i(@INC) {
        $modfile =~ s!$i!!;
    }
    if ($modfile =~ /\.pm$/) {
        $modfile =~ s![:/]!::!g;
        $modfile =~ s/\.pm$//;
    }
    push @{$main::mods}, $modfile unless $main::ismod{$modfile}++;
    push @{ $main::files->{$modfile} }, $lookingfor;
    # print "$lookingfor required at line $line of [$modfile] $filenam
+e\n";
};
1;
[download]

Using DBD::AnyData to access an AoA with SQL

#!perl -w
use strict;
use DBI;
my $AoA = [ [qw(1 Hacker)]
          , [qw(2 Perl)]
          , [qw(3 Another)]
          , [qw(4 Just)]
          , [qw(5 junk)]
          ];
my $dbh=DBI->connect('dbi:AnyData(RaiseError=1):');
$dbh->ad_catalog('t','ARRAY',$AoA,{cols=>'id,phrase'});
print join ' ', @{ $dbh->selectcol_arrayref("
    SELECT phrase FROM t WHERE phrase <> 'junk' ORDER BY id DESC
")};
[download]

ChatterBox WhiteBoard: A communal scratchpad

updated 2004-09-24: brand new versioning per tye's suggestions, click the help button in the demo to read how it works

The scenario: Someone in the chatterbox posts a snippet in the communal scratchpad ... other monks edit the communal scratchpad. This would be a sort of primitive whiteboard, a one-page wiki, where monks could collaboratively work on a problem they were discussing in the chatterbox. It wouldn't be too useful for simple things like someone asking for help spotting a typo in a snippet but could be productive for exploring TIMTOWTDI and for group-developing solutions to problems.

Please give the demo a try!

My Mandatory Registration Complaint Letter

Mandatory registration is a terrible idea. It violates my privacy (I don't care what you do or don't use your database for, I don't want to be in it); it exposes me to spam and identity theft (yes, maybe your database is protected, but if every content site on the web starts using mandatory registration, one of them won't be); it's worthless since anyone can submit fake info (yes I could do that too, but frankly I don't want to).

I used to visit ___ daily. Never again though.

my current hardware

    other remote computers
             |
        cable modem
             |
        wap/nat/router -- wifi -- other local computers
       /           \
      /             \
 cat5 cable         wifi
    /                 \
Computer #1          Computer #2
   |     \               /
   |      VGA/USB    VGA/USB
   |          \        / 
   |          KVM Switch
   |         /    |     \
   |        /  PS2->USB  \
   |       /      |       \
  DVI    VGA     PS2      USB
    \    /        |        |
    Monitor   Keyboard   Mouse
            \     |     /
             \    |    /
          zone of error (me)
                  |
               my chair

Questions for the Debian/VMware cluefull:

I am getting a new Dell 3.2gHz pentium 4 with 1gig memory, 250gig storage, WinXP professional installed. I'd like to:

add Debian + VMware.
mostly use Debian but have WinXP available when I need it without dual boot
access my data files from either OS.
share some of my data files with other Win boxen on my home WiFi network

I'd appreciate any thoughts on

installation - is this what I need to do?
1. backup winXP
2. reformat the hard drive, install Debian
3. install VMware
4. reinstall winXP as a guest OS
setup - any thoughts on partition/directory structure/size - if I create the directories in Win I can mount them from linux but if I create them in linux, how do I access them from Win?
anything else I should think about?

Thanks!

DBM::Deep

use DBM::Deep;
my $file ='foo.db';
unlink $file if -e $file;
my %h;
tie %h, 'DBM::Deep', {file=>$file,autoflush=>1};
$h{key} = 'value';
untie %h;
tie %h, 'DBM::Deep', {file=>$file,autoflush=>1};
print $h{key};
[download]

A Generic Inside-Out Wrapper

#!perl -w
use strict;

#
#  put any object inside a wrapper
#  access the object directly
#  and store variables privately in the wrapper
#
#  my $obj = InsideOutWrapper->new(
#      $module, $wrapper_args, @module_args
#  );
#

my $cgi = InsideOutWrapper->new('CGI');
my $lwp = InsideOutWrapper->new('LWP::UserAgent');

$cgi->param( 'foo'=> 5 );  # store in the CGI object
$lwp->agent(         6 );  # store in the LWP::UA object
$cgi->iow('bar'=>7 );      # store in the CGI Wrapper
$lwp->iow('baz'=>8 );      # store in the LWP::UA Wrapper

print "ok!\n" if '5678' eq join '' # retrieve the values
    , $cgi->param('foo')
    , $lwp->agent
    , $cgi->iow('bar')
    , $lwp->iow('baz')
    ;

# check lists of all the private keys
#
print "ok!\n" if 'bar' eq join( '', $cgi->iow )
             and 'baz' eq join( '', $lwp->iow );
exit;

package InsideOutWrapper;
use warnings;
use strict;
my %built;
sub new {
    my($wrapper_class,$other_class,$wrapper_args,@other_args)=@_;
    my $class = $wrapper_class . '::' . $other_class;
    if (!$built{$class}++) {
        my $class_txt = get_class_txt();
        $class_txt =~ s/__WRAPPER__/$class/g;
        $class_txt =~ s/__MOD__/$other_class/g;
        eval $class_txt;
        die $@ if $@;
    }
    return $class->new($wrapper_args,@other_args);
}

sub get_class_txt { return <<'';
package __WRAPPER__;
use strict;
use warnings;
use vars qw( $vars );
use base '__MOD__';
sub new {
    my($class,$wrapper_args,@other_args)=@_;
    my $obj = bless __MOD__->new(@other_args), $class;
    $vars->{$obj} = $wrapper_args;
    $obj;
}
sub iow {
    my($self,$key,$val)=@_;
    return keys %{ $vars->{$self} } unless defined $key;
    return $vars->{$self}->{$key} unless (defined $val);
    $vars->{$self}->{$key} = $val;
}
sub DESTROY {
    my $self = shift;
    delete $vars->{$self};
}

}
1;
__END__
[download]

Re: Tutorial: Introduction to Object-Oriented Programming

Domain Nodelet^?

www.com | www.net | www.org

Chatterbox^?

How do I use this? • Last hour • Other CB clients

Other Users^?

Others admiring the Monastery: (2)

As of 2024-04-16 21:42 GMT

Sections^?

Information^?

Find Nodes^?

Leftovers^?

Today I Learned

Voting Booth^?

No recent polls found


Don't ask to ask, just ask
	PerlMonks