MCB Bookmarks

PerlModule HTML::Mason::ApacheHandler PerlSetVar MasonCompRoot /home/jeff/public_html/mason SetHandler perl-script PerlHandler HTML::Mason::ApacheHandler ##

##

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

##

##

#!/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__

##

##

# 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!
";
            $linked_word = qq{
         $lookup_word 

             };
    }
    else {
            print "YOU ARE HERE
";
            $linked_word = $lookup_word;
    }
    $word->finish;
    return $linked_word;
}


##

##

#!/usr/bin/perl
use warnings;
use strict;
use CGI;
my $tail = qx(tail mvc.txt);
print CGI::header(), qq{

    
        
    
    
        $tail
    

}

##

##



##

##



    bar


##

##

#!/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;
}

##

##

#!/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 '',;
close IN;

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

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

##

##

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

##

##

#!/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;

##

##





##

##

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

##

##

#!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);

##

##

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

##

##

#!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/');

##

##

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

##

##




    MCB Bookmarks
    
    


Newest Nodes

Recently Active Threads

View Scratchpad


Edit Scratchpad

PM Stats

CB Stats

XP




##

##


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

##

##

#!/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;


##

##

 use Text::CSV_XS;
 $c = Text::CSV_XS->new;              # use default separator,delimiter,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 arrayref
 $c->write_table($filename,$hashref)   # create a CSV file from a hashref


 $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 above) has convenient shortcuts, the older interface is for backwards compatibility for previous users.  B: in the new interface binary mode defaults to true, whereas in the older interface it defaults to false.  This means that the new interface methods will, by default, handle embedded newlines and binary characters, whereas if you want that behaviour with the old methods, you must manually set binary=>1 in the call to new().

##

##

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


##

##

#!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__

##

##

#!/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] $filename\n";
};
1;

##

##

#!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
")};

##

##

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

##

##

#!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__