Public Scratchpad

For Lady_Aleena:

use strict;
use warnings;
use Template;

my @things = ( 'climb dog', 'darkstrike', 'protector', 'sheildbug', 'w
+atcher' );
my $table = Template->new;
$table->process( \*DATA, { things => \@things } ) or die $table->error
+, $/;

__DATA__
[%- FOREACH thing = things %]
<small>[% thing %]</small>
[%- END %]
[download]

I have been playing around with Design Patterns and MVC. This is my futzing around code, trying to not only understand MVC, but understand how certain Design Patterns fit into the MVC model. In this example, the Model is an Observer (Observer pattern), the View is both a Subject (Observer pattern) and a Composite (Composite pattern) while the Controller is Context (Strategy pattern). In all honestly, this is a complex mess of object interaction but trying to implement SIMPLE examples using Design Patterns tends to turn a blind eye to why we need such complex designs. This code uses my Design Patterns from github.

#!/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->g
+et_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 {M
+odel->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`;
[download]

Nobody ever told Lady_Aleena that you are not suppose to generate mark up this way. She has written a function for virtually every reserved word in HTML. Why she didn't use CGI.pm's generations methods is anyone's guess (and highly suspicious to boot) and we even have HTML::Tiny. Having said all that ... i present my own version of "her" HTML::Element

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>" : "<$tag$attr_txt />";
}
1;
[download]

That's right, just 17 lines of (overly terse) code. Here's a client:

use HTML::Element '!DEFAULT';
print '<!DOCTYPE html>',
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' ),
        ),
    ),
);
[download]

That took me about 30 minutes to write. Now i can go do something worthwhile ...

For Lady_Aleena:

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

Life without Perl?

/*------+---------+---------+---------+---------+---------+--------+*\
|                                                                    |
| 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;
}
[download]

for Corion

use Attribute::Handlers;

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


sub foo {
    print Dumper \@_;
}
[download]

for jimbus

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;
}
[download]

for diotalevi

#!/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
[download]

for hok_si_la

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;
[download]

Here is the module:

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 A
+DDRESS                            PRODUCT    JOB#
----------------------------------------------------------------------
+--------------------------------------------------
.
format DETAIL =
@>>>>>   @>>>>> @>>>>>>>> @>>>>>>>>  @>>>>>>>>  @>>>>>>>>>>>>>>>>>>>>>
+>>>> @>>>>>>>>>>>>>>>>>>>>>>>>>>  @>>>>>>  @>>>>>>
@FIELDS
.
format DETAIL_BOTTOM =
@>>>>>   @>>>>>
@FIELDS
.

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

1;
[download]

And here is a script to call it:

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};
[download]

testing one two three

[Mon Apr 26 08:06:25 2004]

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;
[download]

For jdtoronto:

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__
<form>
<select name="movies">
<tmpl_loop movies>
   <option value="<tmpl_var id>"><tmpl_var title></option>
</tmpl_loop>
</select>
</form>
[download]

For DigitalKitty:

use Carp;

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

It's not the fastest, but works with strict and it's fast enough for my needs. ;)

Note that this snippet has two problems:

it does not allow you to capture multiple parameters that have the same name, such as foo=bar&foo=baz&foo=qux
it does not decode encoded characters. In Perl, you could just use HTML::Entities. I am sure Java has some equivalent. Oh, by the way, this snippet is a horrible implementation of a problem that is solved much better by CGI.pm's param() method. I think Java has some class somewhere out there that solves this problem as well ... one of those crazy HTTP classes i think ...

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;
[download]

Mon Nov 17 15:46:14 2003

#!/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__
<tmpl_loop month>
<select name="month">
    <option value="<tmpl_var value>" <tmpl_if curr>selected="1"</tmpl_
+if>>
        <tmpl_var label>
    </option>
</select>
</tmpl_loop>
[download]

Mon Nov 17 15:35:36 2003

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

Sat Oct 11 10:25:58 2003

#!/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";
}
[download]

Sat Oct 11 10:24:52 2003

#!/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";
}
[download]

[Wed Sep 10 00:35:44 EDT 2003]

For sulfericacid:
Welcome to the wonderful world of RDMS's - Relational Database Management Systems. I never really bothered with DB files because i was taught SQL very shorly after learning about them. First off ... this is not easy stuff. I have been using SQL for about 4 years now and consider myself decent enough. The problem is not storing and retrieving data ... it's learning how to organize the data first.

For example, i store information about my DVD's in multiple database tables. I have one table for the DVD's themselves that contains information about that movie - it's title and release year for example. I also keep track of directors, writers, and genres. But none of that stuff belongs in the movie table - directors belongs in the directors table, and so forth. A third table is needed to join directors to the movies. Don't worry - i don't expect you to understand this just yet ... i just want you to realize that if you thought DB files were hard ... wait till you get into this stuff! But it's good that you already understand CGI and DB files - that knowledge will help.

OK! So let's try some stuff out. SSH to perlmonk.org and type the stuff in bold:

sulfericacid@perlmonk:~$ mysql -u sulfericacid -p Enter password: your password here

Welcome to the MySQL monitor. Commands end with ; or \g. Your MySQL connection id is 113558 to server version: 4.0.13-log

Type 'help;' or '\h' for help. Type '\c' to clear the buffer.

mysql> use sulfericacid; Database changed mysql> create table test(foo int, bar varchar(64)); Query OK, 0 rows affected (0.03 sec)

mysql> insert into test values(1,'foo'); Query OK, 1 row affected (0.00 sec)

mysql> insert into test values(2,'bar'); Query OK, 1 row affected (0.00 sec)

mysql> insert into test values(3,'baz'); Query OK, 1 row affected (0.00 sec)

mysql> select foo,bar from test;

+------+------+
| foo  | bar  |
+------+------+
|    1 | foo  |
|    2 | bar  |
|    3 | baz  |
+------+------+

3 rows in set (0.00 sec) mysql> select * from test; +------+------+ | foo | bar | +------+------+ | 1 | foo | | 2 | bar | | 3 | baz | +------+------+ 3 rows in set (0.00 sec) mysql> select foo,bar from test order by bar; +------+------+ | foo | bar | +------+------+ | 2 | bar | | 3 | baz | | 1 | foo | +------+------+ 3 rows in set (0.00 sec) mysql> select bar from test order by bar desc; +------+ | bar | +------+ | foo | | baz | | bar | +------+ 3 rows in set (0.00 sec) mysql> select bar from test where bar='bar'; +------+ | bar | +------+ | bar | +------+ 1 row in set (0.00 sec) mysql> select bar from test where bar like 'b%'; +------+ | bar | +------+ | bar | | baz | +------+ 2 rows in set (0.00 sec) mysql> select bar from test where foo > 1; +------+ | bar | +------+ | bar | | baz | +------+ 2 rows in set (0.01 sec)

And so on. There is a lot more - if you want to execute queries from a Perl script, you will have to learn DBI. Like i said, this is a long road, but you will like it once you learn this stuff. It is soooo much better than DB files - mainly because YOU don't have to worry about concurrency (that is, lock files). The database management system does it for you. Also, once you learn how to design tables "properly", you can decrease the size of the data that you store - but don't worry about that right now. You need to learn some basic SQL and DBI and we'll teach the rest one step at a time. ;)

This Space ...

Is for rent.

[Fri Aug 8 18:38:45 2003]

#!/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 (<IN>) {
        open OUT,'>',sprintf("%0".$length."d-%s",$i++,$file);
        print OUT;
    }
}
[download]

[Fri Aug 8 18:38:49 2003]

#!/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 <IN>;
}
[download]

Domain Nodelet^?

www.com | www.net | www.org

Chatterbox^?

How do I use this? • Last hour • Other CB clients

Other Users^?

Others browsing the Monastery: (4)

As of 2024-04-19 05:27 GMT

Sections^?

Information^?

Find Nodes^?

Leftovers^?

Today I Learned

Voting Booth^?

No recent polls found


Come for the quick hacks, stay for the epiphanies.
	PerlMonks

jeffa's scratchpad

Mon Nov 17 15:46:14 2003

Mon Nov 17 15:35:36 2003

Sat Oct 11 10:25:58 2003

Sat Oct 11 10:24:52 2003

This Space ...