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;

##</code><code>##

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;

##</code><code>##

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;

##</code><code>##

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

##</code><code>##

#!/usr/bin/perl

use strict;
use warnings;

use Getopt::Long;

$| = 1;

my @filename;
my %color = ( same => q{#000000}, file1 => q{#FF0000}, file2 => q{#0000FF}, );
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}, $color->{ ( $state ? q{file1} : q{same} ) }, $e1;
                $out2 .= sprintf qq{</font><font color="%s">%s}, $color->{ ( $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; parameter 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 differing
        portions. Written in #RRGGBB format. (default values are #000000,
        #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
}


##</code><code>##

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

##</code><code>##

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

##</code><code>##

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

##</code><code>##

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

##</code><code>##

$ 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}"

##</code><code>##

#!/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 for append: $!\n});
    close(DF);
}

my $dbh = DBI->connect( qq{dbi:SQLite:dbname=$datafile}, q{}, q{}, { AutoCommit => 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 XML 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 0x%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]{author},  $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__


##</code><code>##

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

##</code><code>##

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;

##</code><code>##

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;

##</code><code>##

#
# 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 methods.\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 methods.\n");
    }
}

1;

##</code><code>##

#!/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/wpr/floorplans/bldgid/BDLK11/BDLK11-AFP-1.pdf target=_blank><img 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"> ServerClock(); </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/BDLK11-AFP-1.pld" target="_blank">Floor 1</a><a href="http://wwwin.cisco.com/wpr/floorplans/bldgid/BDLK11/BDLK11-AFP-1.pdf" target="_blank"><img 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"> ServerClock(); </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/Transform">
        <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);

##</code><code>##

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

##</code><code>##


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


##</code><code>##

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

##</code><code>##

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

##</code><code>##

#!/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 retrievals
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;op=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);

##</code><code>##

$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.pair.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__

##</code><code>##

#!/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 => sub { 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 => 'control', -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, -columnspan => 10, -sticky => 'nsew' );

MainLoop;

##</code><code>##

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

##</code><code>##

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

Content:


##</code><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";

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

##</code><code>##

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

##</code><code>##

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


##</code><code>##

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


##</code><code>##

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

##</code><code>##

--- 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 checkout
   Log($log,"cvs checkout complete\n\n");
 }
@@ -193,4 +198,4 @@
         exit();
 }
 exec("$0");
-exit();
\ No newline at end of file
+exit();


##</code><code>##

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

##</code><code>##

$oradbh = DBI->connect( "dbi:Oracle:" . $oracle_sid, $username, $password, { 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 WHERE duh1=%s", $oradbh->quote($host) );
    print( $sql_query, "\n" );
    $cursor = $oradbh->prepare($sql_query) or warn( "Error preparint statement: " . $sql_query . "\nError: " . $DBI->errstr . "\n" );
    $cursor->execute or die( "Error executing statement: " . $sql_query . "\nError: " . $DBI->errstr . "\n" );
    $cursor->execute or die( "Error executing statement: " . $sql_query . "\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;

##</code><code>##

#!/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 output : $!\n");
        print(OUTF scalar(localtime(time())), "\n");
        close(OUTF);
        sleep(5);
    }
}

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

##</code><code>##

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

##</code><code>##

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

}