atcroft's scratchpad

Public Scratchpad

05 Jan 2012

Is the following a valid way of sub-classing (if that's a term) an object?

Object A:

package Letter_A;

use strict;
use warnings;

our @ISA = qw( Letter );

sub new {
    my $class = shift;

    my %_hash = ( my_type => $class, letter => q{A}, );

    bless \%_hash, $class;
}

1;
[download]

Object B:

package Letter_B;

use strict;
use warnings;

our @ISA = qw( Letter );

sub new {
    my $class = shift;

    my %_hash = ( my_type => $class, letter => q{B}, );

    bless \%_hash, $class;
}

1;
[download]

Base object:

package Letter;

use strict;
use warnings;

sub new {
    my $class = shift;

    my %_hash;

    if ( scalar @_ and $_[0] eq q{A} ) {
        require Letter_A;
        my $s = Letter_A->new();
        return bless $s, $class;
    }
    if ( scalar @_ and $_[0] eq q{B} ) {
        require Letter_B;
        my $s = Letter_B->new();
        return bless $s, $class;
    }

    # } else {
    %_hash = ( my_type => $class, letter => q{}, );

    bless \%_hash, $class;

    # }
}

sub identify {
    my $self = shift;
    print q{I am a '} . $self->{my_type} . q{'} . qq{\n};
}

1;
[download]

Sample code using object:

#!/usr/bin/perl

use strict;
use warnings;

use lib q{.};

use Data::Dumper;

use Letter;

my $s = Letter->new(q{B});

$s->identify;
print Data::Dumper->Dump( [ \$s ], [qw( *s )] ), qq{\n};
[download]

23 Feb 2011

Sample code for a fellow monk who was looking for a way to colorize differences within lines of a data file.

#!/usr/bin/perl

use strict;
use warnings;

use Getopt::Long;

$| = 1;

my @filename;
my %color = ( same => q{#000000}, file1 => q{#FF0000}, file2 => q{#000
+0FF}, );
my $outfile = $0 . q{.html};

if ( scalar( grep( /^-/, @ARGV ) ) ) {
    my @local_color;
    GetOptions(
        'filename:s'   => \@filename,
        'outputfile:s' => \$outfile,
        'color:s'      => \@local_color,
        'help'         => \&help,
    );
    @filename = split( /,/, join( ',', @filename ) );
    while ( scalar @filename > 2 ) {
        pop @filename;
    }
    @local_color = split( /,/, join( ',', @local_color ) );
    if ( scalar @local_color >= 3 ) {
        $color{same}  = $local_color[0];
        $color{file1} = $local_color[1];
        $color{file2} = $local_color[2];
    }

    if ( scalar @filename < 2 ) {
        warn qq{Too few input files listed!\n};
        &help;
    }
}
else {
    &help;
}

#
# Actual code here
#

open my $INF1, $filename[0] or die $!;
open my $INF2, $filename[1] or die $!;
open my $OUTF, q{>}, $outfile or die $!;

write_header( $OUTF, \@filename, $outfile, \%color );

my $i = 0;

process_files( $INF1, $INF2, $OUTF, \$i, \@filename, \%color );

process_files( $INF1, $INF2, $OUTF, \$i, \@filename, \%color );

process_remaining_file( $INF1, $OUTF, 0, \$i, \@filename, \%color );
close $INF1;
process_remaining_file( $INF2, $OUTF, 1, \$i, \@filename, \%color );
close $INF2;

write_footer($OUTF);
close $OUTF;

sub process_files {
    my ( $INF1, $INF2, $OUTF, $linecount, $fn, $color ) = @_;

    while ( defined $INF1 and defined $INF2 ) {
        my @p1;
        my @p2;

        my $l1 = <$INF1>;
        last unless defined $l1;
        chomp $l1;
        @p1 = split //, $l1;
        my $l2 = <$INF2>;
        last unless defined $l2;
        chomp $l2;
        @p2 = split //, $l2;

        $$linecount++;
        my $out1 = sprintf q{<font color="%s">%06d: }, $color->{same},
+ $$linecount;
        my $out2 = sprintf q{<font color="%s">%06d: }, $color->{same},
+ $$linecount;
        my $state = 0;
        while ( scalar @p1 and scalar @p2 ) {
            my $e1 = shift @p1;
            my $e2 = shift @p2;
            if ( ( ( ord $e1 == ord $e2 ) and ( !$state ) ) or ( ( ord
+ $e1 != ord $e2 ) and ($state) ) ) {
                $out1 .= $e1;
                $out2 .= $e2;
            }
            else {
                $state = !$state;
                $out1 .= sprintf qq{</font><font color="%s">%s}, $colo
+r->{ ( $state ? q{file1} : q{same} ) }, $e1;
                $out2 .= sprintf qq{</font><font color="%s">%s}, $colo
+r->{ ( $state ? q{file2} : q{same} ) }, $e2;
            }
        }
        if ( scalar @p1 ) {
            if ($state) {
                $out1 .= sprintf qq{%s</font>}, join( q{}, @p1 );
            }
            else {
                $out1 .= sprintf qq{</font><font color="%s">%s</font>}
+, $color->{file1}, join( q{}, @p1 );
            }
        }
        elsif ( scalar @p2 ) {
            if ($state) {
                $out2 .= sprintf qq{%s</font>}, join( q{}, @p2 );
            }
            else {
                $out2 .= sprintf qq{</font><font color="%s">%s</font>}
+, $color->{file2}, join( q{}, @p2 );
            }
        }
        $out1 .= qq{</font>\n};
        $out2 .= qq{</font>\n};

        print $OUTF $out1, $out2, qq{\n};
    }
}

sub process_remaining_file {
    my ( $inhandle, $outhandle, $file_id, $linecount, $fn, $color ) = 
+@_;

    while ( defined $inhandle ) {
        my $line = <$inhandle>;
        last unless defined $line;
        $$linecount++;
        chomp $line;

        my $out1;
        my $out2;
        if ($file_id) {
            $out1 = sprintf qq{%06d: -%s closed-\n}, $$linecount, $fn-
+>[0];
            $out2 = sprintf qq{%06d: <font color="%s">%s</font>\n}, $$
+linecount, $color->{file2}, $line;
        }
        else {
            $out2 = sprintf qq{%06d: -%s closed-\n}, $$linecount, $fn-
+>[1];
            $out1 = sprintf qq{%06d: <font color="%s">%s</font>\n}, $$
+linecount, $color->{file1}, $line;
        }
        print $outhandle $out1, $out2, qq{\n};
    }
}

sub help {
    printf <<HELPTEXT, $0, $0;

%s -filename file1,file2 [-color #same,#file1,#file2]
    [-outputfile outfile] [-help]

    -filename file1,file2
        - files to process (only the first 2 will be processed; parame
+ter may
        appear twice or names may be comma-separated
    -outputfile outfile
        - file HTML output is written to (default value is %s.html)
    -color #same,#file1,#file2
        - colors used for output of portions of line that match and di
+ffering
        portions. Written in #RRGGBB format. (default values are #0000
+00,
        #FF0000, and #0000FF).
    -help            - display this help text

HELPTEXT
    exit;
}

sub write_header {
    my ( $OUTF, $filename, $outfilename, $color ) = @_;

    print $OUTF <<HEADER
<html>
<head>
</head>
<body>
  <p>Output filename: $outfilename</p>
  <table>
    <tr>
      <td>File</td>
      <td>Color</td>
    </tr>
    <tr>
      <td><font color="$color{same}">$color{same}</font></td>
      <td>Matching</td>
    </tr>
    <tr>
      <td><font color="$color{file1}">$color{file1}</font></td>
      <td>$filename->[0]</td>
    </tr>
    <tr>
      <td><font color="$color{file2}">$color{file2}</font></td>
      <td>$filename->[1]</td>
    </tr>
  </table>
  <hr />
  <pre>
HEADER
}

sub write_footer {
    my ($OUTF) = @_;
    print $OUTF <<FOOTER;
  </pre>
</body>
</html>
FOOTER
}

[download]

21 Apr 2007

Sample code for a fellow monk, in hopes it helps with the problem they were working on.

#!/usr/bin/perl -lw

use strict;
use Data::Dumper;

my $h = {
    info => {
        a => 1,
        b => 2,
    },
    q{info (1)} => {
        a => 3,
        c => 4,
        d => 5,
    },
    q{test (1)} => {
        e => 5,
        f => {
            g => 6,
            h => 7,
        },
    },
};

test($h);

print Data::Dumper->Dump([\$h], [qw(*h)]);

sub test {
    my $self = $_[0];
    my @k = grep { /\s+\(1\)$/; } keys %{$self};
    foreach my $t (@k) {
        my $s = $t;
        $s =~ s/\s+\(1\)$//;
        if (exists $self->{$s}) {
            foreach my $i ( keys %{$self->{$t}} ) {
                if (exists($self->{$s}->{$i})) {
                    if (ref($self->{$s}->{$i}) 
                      ne q{ARRAY}) {
                        my $tmp = $self->{$s}->{$i};
                        delete $self->{$s}->{$i};
                        push @{$self->{$s}->{$i}, $tmp;
                    }
                    push @{$self->{$s}->{$i}},
                      $self->{$t}->{$i};
                } else {
                    $self->{$s}->{$i} = $self->{$t}->{$i};
                }
            }
        } else {
            $self->{$s} = $self->{$t};
        }
        delete $self->{$t};
    }
}
[download]

18 Mar 2007

Sample code for a fellow monk in hopes of handling an XML config to a structure that had a unique "compound" key.

#!/usr/bin/perl -l

use strict;
use warnings;
use Data::Dumper;
use XML::Simple;

my $bla = XMLin("primary.xml",
    ForceArray => [ qw(package) ],
    KeyAttr => [ ],
);

foreach my $i (0 .. $#{$bla->{package}}) {
    # The combination of fields name, epoch, 
    #   version, release and arch are (unique).
    $bla->{temp}{sprintf("%s-%s-%s-%s-%s",
            $bla->{package}[$i]{name},
            $bla->{package}[$i]{version}{ver},
            $bla->{package}[$i]{version}{rel},
            $bla->{package}[$i]{version}{epoch},
            $bla->{package}[$i]{arch},
        )} = $bla->{package}[$i];
}

($bla->{package}, $bla->{temp}) 
    = ($bla->{temp}, $bla->{package});
delete($bla->{temp});

print Data::Dumper->Dump( [\$bla], [qw(*bla)]);
[download]

09 Dec 2006

Sample code for a fellow monk handling various cmd-line inputs with Getopt::Long.

#!/usr/bin/perl -w

use strict;

use Getopt::Long;
use Data::Dumper;

$| = 1;

my (@foo);
my ($bar);
my $baz = 0;
my $bop = 0;
my $quux;

if ( scalar( grep( /^-/, @ARGV ) ) ) {
    GetOptions(
        'foo:s'   => \@foo,
        'bar:s'   => \$bar,
        'baz+'    => \$baz,
        'gazonk+' => sub { $bop = !$bop; $bop += 0; },
        'quux' => sub { $quux = scalar localtime; },
        'help' => \&help,
    );
    @foo = split( /,/, join( ',', @foo ) );

    print Data::Dumper->Dump(
        [ \@foo, \$bar, \$baz, \$bop, \$quux ],
        [qw(*foo *bar *baz *bop *quux)]
        ),
        qq{\n};

    if ( !$baz ) {
        if ( !scalar(@foo) ) {
            &help;
        }
        if ( ( !defined($bar) ) or ( !length($bar) ) ) {
            &help;
        }
    }
}
else {
    &help;
}

sub help {
    printf <<HELPTEXT, $0, ( 'alice[,bob,eve]', 'xyzzy' ) x 2;

%s [-foo %s] [-bar %s] [-baz] [-gazonk] [-quux] [-help]

    -foo %s - one or more options, either comma-separated
                or the option listed more than once
    -bar %s - another option
    -baz    - a flag
    -gazonk - another flag, trying to flip on/off
    -quux   - option which results in a subroutine being called
    -help   - display this help text

HELPTEXT
    exit;
}
[download]

09 Dec 2006

Testing results when looking at a problem for a fellow monk. (Reference: Options with multiple values)

Test script:

#!/usr/bin/perl -w

use strict;
use Getopt::Long qw(:config debug);

my @coor;
my @color;

GetOptions(
    'coordinates=f{2}' => \@coor,
    'rgbcolor=i{3}'    => \@color
);

print qq{Coordinates:\n} . join( qq{\n\t}, @coor ), qq{\n},
    qq{RGBcolor:\n} . join( qq{\n\t}, @color ), qq{\n};
[download]

Results:

$ perl gol-test.pl --coordinates 52.2 16.4 --rgbcolor 255 255 149
Getopt::Long 2.34 ($Revision: 2.68 $) called from package "main".
  ARGV: (--coordinates 52.2 16.4 --rgbcolor 255 255 149)
  autoabbrev=1,bundling=0,getopt_compat=1,gnu_compat=0,order=1,
  ignorecase=1,requested_version=0,passthrough=0,genprefix="(--|-|\+)"
+.
Error in option spec: "coordinates=f{2}"
Error in option spec: "rgbcolor=i{3}"
[download]

(Note to self: If you're testing something that's listed as an experimental feature, make sure you have the version of the module that implements it.)

09 Nov 2006

Sample code for a fellow monk, of how to create a SQLite db from scratch. (Taken from a personal project for backing up PM private messages.)

#!/usr/bin/perl -w

use strict;

use DBI;
use DBD::SQLite;
use Data::Dumper;
use Getopt::Long;
use LWP::Simple;
use XML::Simple;

$| = 1;

print $DBD::SQLite::VERSION,        qq{\n};
print $DBD::SQLite::sqlite_version, qq{\n};

my $datafile = $0 . q{.sqlite};

if ( scalar grep( /^-/, @ARGV ) ) {
    GetOptions(
        "help|?"     => sub { &help($datafile) },
        "datafile=s" => \$datafile,
    );
}

if ( !-e $datafile ) {
    open( DF, q{>>} . $datafile ) or die(qq{Couldn't open $datafile fo
+r append: $!\n});
    close(DF);
}

my $dbh = DBI->connect( qq{dbi:SQLite:dbname=$datafile}, q{}, q{}, { A
+utoCommit => 0 } );

test_table_existance($dbh);

# my $cb_xml_url = q{http://www.perlmonks.org/index.pl?node_id=207304}
+;
my $cb_xml_url = q{358181.pl.1132118668.xml};

foreach my $cb_xml_url (@ARGV) {
    next unless ( -f $cb_xml_url );
    print $cb_xml_url, qq{\n};

    # Setup
    my $xs = new XML::Simple;

    my $cb_xml;
    open( DF, $cb_xml_url ) or die($!);
    {
        my @temp = <DF>;
        chomp @temp;
        $cb_xml = join( qq{\n}, @temp );
        $cb_xml =~ s/&([^a])/&amp;$1/g;
        $cb_xml =~ s/<([^CIm?\/])/&lt;$1/g;
        $cb_xml =~ s/<\/([^CIm?])/&lt;\/$1/g;
    }

    # my $cb_xml = get($cb_xml_url) or die(qq{Could not retrieve CB XM
+L ticker: $!\n});
    if ( $cb_xml =~ m/[\x00-\x08\x0b-\x0c\x0e-\x1f]/ ) {
        my @parts = split( //, $cb_xml );
        foreach my $c ( 0 .. $#parts ) {
            if ( $parts[$c] =~ m/[\x00-\x08\x0b-\x0c\x0e-\x1f]/ ) {
                $parts[$c] = sprintf( '<!-- XML disallowed character 0
+x%x detected -->', ord( $parts[$c] ) );
            }
        }
        $cb_xml = join( '', @parts );
    }

    my $ref = $xs->XMLin( $cb_xml, ForceArray => [q{message}] ) or die
+(qq{Could not parse CB XML: $!\n});

    # print Data::Dumper->Dump( [ \$ref ], [qw(*ref)] ), "\n";

    my $ior_updateinfo = q{
    INSERT OR REPLACE INTO updateinfo 
        ( updateinfo_id, archived, foruser, foruser_id, gentimeGMT, 
            hard_limit, max_recs, min_poll_seconds, since_id, site, 
            sitename, style, content ) 
        VALUES 
            ( NULL, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );
    };
    my $iorus = $dbh->prepare($ior_updateinfo);
    my $iorur = $iorus->execute(
        $ref->{INFO}{archived},         $ref->{INFO}{foruser},    $ref
+->{INFO}{foruser_id},
        $ref->{INFO}{gentimeGMT},       $ref->{INFO}{hard_limit}, $ref
+->{INFO}{max_recs},
        $ref->{INFO}{min_poll_seconds}, $ref->{INFO}{since_id},   $ref
+->{INFO}{site},
        $ref->{INFO}{sitename},         $ref->{INFO}{style},      $ref
+->{INFO}{content},
        )
        or die( $dbh->errstr );

    my $ior_message = q{
    INSERT OR REPLACE INTO message 
        ( message_id, author, status, time, user_id, content )
        VALUES
            ( ?, ?, ?, ?, ?, ? );
    };
    my $iorms = $dbh->prepare($ior_message);
    foreach my $i ( 0 .. $#{ $ref->{message} } ) {
        my $iormr = $iorms->execute(
            $ref->{message}[$i]{message_id}, $ref->{message}[$i]{autho
+r},  $ref->{message}[$i]{status},
            $ref->{message}[$i]{q{time}},    $ref->{message}[$i]{user_
+id}, $ref->{message}[$i]{content},
            )
            or die( $dbh->errstr );
    }

    $dbh->commit;
}

$dbh->disconnect;

do_maintainance($datafile);

#
# Subroutines
#
sub help {
    my ($datafile) = @_;
    printf <<HELP_TEXT, $datafile;

Usage:  $0 [-help| -?] [-datafile filename] 

    -help | -?      - display this help message and exit.

    -datafile filename  - name of SQLite database file to use 
                            (created if does not exist, default: %s).

HELP_TEXT
    exit(0);
}

sub do_maintainance {
    my ($datafile) = @_;

    my @maintainence_query = (
        q{
        VACUUM updateinfo;
    },
        q{
        VACUUM message;
    },
    );

    foreach my $i ( 0 .. $#maintainence_query ) {
        my $maintenance = $maintainence_query[$i];

        my $pre_fs   = ( stat($datafile) )[7];
        my $pre_time = time;
        $dbh = DBI->connect( qq{dbi:SQLite:dbname=$datafile}, q{}, q{}
+ );
        $dbh->do($maintenance);
        $dbh->disconnect;
        my $post_time = time;
        my $post_fs   = ( stat($datafile) )[7];

        if ( $pre_fs != $post_fs ) {
            printf
                qq{Vacuuming of database table %d lead to a change of 
+%d bytes in size (from %d to %d bytes, in %d seconds)\n},
                $i, ( $post_fs - $pre_fs ), $pre_fs, $post_fs, ( $post
+_time - $pre_time );
        }
    }
}

sub test_table_existance {
    {
        my ($dbh) = @_;

        my $tables_query = q{
SELECT COUNT(name) FROM 
( 
    SELECT * FROM sqlite_master UNION ALL 
    SELECT * FROM sqlite_temp_master
) WHERE type='table'; 
};
        my $tqs     = $dbh->prepare($tables_query);
        my $tqr     = $tqs->execute;
        my @row_tqr = $tqs->fetchrow_array;
        $tqs->finish;

        if ( !$row_tqr[0] ) {

            my @creation_query = (
                q{
                CREATE TABLE updateinfo (
                    updateinfo_id INTEGER,
                    archived TEXT,
                    foruser TEXT,
                    foruser_id INTEGER,
                    gentimeGMT TEXT,
                    hard_limit INTEGER,
                    max_recs INTEGER,
                    min_poll_seconds INTEGER,
                    since_id INTEGER,
                    site TEXT,
                    sitename TEXT,
                    style TEXT,
                    content TEXT,
                    UNIQUE(gentimeGMT, updateinfo_id)
                );
},
                q{
                CREATE TABLE message (
                    message_id INTEGER,
                    author TEXT,
                    status TEXT,
                    time INTEGER,
                    user_id INTEGER,
                    content TEXT,
                    UNIQUE(message_id)
                );
},
                q{
                CREATE INDEX ui_idx ON updateinfo ( updateinfo_id );
},
                q{
                CREATE INDEX m_idx ON message ( message_id );
},
                q{
                CREATE INDEX m_idx_2 ON message ( author, status, user
+_id, time, content );
},
            );

            foreach my $i ( 0 .. $#creation_query ) {
                my $cr = $dbh->do( $creation_query[$i] );
            }

            $dbh->commit;
        }
    }
}
__END__

[download]

14 May 2006

Sample code for an offline discussion with a fellow monk.

w-test.pl - test program
Exam/ATC.pm - module one object type comes from
Test/AC1.pm - module other object type comes from
My/Wrapper.pm - module containing "wrapper" object

w-test.pl :

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;

use Exam::ATC;
use Test::AC1;
use My::Wrapper;

my @possible_methods =
    qw( get_a get_b get_ set_ get_value set_value get set wrapper_get 
+wrapper_set );

my $wrapper = My::Wrapper->new();

my $something = Exam::ATC->new(qw(a b c d));

$wrapper->set_original_object($something);

$wrapper->set('a');


print Dumper($wrapper);

print "the value of [c] is [", $wrapper->get('c'), "]\n";

foreach my $method (@possible_methods) {
    printf "the object %s $method\n",
        $wrapper->can($method) ? 'can' : 'cannot';
}

my $object = Test::AC1->new(qw(a b c d));
$wrapper->set_original_object($object);

$wrapper->set('c');

print Dumper($wrapper);

print "the value of [a] is [", $wrapper->get('a'), "]\n";

foreach my $method (@possible_methods) {
    printf "the object %s $method\n",
        $wrapper->can($method) ? 'can' : 'cannot';
}
[download]

Exam/ATC.pm :

use strict;
use warnings;

package Exam::ATC;

sub new {
    my $class   = shift;
    my %attribs = @_;

    my $href = {};
    $href->{var1} = 'this is set in new';
    foreach my $key ( keys %attribs ) {
        $href->{$key} = $attribs{$key};
    }

    my $obj = bless( $href, $class );
    return $obj;
}

sub get_value {
    my ( $self, $k ) = @_;
    $k ||= q{a};
    return $self->{$k};
}

sub set_value {
    my ( $self, $k, $v ) = @_;
    if ( defined($v) ) {
        $self->{$k} = $v;
    }
    else {
        delete( $self->{$k} );
    }
}

1;
[download]

Test/AC1.pm :

use strict;
use warnings;

package Test::AC1;

sub new {
    my $class   = shift;
    my %attribs = @_;

    my $href = {};
    $href->{var1} = 'this is set in new';
    foreach my $key ( keys %attribs ) {
        $href->{$key} = $attribs{$key};
    }

    my $obj = bless( $href, $class );
    return $obj;
}

sub get_ {
    my ( $self, $k ) = @_;
    $k ||= q{a};
    return $self->{$k};
}

sub set_ {
    my ( $self, $k, $v ) = @_;
    if ( defined($v) ) {
        $self->{$k} = $v;
    }
    else {
        delete( $self->{$k} );
    }
}

1;
[download]

My/Wrapper.pm :

#
# My/Wrapper.pm
#
use strict;
use warnings;

package My::Wrapper;

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    if (@_) {
        $self->{orig_obj} = $_[0];
    }
    return $self;
}

sub wrapper_get {
    my $self = shift;
    my ($k) = @_;
    $k ||= q{orig_obj};
    return $self->{$k};
}

sub wrapper_set {
    my $self = shift;
    my ( $k, $v ) = @_;
    if ( defined($v) ) {
        $self->{$k} = $v;
    }
    else {
        delete( $self->{$k} );
    }
}

sub get_original_object {
    my $self = shift;

    # return $self->{orig_obj};
    return $self->wrapper_get('orig_obj');
}

sub set_original_object {
    my $self = shift;

    # $self->{orig_obj} = $_[0];
    $self->wrapper_set( 'orig_obj', $_[0] );
}

# Test::AC1 - get_, set_
# Exam::ATC - get_value, set_value

sub get {
    my $self        = shift;
    my $wrapped_obj = $self->get_original_object;
    if ( $wrapped_obj->can('get_') ) {
        return $wrapped_obj->get_(@_);
    }
    elsif ( $wrapped_obj->can('get_value') ) {
        return $wrapped_obj->get_value(@_);
    }
    else {
        warn("Wrapped object supports neither get_ nor get_value metho
+ds.\n");
    }
}

sub set {
    my $self        = shift;
    my $wrapped_obj = $self->get_original_object;
    if ( $wrapped_obj->can('set_') ) {
        return $wrapped_obj->set_(@_);
    }
    elsif ( $wrapped_obj->can('set_value') ) {
        return $wrapped_obj->set_value(@_);
    }
    else {
        warn("Wrapped object supports neither set_ nor set_value metho
+ds.\n");
    }
}

1;
[download]

08 Mar 2006

An attempt to help a fellow monk solve a problem.

#!/usr/bin/perl -w
# vim:set expandtab shiftwidth=4 softtabstop=2 tabstop=4:
 
use strict;
 
use Data::Dumper;
use XML::LibXML;
use XML::LibXSLT;
use XML::XPath;
 
my $xml_results =
q{<tr>
<td>Floor</td>
 
<td><a href=http://wwwin.cisco.com/wpr/floorplans/bldgid/BDLK11/BDLK11
+-AFP-1.pld target=_blank>Floor 1</a><a href=http://wwwin.cisco.com/wp
+r/floorplans/bldgid/BDLK11/BDLK11-AFP-1.pdf target=_blank><img src=./
+images/icon_pdf.gif width=18 height=12 border=0 alt='Adobe Acrobat PD
+F File'></a> (PDF)<br></td>
<td >Local Time (24 hr)</td> <td><p><script language="JavaScript"> Ser
+verClock(); </script><noscript>Wed 21:58:50 </noscript></p></td>
</tr>
};
 
#
# Since there was a comment that there was no control over the source 
+HTML....
# (and yes, I know it probably only works with the sample data)....
#
$xml_results =~ s/(=)([^\"\'\s\>]+)/$1"$2"/gis;
$xml_results =~ s/(\<br)(\>)/$1\/$2/gis;
$xml_results =~ s/(\<img[^\>]+)(>)/$1\/$2/gis;
 
=pod
#
# For reference-the expressions worked with this
#
$xml_results =
q{<tr>
<td>Floor</td>
 
<td><a href="http://wwwin.cisco.com/wpr/floorplans/bldgid/BDLK11/BDLK1
+1-AFP-1.pld" target="_blank">Floor 1</a><a href="http://wwwin.cisco.c
+om/wpr/floorplans/bldgid/BDLK11/BDLK11-AFP-1.pdf" target="_blank"><im
+g src="./images/icon_pdf.gif" width="18" height="12" border="0" alt='
+Adobe Acrobat PDF File' /></a> (PDF)<br /></td>
<td >Local Time (24 hr)</td> <td><p><script language="JavaScript"> Ser
+verClock(); </script><noscript>Wed 21:58:50 </noscript></p></td>
</tr>
};
=cut
 
#
# No user-editable data below this point.
#
 
$| = 1;
 
# Initialize the parser and XSLT processor
my $parser = XML::LibXML->new();
my $xslt   = XML::LibXSLT->new();
 
my $source_doc = $parser->parse_string($xml_results);
 
# Initialize the XPath processor
my $xp = XML::XPath->new( xml => $xml_results );
 
my ($stylesheet);
{
    my $stylesheetdata = q{
<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Tr
+ansform">
        <xsl:output method="html" encoding="iso-8859-1" indent="no"/>
        <xsl:template match="/">
 
    <xsl:value-of select="//tr/td[preceding-sibling::td/text()='Local 
+Time (24 hr)' and position()=4]/p/noscript/text()"/>
 
        </xsl:template>
</xsl:stylesheet>
};
 
    my $style_data = $parser->parse_string($stylesheetdata);
    $stylesheet = $xslt->parse_stylesheet($style_data);
}
 
my $result = $stylesheet->transform($source_doc);
print $stylesheet->output_string($result);
[download]

02 Feb 2006

An attempt at finding the longest substring that appears twice in a larger string.

#!/usr/bin/perl -w
use strict;

my ($str);
open(DF, q{43.txt}) or die(qq{Can't open 43.txt for input: $!\n"});
{
  my @string = <DF>;
  chomp(@string);
  $str = join('', @string);
}
close(DF);

foreach my $to_consider (reverse(1..length($str) - 2)) {
  foreach my $start_at (0..length($str) - $to_consider - 1) {
    my $str1 = substr($str, $start_at, $to_consider);
    foreach my $against (1..length($str) - $to_consider) {
      if (substr($str, $start_at + $against, $to_consider) eq $str) {
        printf qq{Found at %d and %d, of length %d\n}, 
            $start_at, $start_at + $against, $to_consider;
        exit;
      }
    }
  }
}
[download]

28 Jan 2006

A look at some code for a fellow monk


print join(", ", 
  map{ q{<a href="link.pl?=} . $_ . q{" target="_blank" onclick="var w
+inHandle = window.open('', '', 'width=400,height=200'); return(false)
+;">} . $_ . q{</a>} } @array
  );

[download]

17 Nov 2005

Attempt at converting lyrics to perl poetry (not intended to run).... (Original lyrics at http://www.lyricsfreak.com/v/vince-gill/144500.html)

# Title:    Go Rest High on that Mountain
# Artist:   Vince Gill
# Lyrics:   http://www.lyricsfreak.com/v/vince-gill/144500.html


# I know
your $life{on_earth} = 'troubled';
{
    your $pain = 1;
}
your $afraid = 0;
open(DEVIL);
$known{rain} = 1;

chorus();

our %cries = ( day => 'you left us', number => many );
%we = ( location => 'gathered round your grave', 
        reason => 'to grieve' );

my ($wish);
while ($angels{hear} == ( your $voice = 'sweet')) { 
    $angels{faces}->display;
}

chorus() foreach ( 0 .. 1 );

sub chorus {
    goto REST_HIGH_ON_THAT_MOUNTAIN;

REST_HIGH_ON_THAT_MOUNTAIN:
    your $work{on_earth} = 'done';
    goto HEAVEN;

HEAVEN:
    $you->shouting('love for the Father and the Son');
}
[download]

(Backstory: The song was used in a funeral service recently for someone I knew. A few days later, I picked up a CD which, unknown to me at the time, contained the song.)

25 Aug 2005

Snippet of code to help out a fellow monk

for my $host (keys %hosts) {
  for my $servicename ( @{$hosts{$host}} ) {
    for my $protocol (keys %{$services{$servicename}}) {
      my $portnumber = $services{$servicename}{$protocol};
      print "$host  $servicename  $protocol  $portnumber\n";
    }
  }
}
[download]

19-20 Jun 2005

Sample code used to retrieve all messages from Message Inbox (stripped of username/passwords/etc)

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;
use Festival::Client;
use File::Spec;
use HTTP::Cookies;
use HTTP::Request::Common qw{POST};
use LWP;
use XML::Simple;

$| = 1;

# Information for Festival server to connect to
#   (undef as port value to use default port)
my %festival_server = (
    host => q{localhost},
    port => undef,
);

# The following values are in seconds.
# $delay - approximate delay between Message Inbox XML Ticker retrieva
+ls
my $delay        = 90;

# $seen - holds message id of last message seen
my $seen = 0;

# Setup
my $username = '(your username here)';
my $password = '(your password here)';

my $xs         = new XML::Simple;
my $cookie_jar =
  File::Spec->catfile( File::Spec->tmpdir(),
    join ( q{.}, ( File::Spec->splitpath($0) )[2] ) . q{.cj} );
my $pm_server = q{www.perlmonks.com};
my $pm_port   = 80;
my $pm_base   = q{http://}
  . $pm_server
  . ( $pm_port != 80 ? q{:} . $pm_port : '' ) . q{/};
my $li_xml_url = $pm_base
  . q{/index.pl?node_id=109;displaytype=xml;xmlstyle=flat;nofields=1;o
+p=login;ticker=1;user=}
  . $username
  . q{;passwd=}
  . $password;
my $last_mi    = 0;
my $max_recs   = 20;
my $mi_xml_url =
  sprintf(
q{%sindex.pl?node_id=%d;archived=%s;xmlstyle=%s;max_recs=%d;since_id=%
+%d},
    $pm_base, 15848, q{both}, q{default}, $max_recs );

my ($fs);
my ($browser);
my ($ref);
my ($combined_mi);

# Attempt to log in
$browser = LWP::UserAgent->new;
$browser->cookie_jar(
    HTTP::Cookies->new( file => $cookie_jar, autosave => 1 ) );

my $li_xml = $browser->get($li_xml_url)
  or die (
    scalar localtime() . q{: }
      . qq{Could not log into the site: $!\n} );

$ref =
  $xs->XMLin( $li_xml->content, ForceArray => [q{loggedin}] )
  or die (
    scalar localtime() . q{: }
      . qq{Could not parse information regarding login to site XML: $!
+\n}
  );

# Do not proceed if we did not successfully log in
die (
    scalar localtime() . q{: }
      . qq{Could not log into PM: $!\n} )
  unless ( exists( $ref->{loggedin} ) );

my $count = 10_000
  ; # There should NEVER be more than this number messages, at worst
while ($count) {

    my $mi_xml =
      $browser->get( sprintf( $mi_xml_url, $last_mi ) )
      or warn(
        scalar localtime() . q{: }
          . qq{Could not retrieve Message Inbox XML ticker: $!\n}
      );

    $ref =
      $xs->XMLin( $mi_xml->content, ForceArray => [q{message}] )
      or die (
        scalar localtime() . q{: }
          . qq{Could not parse Message Inbox XML: $!\n} );

    if ( !exists( $combined_mi->{INFO} ) ) {
        $combined_mi->{INFO} = $ref->{INFO};
    }

    $delay = $ref->{INFO}->{min_poll_seconds};
    print qq{Delay: $delay\n};

    # Check to see if there are message entries
    last unless ( exists( $ref->{message} ) );

    foreach my $message ( @{ $ref->{message} } ) {
        push ( @{ $combined_mi->{message} }, $message );
        if ( $message->{message_id} > $seen ) {
            $seen = $message->{message_id};

            printf(
                "%s-%s-%s %s:%s:%s - %s: %s\n",
                substr( $message->{time}, 0,  4 ),
                substr( $message->{time}, 4,  2 ),
                substr( $message->{time}, 6,  2 ),
                substr( $message->{time}, 8,  2 ),
                substr( $message->{time}, 10, 2 ),
                substr( $message->{time}, 12, 2 ),
                $message->{author},
                $message->{content}
            );
            $last_mi = $message->{message_id}
              if ( $message->{message_id} > $last_mi );
        }
    }

    print scalar localtime(), q{: },
      qq{Asked for $max_recs, retrieved },
      scalar @{ $ref->{message} }, qq{\n};
    last if ( scalar @{ $ref->{message} } != $max_recs );

    print qq{Last message id: $last_mi\n};
    print qq{Sleeping for $delay seconds...\n};
    sleep($delay);
}

my ($OUTF);
open( $OUTF, q{>} . $0 . q{.3.out} ) or die (qq{$! \n});
$xs->XMLout(
    $combined_mi,
    (
        AttrIndent => 1,
        KeepRoot   => 1,
        NoEscape   => 1,
        OutputFile => $OUTF,
        RootName   => q{CHATTER},
        XMLDecl    => 1
    )
);
close($OUTF);
[download]

04 Apr 2005

Sample ~/.cpan/CPAN/MyConfig.pm, as an example for a fellow monk:

$CPAN::Config = {
  'build_cache' => q[10],
  'build_dir' => qq[$ENV{HOME}/.cpan/build],
  'cache_metadata' => q[1],
  'cpan_home' => qq[$ENV{HOME}/.cpan],
  'ftp' => q[/usr/bin/ftp],
  'ftp_proxy' => q[],
  'getcwd' => q[cwd],
  'gpg' => q[/usr/bin/gpg],
  'gzip' => q[/bin/gzip],
  'histfile' => qq[$ENV{HOME}/.cpan/histfile],
  'histsize' => q[100],
  'http_proxy' => q[],
  'inactivity_timeout' => q[0],
  'index_expire' => q[1],
  'inhibit_startup_message' => q[0],
  'keep_source_where' => qq[$ENV{HOME}/.cpan/sources],
  'lynx' => q[/usr/bin/lynx],
  'make' => q[/usr/bin/make],
  'make_arg' => q[],
  'make_install_arg' => q[],
  'makepl_arg' => q[],
  'ncftpget' => q[/usr/bin/ncftpget],
  'no_proxy' => q[],
  'pager' => q[/usr/bin/less],

  'prerequisites_policy' => q[ask],
  'scan_cache' => q[atstart],
  'shell' => q[/bin/bash],
  'tar' => q[/bin/tar],
  'term_is_latin' => q[1],
  'unzip' => q[/usr/bin/unzip],
  'urllist' => [q[file://$ENV{HOME}/reference/cpan/], q[http://cpan.pa
+ir.com/], q[http://cpan.belfry.net/], q[http://cpan.mirrors.nks.net/]
+, q[http://www.perl.com/CPAN/]],
  'wget' => q[/usr/bin/wget],
};
1;
__END__
[download]

14 Mar 2005

Proposed title: Re^8: Smart match in p5

Proposed node content: (Posted content of node now in node 439427, Re^8: Smart match in p5 )

02 Jan 2005

#!/usr/bin/perl -w

use strict;
use Tk;

my %options = ( grid => 0 );
my (%objects);

my $mw = MainWindow->new;

# $objects{button}{exit} = $mw->Button( -text => 'Exit', -command => s
+ub { exit } )->pack( -side => 'bottom', -fill => 'x' );
$objects{button}{exit} =
  $mw->Button( -text => 'Exit', -command => sub { exit } )
  ->grid( -row => 5, -column => 0, -columnspan => 10, -sticky => 'nsew
+' );

my $frame = $objects{frame}{c1} =
  $mw->Frame( -background => 'blue', -borderwidth => 1, -label => 'con
+trol', -relief => 'groove' );
$objects{label}{i1} = $frame->Label( -anchor => 'w', -text => 'I-1' )-
+>grid( -row => 0, -column => 0 );

# $objects{label}{i2} = $frame->Label( -text => 'I-2' )->grid( -row =>
+ 2, -column => 0 );
# $objects{label}{i3}   = $frame->Label( -text => 'I-3' )->grid( -row 
+  => 0, -column => 2 );
# $objects{label}{i4}  = $frame->Label( -text => 'I-4' )->grid( -row  
+=> 2, -column => 2 );

$objects{frame}{c1}->grid( -row => 0, -column => 0, -rowspan => 4, -co
+lumnspan => 10, -sticky => 'nsew' );

MainLoop;
[download]

29 Oct 2004

An attempt to help a fellow monk with a problem.

#!/usr/bin/perl

use strict;
use warnings;
use File::Find;

my $base = '/var/www/noc/calendarsPostCalendars';
my $s1   = 'POSTCALENDARN';
my $s2   = 'POSTCALENDARS';
my $s3   = 'postcalendarn_';
my $s4   = 'postcalendars_';
my $s5   = 'PostCalendarn';
my $s6   = 'PostCalendars';


find(\&wanted, $base);

sub wanted {

    if ((-f $File::Find::name) && ($File::Find::name !~ m/\.bak/)) {
        my $file = $File::Find::name;
        my $file_old = $file . '.bak';

        rename($file, $file_old);
        open(IN, $file_old) or die($!);
        open(OUT, '>' . $file) or die($!);
        while (<IN>) {
            s/$s1/$s2/;
            s/$s3/$s4/;
            s/$s5/$s6/;

            print OUT $_;
        }
        close(OUT);
        close(IN);
    }
}
[download]

26 Oct 2004

WTH?!?!?!? Why does the following not seem to work?

Output:

$ perl test.6.pl
Content-seen:
1

Content:

[download]

Code:

#!/usr/bin/perl -w

use strict;
use vars qw(@files);
use Data::Dumper;
use File::Find;
use File::Glob qw(:glob);
use Pod::Simple;
no warnings
  'File::Find';    # per suggestion of the docs for File::Find

$| = 1;

my (@searchpath);
foreach my $i ( 0 .. $#INC ) {
    push( @searchpath,
        File::Glob::bsd_glob( $INC[$i], GLOB_TILDE | GLOB_ERR )
    );
}
find( { wanted => \&wanted, no_chdir => 1 }, @searchpath );

sub wanted {
    if ( $File::Find::name =~ m/Find\.pm$/ ) {
        push( @files, $File::Find::name );
    }
}

my ($content);
open( DF, $files[0] )
  or die("Can't open $files[0] for input: $!\n");
{
    local ( $/ = undef );
    $content = <DF>;
}
close(DF);

my $podcontent = '';
my $parser     = Pod::Simple->new();
$parser->output_string( \$podcontent );
$parser->parse_string_document($content);

print "Content-seen:\n", $parser->content_seen, "\n";
print "Content:\n", $podcontent, "\n";

# print Data::Dumper->Dump( [ \$parser, \$content, \$podcontent ], 
#   [qw(*parser *content *podcontent)] ), "\n";
[download]

22 Oct 2004

Why does not behave? An attempt at writing a module for handling base operations for the Tower of Hanoi problem. (Adapted from code on pages 103-4, _Object_Oriented_Perl_ by Dr. Damian Conway.)

The new constructor does not seem to take the default values from $_class_defaults.</code>

package Tower;
use strict;
use Data::Dumper;

{
    my $_class_defaults = {
        _count_disks   => 3,
        _count_pegs    => 5,
        _display_move  => 1,
        _display_tower => 1,
        _movecount     => 0,
        _tower         => {},
        _tower_keys    => (),
    };

    sub _class_defaults {
        $_class_defaults;
    }

    sub _class_defaults_keys {
        map { s/^_//; $_ } keys %$_class_defaults;
    }

    sub _initialize {
        my ($self) = @_;
        @{ $self->{_tower_keys} } = ( 'A' .. chr( ord('A') + $self->{_
+count_pegs} ) );
        foreach ( @{ $self->{_tower_keys} } ) {
            @{ $self->{_tower}{$_} } = ();
        }
        $self->_add_to_tower( reverse( 1 .. $self->{_count_pegs} ) );
    }

    sub _remove_from_tower {
        my $self       = shift;
        my $tower_name = shift;
        return pop @{ $self->{_tower}{$tower_name} };
    }

    sub _add_to_tower {
        my $self       = shift;
        my $tower_name = shift;
        push @{ $self->{_tower}{$tower_name} }, @_;
    }

}

sub on_tower {
    my $self  = shift;
    my $tower = shift;
    return scalar @{ $self->{_tower}{$tower} };
}

sub tower_top {
    my $self  = shift;
    my $tower = shift;
    if ( scalar( @{ $self->{_tower}{$tower} } ) ) {
        return $self->{_tower}{$tower}[ $#{ $self->{_tower}{$tower} } 
+];
    }
    else {
        return undef;
    }
}

sub tower_keys {
    my $self = shift;
    @{ $self->{_tower_keys} };
}

sub move_count {
    my $self = shift;
    $self->{_movecount};
}

sub move {
    my $self = shift;
    my ( $from, $to ) = @_;
    if ( scalar( @{ $self->{_tower}{$from} } ) ) {
        my $piece = $self->_remove_from_tower($from);
        $self->_add_to_tower( $to, $piece );
        $self->{_move_count}++;
        $self->_display_move( $piece, $from, $to );
        $self->_display_tower;
    }
    else {
        warn("WARNING: $from contains no disks\n");
    }
}

sub new {
    my ( $caller, %arg ) = @_;
    my $class = ref($caller);
    my $defaults = $class ? $caller : $caller->_class_defaults();
    $class ||= $caller;
    my $self = bless {}, $class;

    foreach my $attribute ( $class->_class_defaults_keys ) {
        $self->{"_$attribute"} = ( exists $arg{"_$attribute"} ? $arg{"
+_$attribute"} : $defaults->{"_$attribute"} );
    }

    $self->_initialize;

    return ($self);
}

sub DESTROY {
    my ($self) = @_;
    foreach ( @{ $self->{_tower_keys} } ) {
        @{ $self->{_tower}{$_} } = ();
        delete( $self->{_tower}{$_} );
    }
    delete( $self->{_tower} );
    @{ $self->{_tower_keys} } = ();
}

sub display_tower {
    my $self = shift;
    if ( $self->{_display_tower} ) {
        foreach my $t ( @{ $self->{_tower_keys} } ) {
            printf(
                "%s: %s\n",
                $t,
                (
                    defined( $self->{_tower}{$t} )
                      and scalar( @{ $self->{_tower}{$t} } ) ? join( '
+ ', @{ $self->{_tower}{$t} } ) : ' '
                )
            );
        }
    }
}

sub display_move {
    my $self = shift;
    my ( $piece, $from, $to ) = @_;
    if ( $self->{_display_move} ) {
        printf( "%s: %s => %s\n", $piece, $from, $to );
    }
}
[download]

24 Sep 2004

Proposed title: Suggestions for nodes to use to test CSS

Proposed node content:

(Posted content of node now in node 393403, Suggestions for nodes to use to test CSS )

10 Sep 2004

Potential answer to I've got a hash of hashes how do i get my values out, that handles multilevel data containing only scalars, arrays, or hashes: (Posting, code, and sample run are now in node 390153, Answer: I've got a hash of hashes how do i get my values out )

01-02 Jul 2004

Not sure where this could/should go, but is an attempt at a JAPH using Term::ANSIScreen. Not really an obfu, and didn't know if anyone would care, but here it is. (Posting and code are now in node 371396, JAPH attempt using Term::ANSIScreen )

29 May 2004

#!/usr/bin/perl -w

use strict;
use vars
  qw($ft @filelist @typelist @spinner $bigscape $scale $index);

use File::Find;
use File::Glob qw(:glob);
use File::Type;
use GD;
use Image::GD::Thumbnail;
use Image::Size;
use Tk;
use Tk::JPEG;
use Tk::PNG;
use Tk::TIFF;
use Tk::Thumbnail;
use Tk::Stderr;

$| = 1;
my @spinner  = ( '|', '/', '-', '\\' );
my $bigscale = 10_000;
my $scale    = 100;
my $index    = 0;

my (@directories_to_search);
foreach my $dir ( ( scalar(@ARGV) > 0 ? @ARGV : '.' ) ) {
    push( @directories_to_search,
        bsd_glob( $dir, GLOB_TILDE | GLOB_ERR ) );
}
print join( "\n", @directories_to_search ), "\n\n";

$ft = File::Type->new();
find(
    { wanted => \&wanted, follow_skip => 2, no_chdir => 1 },
    @directories_to_search
);
print "\n";

my (%images);
{
    my @templist = sort { $a cmp $b } @filelist;
    @filelist = @templist;
}

foreach ( 0 .. $#filelist ) {
    next unless ( length($_) );
    my ( $x, $y ) = imgsize( $filelist[$_] );
    printf "[%4d, %4d] %30s %s\n", $x, $y, $typelist[$_],
      $filelist[$_];
}

my $mw      = MainWindow->new();
my $stderrw = MainWindow->new->InitStderr;
$mw->title($0);

{
    my (@imagelist);
    foreach ( 0 .. $#filelist ) {
        print $filelist[$_], "\n";
        my $temp = $mw->Photo( -file => $filelist[$_] );
        push( @imagelist, $temp );
    }
    eval {
        my $thumb = $mw->Thumbnail(
            -images  => [@imagelist],
            -ilabels => 1
        )->pack;
    };
    warn($@) if ($@);
}

MainLoop;

sub wanted {
    &spinner;
    return unless ( -R $File::Find::dir );
    return unless ( defined($File::Find::name) );
    return unless ( -f $File::Find::name );
    return unless ( -R $File::Find::name );

    my ($type_from_file);
    eval {
        $type_from_file =
          $ft->checktype_filename($File::Find::name);
        printf "Unknown type: %s\n", $File::Find::name
          unless ( defined($type_from_file) );

    };

    return unless ( defined($type_from_file) );

    if ( $type_from_file =~ m/image/ ) {
        push( @filelist, $File::Find::name );
        push( @typelist, $type_from_file );
    }
}

sub spinner {
    print $spinner[ ( $index++ / $scale ) % 4 ], "\b";
    print '.' unless ( $index % $bigscale );
}
[download]

(< 27 May 2004)

An *UNTESTED* attempt to add a method to add data to a CGI::Persistent object that is not in the inherited CGI.pm query string. Assumes user has already handled converting the value to be stored into some form of string, and that user will handle the conversion back as well.

package CGI::Persistent::Nonquery;

require CGI::Persistent;
require Data::Dumper;
use base CGI::Persistent;
use strict;
use vars qw(@ISA $VERSION);

( $VERSION ) = '$Revision: 0.01 $' =~ /(\d+\.\d+)/;

sub add_data {

    my ( $self, $name, $value ) = @_;
    my $fn = $self->param( '.id' );
    my $po = new Persistence::Object::Simple __Fn => $fn;

    $self->param( -name => $name, -values => $po->{$name} )
    unless $name eq "__Fn";

    $po->{$name} = $value;
    $po->commit ();
    
    return $self;

}

"True Value";

[download]

(< 27 May 2004)

#
# $nonetwork, $nogateway, and $nobroadcast sent as 0 if to be 
# displayed in list, 1 if to be removed 
# (gateway assumed at start of block)
#
sub print_inblock {
   my ($block, $cidr, $nonetwork, $nogateway, $nobroadcast) = @_;
   my $machines = 2**(32 - $cidr);
   my $lip = unpack("N", pack("C4", split(/\D/, $block, 4)));

   for (my $i = ($nonetwork + $nogateway); 
          $i < ($machines - $nobroadcast); $i++) {
       my $result = $lip + $i;
       print(join('.', unpack("C4", pack("N", $res))), "\n");
   }
}

#
# Sample call (10.0.32.0/20, do not display network, gateway, 
# or broadcast address in listing)
#
&print_inblock("10.0.32.0", 20, 1, 1, 1);

[download]

(< 27 May 2004)

Code sample attempting to help a fellow monk parse an RSS feed from Yahoo:

use strict;
use warnings;
use Data::Dumper;
use Date::Manip;
use LWP::Simple;
use XML::Simple;

# Needed on some platforms, such as Microsoft Windows
&Date_Init("TZ=CST6CDT");

# Set timeframe to display entries for (-1 day apparently goes back to
+ midnight today)
my ($truncdate, $tderr);
my $dateback = "-1 day";
$truncdate = DateCalc("today", $dateback, \$tderr);

my $xs = new XML::Simple;

# my $feedfile = 'science';
# my $ref = $xs->XMLin($feedfile);

my $feedurl = 'http://rss.news.yahoo.com/rss/science';
my $feedline = get($feedurl) or die("Couldn't open feed: $!\n");
my $ref = $xs->XMLin($feedline);

foreach my $item (@{$ref->{'channel'}->{'item'}}) {

    my $itemDate = ParseDate($item->{'pubDate'});
    if (Date_Cmp($itemDate, $truncdate) > 0) {
        foreach (qw(title link pubDate description)) {
            $item->{$_} =~ s/[\r\n]+/ /g;
            print uc($_), "\n", $item->{$_}, "\n";
        }
        print "\n";
    }
}
# print Data::Dumper->Dump([\$ref], [qw(*ref)]), "\n";
[download]

Sample output:

TITLE
Swiss Adventurer Plans Solar-Powered Flight (Reuters)
LINK
http://us.rd.yahoo.com/dailynews/rss/753/*http://story.news.yahoo.com/news?tmpl=story2&u=/nm/20031129/sc_nm/switzerland_flight_dc
PUBDATE
Sat, 29 Nov 2003 18:18:33 GMT
DESCRIPTION
Reuters - Swiss adventurer Bertrand Piccard, the first man to pilot a balloon around the world non-stop, has announced plans to circle the planet in a specially built solar-powered aircraft.

(< 27 May 2004)

*UNTESTED* diff of possible patch to Devel::Tinderclient to check if cvs update is needed
(original was renamed tinderclient.pl.original, result of 'diff -u tinderbox.pl.original tinderbox.pl')

--- tinderbox.pl.original    Mon Sep 22 11:22:53 2003
+++ tinderbox.pl    Mon Sep 22 11:41:43 2003
@@ -77,6 +77,11 @@
 
 if ($Tinderconfig::cvs) {
   Log($log,"about to cvs checkout $Tinderconfig::cvsmodule:\n");
+  system("cvs -z3 diff $Tinderconfig::cvsmodule > /dev/null");
+  if ($? == 0) {
+    Log($log,"No diff detected against current cvs.\n\n");
+    return(undef);
+  }
   Log($log,`cvs -z3 co $Tinderconfig::cvsmodule 2>&1`); # do the chec
+kout
   Log($log,"cvs checkout complete\n\n");
 }
@@ -193,4 +198,4 @@
         exit();
 }
 exec("$0");
-exit();
\ No newline at end of file
+exit();

[download]

(< 27 May 2004)

sub inblock-cidr {
  my ($block, $cidr, $target) = @_;
  my $result = 1;
  my $machinebits = (32 - $cidr);
  my $lip1 = 
    unpack("N", pack("c4", split(/\D/, $block,  4)));
  my $lip2 = 
    unpack("N", pack("c4", split(/\D/, $target, 4)));
  $result = 0    
    if (($lip1 >> $machinebits) != ($lip2 >> $machinebits));
  return($result);
} 
sub inblock-mask {
  my ($block, $mask, $target) = @_;
  my $result = 1;
  my $machinebits = 
    unpack("N", pack("c4", split(/\D/, $mask,   4)));
  my $lip1 = 
    unpack("N", pack("c4", split(/\D/, $block,  4)));
  my $lip2 = 
    unpack("N", pack("c4", split(/\D/, $target, 4)));
  $result = 0    
    if (($lip1 & $machinebits) != ($lip2 & $machinebits));
  return($result);
}
&inblock-cidr('10.0.0.0', 8, '10.13.23.42');
&inblock-mask('10.0.0.0', '255.0.0.0', '10.13.23.42');
[download]

(< 27 May 2004)

$oradbh = DBI->connect( "dbi:Oracle:" . $oracle_sid, $username, $passw
+ord, { AutoCommit => 0, PrintError => 1, RaiseError => 0 } ) or die (
+ "Oracle connection failed: " . $DBI->errstr . "\n" );
$oradbh->{LongReadLen} = 64000;
  {
    $sql_query = sprintf( "SELECT duh1, duh2, duh3, duh4 FROM table1 W
+HERE duh1=%s", $oradbh->quote($host) );
    print( $sql_query, "\n" );
    $cursor = $oradbh->prepare($sql_query) or warn( "Error preparint s
+tatement: " . $sql_query . "\nError: " . $DBI->errstr . "\n" );
    $cursor->execute or die( "Error executing statement: " . $sql_quer
+y . "\nError: " . $DBI->errstr . "\n" );
    $cursor->execute or die( "Error executing statement: " . $sql_quer
+y . "\nError: " . $DBI->errstr . "\n" );
    my @duhnfo = ();
    while ( @duhinfo = $cursor->fetch ) {
      $existingduh->{ $duhinfo[1] }{'duh1'} = $duhinfo[0];
      $existingduh->{ $duhinfo[1] }{'duh2'} = $duhinfo[2];
      $existingduh->{ $duhinfo[1] }{'duh4'} = $duhinfo[3];
  }
}
$oradbh->disconnect;
[download]

(< 27 May 2004)

Attempt at a double-forking way to make a process display something to a web page, then do something in the background longer than Apache's TimeOut value (300s in that case):

#!/usr/local/bin/perl

use CGI qw(fatalstobrowser);
use POSIX;

$| = 1;
my $q = new CGI;

print($q->redirect("read_bgtest.pl"));
close(STDOUT);
close(STDIN);

#untested code conversion from C sources
exit unless(fork());
setsid();
$SIG{'HUP'}='IGNORE';
exit unless (fork());
chdir('/'); #prevents path-specific hax
umask(0); #clear file mode creation mask

foreach (0..14) {
    foreach (0..11) {
        open(OUTF, ">> /path/to/file") or die("Can't open file for out
+put : $!\n");
        print(OUTF scalar(localtime(time())), "\n");
        close(OUTF);
        sleep(5);
    }
}
[download]

(< 27 May 2004)

Some code to show an example of making a POST call (values changed from production code)....

  use HTTP::Request::Common qw(POST);
  use LWP::UserAgent;
  my $req = POST
    'http://server/path/to/form.handling.script',
    [
      value1 => $value[0],
      value2 => $value[2],
      value3 => $value[3],
      value4 => 'add'
    ];
  my $ua   = LWP::UserAgent->new();
  my $rslt = $ua->request($req)->as_string;
[download]

(< 27 May 2004)

Some code I threw together to see if it might help out with a fellow monk's problem...

my ($k);
foreach (@body) {
    s/\s+//g;
    if (m/^(url|bpp|maxdepth|newurl|cfg)\s*=\s*(.+)/) {
        ($k, $val) = split('=', $_);
        $line{$k} = $val;
    } else {
        $line{$k} .= $val;
    }
}
@body = ();
foreach (keys(%line)) {
    push(@body, join('=', $_, $line{$_}));
}
[download]

(< 27 May 2004)

A routine I used, here temporarily to answer a question regarding Mail::Sender. My code originally tried sending in plain and html....

sub send_email {

    #
    # Code adapted from the Mail::Sendmail FAQ, located (at the time) 
+at http://alma.ch/perl/Mail-Sendmail-FAQ.htm
    #
    my ( $server, $sender, $addressee, $reply_to, $subject, $msg ) = @
+_;

    use MIME::QuotedPrint;
    use HTML::Entities;

    use Mail::Sendmail 0.75;    # doesn't work with v. 0.74!

    my ($plain);

    $boundary = "====" . time() . "====";

    %mail = (
        'SMTP'         => $server,
        'from'         => $sender,
        'to'           => $addressee,
        'reply-to'     => $reply_to,
        'subject'      => $subject,
        'content-type' => "multipart/alternative; boundary=\"$boundary
+\""
    );

    # {

    #     use HTML::TreeBuilder;

    #     my $tree = HTML::TreeBuilder->new();    # empty tree
    #     $tree->parse($msg);
    #     $tree->eof();
    #     $plain = $tree->as_text . "\n";

    # Now that we're done with it, we must destroy it.
    #     $tree = $tree->delete;
    # }
    # {
    #     use HTML::Parse;
    #     $plain = parse_html($msg)->format;
    # }

    # $html = encode_entities($msg);
    # $html =~ s/\n\n/\n\n<p>/g;
    # $html =~ s/\n/<br>\n/g;
    # $html = "<p><strong>" . $html . "</strong></p>";

    $boundary = '--' . $boundary;

    $mail{body} = <<END_OF_BODY;
$boundary
Content-Type: text/plain; charset="iso-8859-1"
Content-Transfer-Encoding: quoted-printable

$msg

$boundary--
END_OF_BODY

    sendmail(%mail) || print "Error: $Mail::Sendmail::error\n";

    # print( join ( "\n", map { $_ . ' ' . $mail{$_} } keys(%mail) ) )
+;

}
[download]

Chatterbox^?

How do I use this? | Other CB clients

Other Users^?

Others drinking their drinks and smoking their pipes about the Monastery: (8)

As of 2013-05-19 06:26 GMT

Sections^?

Information^?

Find Nodes^?

Leftovers^?

Voting Booth^?

The best material for plates (tableware) is:

Results (397 votes), past polls


We don't bite newbies here... much
	PerlMonks