use strict; use warnings; use Template; my @things = ( 'climb dog', 'darkstrike', 'protector', 'sheildbug', 'watcher' ); my $table = Template->new; $table->process( \*DATA, { things => \@things } ) or die $table->error, $/; __DATA__ [%- FOREACH thing = things %] [% thing %] [%- END %] ##

##

#!/usr/bin/perl -l
use lib '/PATH/TO/DesignPatterns-Perl/lib/';

package Model;
use Moose;
extends 'OODP::Observer';
has state => ( is => 'ro', isa => 'Num', default => 1 );
sub update {
    my ($self, $newval) = @_;
    $self->set_state( $newval );
}


package View;
use Moose;
extends 'OODP::Composite', 'OODP::Subject';
sub notify {
    my $self = shift;
    $self->SUPER::notify( @_ );
    $self->update_display;
}
sub update_display {
    my $self = shift;
    for my $child (values %{ $self->get_children }) {
        $child->update_display
    }
}

package View::FH;
use Moose;
use IO::File;
use IO::Handle;
extends 'View';
has '+name'    => ( default => 'view' );
has mode       => ( is => 'ro', isa => 'Str', default => '>' );
has filename   => ( is => 'ro', isa => 'Str' );
has filehandle => ( 
    is      => 'ro',
    isa     => 'IO::Handle',
    default => sub { IO::Handle->new_from_fd( fileno(STDOUT), 'w' ) }
);
sub BUILD {
    my $self = shift;
    if ($self->get_filename) {
        $self->{filehadle} = IO::File->new( $self->get_mode . $self->get_filename );
    }
}
sub DEMOLISH {
    my $self = shift;
    $self->get_filehandle->close if $self->get_filehandle;
    unlink $self->get_filename if $self->get_filename && -z $self->get_filename;
}
sub update_display {
    my $self = shift;
    my $fh = $self->get_filehandle;
    print $fh $_->get_state for @{ $self->get_observers };
    $self->SUPER::update_display( @_ );
}


package Controller;
use Moose;
extends 'OODP::Context';
has '+strategy' => ( handles => ['algorithm'], default => sub {Adder->new} );
has model => ( is => 'ro', handles => ['get_state'], default => sub {Model->new} );
has view  => ( is => 'ro', handles => ['notify'], default => sub {View::FH->new} );
sub BUILD {
    my $self = shift;
    $self->{view}->attach( $self->{model} )
}
sub context {
    my ($self,$val) = @_;
    $self->algorithm( $self->get_state, $val )
}
sub run {
    my $self = shift;
    $self->notify( $self->context( $_ ) ) for @_;
}

package Adder;
use Moose;
extends 'OODP::Strategy';
use Data::Dumper;
sub algorithm { $_[1] + $_[2] }

package Subtractor;
use Moose;
extends 'OODP::Strategy';
sub algorithm { $_[1] - $_[2] }


package main;
use Data::Dumper;
use IO::File;

Controller->new( strategy => Subtractor->new )->run( 1 .. 10 );

Controller->new(
    view => View::FH->new(
        filename => 'out.txt',
        mode => '>>'
    )
)->run( 1 .. 10 );
print `cat out.txt`;

Controller->new(
    strategy => Subtractor->new,
    view => View::FH->new(
        filename => 'out.txt',
        mode => '>>'
    )
)->run( 1 .. 10 );
print `cat out.txt`;
print `rm out.txt`;

##

##

package HTML::Element;
use strict;
use warnings;
use Exporter 'import';
our @EXPORT = qw( html head title body h1 p br table Tr td );
our $AUTOLOAD;
sub new { bless {}, shift }
sub AUTOLOAD {
    my $self = ref($_[0]) eq __PACKAGE__ ? shift : undef;
    my $attr = ref($_[0]) eq 'HASH' ? shift : {};
    my $tag  = $AUTOLOAD =~ s/.*:://r;
    my $attr_txt = '';
    $attr_txt .= qq( $_="$attr->{$_}") for keys %$attr;
    return @_ ? "<$tag$attr_txt>@_" : "<$tag$attr_txt />";
}
1;

