use strict;
use warnings FATAL => qw( all );

use Data::Dumper;

$| = 1;

$Data::Dumper::Deepcopy = 1;
$Data::Dumper::Sortkeys = 1;

local $\ = "\n";

my @laundry_loads = (
    'cottons', 'cold water items',
    'sheets',  'uniforms',
    'clothing of the day'
);
my @laundry_tasks = ( 'wash', 'dry', 'fold' );

sub wash {
    my ( $load, $loads ) = @_;
}

sub dry {
    my ( $load, $loads ) = @_;
}

sub fold {
    my ( $load, $loads ) = @_;
}

my @progress = ( undef, undef, undef, );
my %task;
foreach my $i ( 0 .. $#laundry_tasks ) {
    $task{ $laundry_tasks[$i] } = $i;
}

while ( my $load = shift @laundry_loads or scalar keys %task ) {

    print "";

    foreach my $current_task ( reverse @laundry_tasks ) {

        if (
            not scalar @laundry_loads
            and not(defined $task{$current_task}
                and defined $progress[ $task{$current_task} ] )
          )
        {
            delete $task{$current_task};
            next;
        }

        if ( defined $progress[ $task{$current_task} ] ) {
            my $current_load = $progress[ $task{$current_task} ];
            my $activity     = qq{$current_task $current_load};
            print $activity;

            if ( $current_task eq q{wash}
                and defined $progress[ $task{$current_task} ] )
            {
            }

            if ( $current_task eq q{dry}
                and defined $progress[ $task{$current_task} ] )
            {
            }

            if ( $current_task eq q{fold}
                and defined $progress[ $task{$current_task} ] )
            {

                if ( $current_load =~
                    /sheets|uniforms|clothing of the day/ )
                {
                    my $new_load =
                      $current_load eq 'sheets'
                      ? 'laundry'
                      : $current_load;
                    print "put away $new_load";
                }
                if ( $current_load eq 'sheets' ) {
                    print 'vacuum the house';
                    print 'make the bed';
                }
                if ( $current_load eq 'uniforms' ) {
                    print 'take showers';
                }

                pop @progress;

            }
        }

    }
    if ( defined $load ) {
        unshift @progress, $load;
    }
    else {
        unshift @progress, undef;
    }

}

##</code><code>##

$ perl la-2.pl 2>&1


wash cottons

dry cottons
wash cold water items

fold cottons
dry cold water items
wash sheets

fold cold water items
dry sheets
wash uniforms

fold sheets
put away laundry
vacuum the house
make the bed
dry uniforms
wash clothing of the day

fold uniforms
put away uniforms
take showers
dry clothing of the day

fold clothing of the day
put away clothing of the day



##</code><code>##

perl -Mstrict -Mwarnings -MData::Dumper -MYAML -le '
my @episode = ( 
  q{The Librarians} => { 
    q{1} => [ 
      q{And the Crown of King Arthur}, 
      q{And the Sword in the Stone},
      q{And the Horns of a Dilemma},
      q{And Santa&quot;s Midnight Run}, 
    ], 
    q{2} => [ 
      q{And the Apple of Discord}, 
      q{And the Fables of Doom}, 
      q{And the Rule of Three}, 
    ], 
    q{3} => [ 
      q{And the Heart of Darkness}, 
      q{And the City of Light}, 
      q{And the Loom of Fate}, 
    ], 
  }, 
); 
YAML::DumpFile( q{test.yml}, \@episode, ); 

my @stories = YAML::LoadFile( q{test.yml} ); 
print Data::Dumper->Dump( 
    [ \@episode, \@stories, ], 
    [ qw( *episode *stories ) ] 
);
'
##</code><code>##

git clone ssh://user@githost/git/foo
cd foo
#Work to files in the repository
##</code><code>##

git log file.txt
git log --follow file.txt
git log --follow -C -M file.txt
##</code><code>##

git log --graph
git log --graph --oneline
git log --graph --pretty=format':%C(yellow)%h%Cblue%d%Creset %s %C(white) %an, %ar%Creset'
##</code><code>##

git mv new-file-2.pl new-file.pl
git commit -m "new-file.pl: Rename file from new-file-2.pl."
##</code><code>##

git rm --cached new-file-3.pl
git commit -m "new-file-3.pl: Remove file from Git repository (but leave in directory)."
##</code><code>##

git rm new-file-4.pl
git commit -m "new-file-4.pl: Remove file from Git repository."
##</code><code>##

git config --global user.name  "John Doe"
git config --global user.email 'jdoe@example.com'
##</code><code>##

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

# vim:set expandtab shiftwidth=4 softtabstop=2 tabstop=4:

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

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