##

##

use HTML::Element '!DEFAULT';
print '',
html(
    head(
        title("some html")
    ),
    body(
        h1( "some headline" ),
        p( {class => 'foo'}, "yadda yadda", br(), "more yadda" ),
        p( {class => 'bar'}, "yadda yadda yadda" ),
        table( {summary => 'table', border => 1},
            Tr( map td($_), 'a' .. 'f' ),
            Tr( map td($_), 'g' .. 'l' ),
            Tr( map td($_), 'm' .. 'r' ),
            Tr( map td($_), 's' .. 'x' ),
        ),
    ),
);

##

##

#!/usr/bin/env perl 

use strict;
use warnings;
use LWP::Simple;
use HTML::TableExtract;

my $html = get( 'http://en.wikipedia.org/wiki/Kool-Aid' );
my $te   = HTML::TableExtract->new( depth => 0, count => 1 );
$te->parse($html);

#my @flavors;
my %flavors;
for my $ts ($te->tables) {
    #push @flavors, split( /\s*,\s*/, $_->[1] ) for $ts->rows;
    for ($ts->rows) {
        $flavors{$_}++ for split( /\s*,\s*/, $_->[1] );
    }
}

#print $_,$/ for @flavors;
print $_,$/ for sort keys %flavors;

##

##

/*------+---------+---------+---------+---------+---------+--------+*\
|                                                                    |
| Function:   toInt                                                  |
|    Input:   base to convert by (default is 10)                     |
|   Output:   int                                                    |
|  Purpose:   This function returns the integer value of the string. |
|             It can be used for binary, decimal, octal, and hex.    |
|                                                                    |
\*------+---------+---------+---------+---------+---------+--------+*/
int String::toInt(int base) {

    int intValue = 0;

    if (base != 2 && base != 8 && base != 10 && base != 16)
        return 0;

    if (base == 16)
        toUpper();

    for (int i = 0; i < length; i++) {

        intValue *= base;

        if(base == 16 && data[i] >= 'A' && data[i] <= 'F') {

            intValue += (data[i] - 'A' + 10);
        }
        else
            intValue += (data[i] - '0');
    }

    return intValue;
}




/*------+---------+---------+---------+---------+---------+--------+*\
|                                                                    |
| Function:   toFloat                                                |
|    Input:   void                                                   |
|   Output:   float                                                  |
|  Purpose:   This function returns to float value of the string.    |
|                                                                    |
\*------+---------+---------+---------+---------+---------+--------+*/
float String::toFloat() {

    //Local Variables
    int i = 0;
    float floatValueLeft = 0;
    float floatValueRight = 0;

    while (data[i] != '.' && data[i] != '\0') {

        floatValueLeft *= 10;
        floatValueLeft += (data[i] - '0');

        i++;
    }

    if (data[i] != '\0') {

        i = length - 1;

        while (data[i] != '.') {

            floatValueRight /= 10;
            floatValueRight += (data[i] - '0');

            i--;
        }
        floatValueRight /= 10;
    }

    return floatValueLeft + floatValueRight;
}

##

##

use Attribute::Handlers;

sub myfoo : attr {
    print Dumper \@_;
};


sub foo {
    print Dumper \@_;
}

##

##

sub new {
  my $class = shift;
  my $report = shift || "default";
  my $system = shift || "none";

  my $self = {
     logType   => "both",
     fileSize  => 100000000,
     fileExt   => ".log",
     filePath  => "/tmp/",
     fileCount => 3,
     dbAgeSize => 1,
     dbAgeUnit => "DAY",
     dbConnStr => 'dbi:mysql:reports:localhost',
     dbUser    => "scott",
     dbPasswd  => "tiger",
     status    => "testing",
     entry     => "",
     system    => $system,
     name      => $report,
  };

  $self->{fileName} = $self->{filePath} . $report . $log->{fileExt};

  return bless $self, $class;
}

##

##

#!/usr/bin/perl -w

use strict;
use MP3::Info;
use Getopt::Long;

use vars qw($tag $value);

my %value;
my $flag;
my @field = qw(title artist album year comment genre tracknum);
@value{@field} = ('') x @field;

GetOptions(map { $_.'=s',\$value{$_} } keys %value);

my $file = shift or USAGE() and exit;
my $tag  = get_mp3tag($file) or warn "no ID3 tag for '$file'";

for (keys %value) {
    next unless $value{$_};
    $tag->{uc $_} = $value{$_};
    $flag = 1;
}

set_mp3tag($file,$tag) if $flag;
write_tag($tag);

sub write_tag {
    my %tag = %{+shift};
    write while ($tag,$value) = each %tag;
}

sub USAGE {
    print "USAGE: $0 [options] file\noptions:\n";
    print map { "\t-$_\n" } @field;
}

format STDOUT =
   @<<<<<<<<<<  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$tag,$value
.

__END__
=pod

=head1 NAME

id3_tweaker.pl - MP3::Info script

=head1 DESCRIPTION

This is a simple script that uses MP3::Info to alter the
a single ID3 tag fields or multiple ID3 tag fields. There
is no -help or -h option, just run the script by itself
for the USAGE.

=head1 SYNOPSIS

  for *nix:
    ./id3_tweaker.pl -year='1984' foo.mp3
  for win32:
    perl id3_tweaker.pl -year='1984' foo.mp3

  or run with the only argument being the file:
    ./id3_tweaker.pl foo.mp3

  retrieve list of tags that can be altered:
    ./id3_tweaker.pl

=cut


##

##

use strict;
use warnings;
use Data::Dumper;

my @array = (1..5, 8..10, 15..30, 35..40);
my @bucket;

my $j = 0;
for my $k (0 .. $#array) {
    if ($array[$k] == $array[$k+1] - 1) {
        push @{ $bucket[$j] }, $array[$k];
    }
    else {
        $j++;
    }
}

my @ip = (sort { $#$b <=> $#$a } @bucket)[0];
print Dumper \@ip;

##

##

package DMML;

use strict;
use warnings;
use DBI;
use Data::Dumper;

our (@FIELDS,$OUTPUT);

sub new {
	my $class = shift;
	my $self  = {};
	return bless $self, $class;
}

sub detail_report {
	my $self = shift;
	open DETAIL, '>', \$OUTPUT or die $!;

	return $self->write_report(format => 'DETAIL', @_);
}

sub summary_report {
	my $self = shift;
	open SUMMARY, '>', \$OUTPUT or die $!;

	return $self->write_report(format => 'DETAIL', @_);
}



sub write_report {
	my $self = shift;
	my %args = @_;

	$~ = $args{format};

	for (@{ $args{records} }) {
		@FIELDS = @$_;	
		write;
	}

	$~ = $args{format} . '_BOTTOM';
	@FIELDS = @{ $args{total} };
	write;

	return $OUTPUT;
}

format DETAIL_TOP =
 COUNT   #PAGES   FIRST     LAST      MEMBER#                 POSTAL ADDRESS                            PRODUCT    JOB#
------------------------------------------------------------------------------------------------------------------------
.
format DETAIL =
@>>>>>   @>>>>> @>>>>>>>> @>>>>>>>>  @>>>>>>>>  @>>>>>>>>>>>>>>>>>>>>>>>>> @>>>>>>>>>>>>>>>>>>>>>>>>>>  @>>>>>>  @>>>>>>
@FIELDS
.
format DETAIL_BOTTOM =
@>>>>>   @>>>>>
@FIELDS
.

format SUMMARY_TOP =
FormType                  #Kits     #Pages
------------------------------------------
.
format SUMMARY =
@<<<<<<<<<<<              @>>>>>    @>>>>>
@FIELDS
.
format SUMMARY_BOTTOM =
==========================================
@<<<<<<<<    @<<<<       @>>>>>>   @>>>>>>
@FIELDS
.

1;

##

##

use strict;
use warnings;
use DMML;
use Data::Dumper;

my $dmml = DMML->new;

my @field = (([1..9]) x 10);
my @total = (1,2);

my $output = $dmml->detail_report(
	records => \@field,
	total   => \@total,
);

print Dumper $dmml->{OUTPUT};

##

##

package DVD::director_movie;
use base qw(DVD::DBI);

__PACKAGE__->table('director_movie');
__PACKAGE__->columns(Primary => qw/movie director/);
__PACKAGE__->has_a(movie => 'DVD::movie');
__PACKAGE__->has_a(director => 'DVD::director');

__PACKAGE__->add_trigger(after_delete => sub {
        $_[0]->director->delete unless $_[0]->director->movies;
});

1;

##

##

use DBI;
use HTML::Template;

my $dbh = DBI->connect(...);
my $sth = $dbh->prepare('select id,title from movie');
$sth->execute;

my $movies   = $sth->fetchall_arrayref({});
my $template = HTML::Template->new(filehandle => \*DATA);

$template->param(movies => $movies);
print $template->output;

__DATA__




##

##

use Carp;

sub AUTOLOAD {
    my ($self) = @_;
    $AUTOLOAD =~ /.*::(\w+)/ && exists $self->{$1} and return $self->{$1};
    croak "No such attribute: $1";
}

##

##

use strict;
use warnings;
use Data::Dumper;

my $str = 'foo=bar&baz=qux&one=1&two=2';
my %hash;
my @pair = split '&',$str;

for my $pair (@pair) {
   my ($key,$val) = split '=',$pair;
   $hash{$key} = $val;
}

print Dumper \%hash;

##

##

#!/usr/bin/perl

use strict;
use warnings;
use Time::Piece;
use HTML::Template;

my $time     = localtime;
my $curr_mon = $time->_mon;
my @month    = $time->mon_list;

my $tmpl = HTML::Template->new(filehandle => \*DATA);
$tmpl->param(month => [
	map {
		value => $_,
		label => $month[$_],
		curr  => $curr_mon == $_,
	}, 0..$#month
]);

print $tmpl->output;

__DATA__




##

##

#!/usr/bin/perl

use strict;
use warnings;
use Time::Piece;
use CGI qw(popup_menu);

my $time     = localtime;
my $curr_mon = $time->_mon;
my @month    = $time->mon_list;
my %label    = map {($month[$_] => $_)} 0..$#month;

print popup_menu(
	-name     => 'month',
	-values   => \@month,
	-default  => $month[$curr_mon],
	-labels   => \%label,
);


##

##

#!/usr/bin/perl

use strict;
use warnings;

our $var = 5;

increment_me($var) for 1..10;
decrement_me($var) for 1..5;
print_me($var);

sub increment_me {
	$var = shift;
	$var++;
}

sub decrement_me {
	$var = shift;
	$var--;
}

sub print_me {
	$var = shift;
	print "$var\n";
}

##

##

#!/usr/bin/perl

use strict;
use warnings;

my $var = My::Number->new;

$var->increment_me for 1..10;
$var->decrement_me for 1..5;
$var->print_me;


package My::Number;
sub new {
	my $class = shift;
	my $self  = { var => 0};
	return bless $self, $class;
}

sub increment_me {
	my $self = shift;
	$self->{var}++;
}

sub decrement_me {
	my $self = shift;
	$self->{var}--;
}

sub print_me {
	my $self = shift;
	print $self->{var},"\n";
}

##

##

#!/usr/bin/perl

use strict;
use warnings;

my $file   = shift;
my $chunk  = 2**22;  # two megs
my $total  = -s $file;
my $length = length(int($total/$chunk));

open IN, $file or die $!;
{
	local $/ = \$chunk;
	my $i    = 0;
	while () {
		open OUT,'>',sprintf("%0".$length."d-%s",$i++,$file);
		print OUT;
	}
}

##

##

#!/usr/bin/perl

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

my $file  = 'bigfile.txt';
my @files = File::Find::Rule
	->file()
	->name( qr/^\d+-$file\Z/)
	->in( '.' )
;

open OUT, '>', "new_$file" or die $!;
for (sort @files) {
	open IN, $_;
	print OUT while ;
}