HomePage

  Have Fun!
  - ScottWalters 

SoftwareQualityLevels

AboutPerl

AboutObjects

AboutPatterns

AboutFlack

PlanningIsNpComplete

InnerClasses

  package WebsafeColors;

  sub new { ... };

  sub getIterator {
    my $parentThis = shift;
    return eval {
      package WebsafeColors::Iterator;
      # this mini sub-package only knows how to iterate over our data structure
      @ISA=(Iterator);
      sub new {
        my $type = shift;
        my $this = { currentIndex=>0 };
        bless $this, $type;
      }
      sub hasNext {
        my $this = shift;
        return @{$parentThis->{'colors'}} > $this->{'currentIndex'};
      }
      sub getNext {
        my $this = shift;
        die unless $this->hasNext();
        return $parentThis->{'colors'}->[$this->{'currentIndex'}++];
      }
      __PACKAGE__;
    }->new();
  }

  # there should be two underscores on either side of PACKAGE. TinyWiki is having a bug. sorry.

AggregatePattern

  my $subtotal;
  foreach my $item (@cart) {
    $subtotal += $item->query_price();
  }

  my $weight;
  foreach my $item (@cart) {
    $weight += $item->query_weight();
  }

  # and so on

  package Cart::Basket;

  use base 'Cart::Item';

  sub query_price {
    my $self = shift;
    my $contents = $self->{contents};
    foreach my $item (@$contents) {
    }
  }

  sub add_item {
    my $self = shift;
    my $contents = $self->{contents};
    my $item = shift; $item->isa('Cart::Item') or die;
    push @$contents, $item;
    return 1;
  }

  # query_ routines:

  sub query_price {
    my $self = shift;
    my $contents = $self->{contents};
    my $subtotal;
    foreach my $item (@$contents) {
      $subtotal += $item->query_price();
    }
    return $subtotal;
  }

  sub query_price {
    my $self = shift;
    my $contents = $self->{contents};
    my $weight;
    foreach my $item (@$contents) {
      $weight += $item->query_weight();
    }
    return $weight;
  }

ContainerPattern

  package LinkedList::Link;

  sub new { bless { prev => undef, next => undef }, $_[0]; }

  sub next { $_[0]->{next} }

  sub set_next { $_[0]->{next} = $_[1] }

  sub prev { $_[0]->{prev} }

  sub set_prev { $_[0]->{prev} = $_[1] }

DecoratorPattern

  # in a file named Taco.pm:
  
  package Taco;
  use ImplicitThis; ImplicitThis::imply();
  
  sub new { bless { price=>5.95}, $_[0]; }
  sub query_price { return $price; }
  
  # in a file named TacoWithLettuce.pm:
  
  package TacoWithLettuce;
  use ImplicitThis; ImplicitThis::imply();
  @ISA = qw(Taco);
  sub query_price { return $this->Taco::query_price() + 0.05; }
  
  # in a file named TacoWithTomato.pm:
  
  package TacoWithTomato;
  use ImplicitThis; ImplicitThis::imply();
  @ISA = qw(Taco);
  sub query_price { return $this->Taco::query_price() + 0.10; }
  
  # in a file named TacoWithTomatoAndLettuce.pm:
  
  package TacoWithTomatoAndLettuce;
  use ImplicitThis; ImplicitThis::imply();
  @ISA = qw(Taco);
  sub query_price { return $this->Taco::query_price() + 0.10; }
  

  # in a file named Taco.pm:
  
  package Taco;
  use ImplicitThis; ImplicitThis::imply();
  
  sub new { 
    bless { price=>5.95, first_topping=>new Topping::BaseTaco }, $_[0]; 
  }
  sub query_price { return $first_topping->query_price(); }
  sub add_topping {
    my $topping = shift; $topping->isa('Topping') or die "add_topping requires a Topping";
    $topping->inherit($first_topping);
    $first_topping = $topping;
  }
  
  # in a file named Topping.pm:
  
  package Topping.pm;
  # this is just a marker class
  
  # in a file named Topping/BaseTaco.pm:
  
  package Topping::BaseTaco;
  @ISA = qw(Topping);
  
  sub query_price { return 5.95; }
  
  # in a file named Topping/Lettuce.pm:
  
  package Topping::Lettuce;
  @ISA = qw(Topping);
  use ImplicitThis; ImplicitThis::imply();
  sub query_price { return 0.05 + $this->SUPER::query_price(); }
  sub inherit { my $parent = shift; unshift @ISA, $parent; return 1; }
  
  # and so on for each topping...
  

  # in a file named Taco.pm:
  
  package Taco;
  use ImplicitThis; ImplicitThis::imply();
  
  sub new { bless { price=>5.95, top_topping=>new Topping::BaseTaco }, $_[0]; }
  sub query_price { return $price; }
  sub add_topping {
    my $new_topping = shift;
    # put the new topping on top of existing toppings. this new topping is now our top topping.
    $new_topping->top($top_topping);
    $top_topping = $new_topping;
    return 1;
  }
  
  # in a file named Topping.pm:
  
  package Topping.pm;
  use ImplicitThis; ImplicitThis::imply();
  
  sub new {
    my $type = shift;
    bless { we_top=>undef }, $type;
  }
  
  sub top { 
    my $new_topping = shift; $new_topping->isa('Topping') or die "top must be passed a Topping";
    $we_top = $new_topping; 
    return 1; 
  }
  
  # in a file named Topping/BaseTaco.pm:
  
  package Topping::BaseTaco;
  @ISA = qw(Topping);
  sub query_price { return 5.95; }
  
  # in a file named Topping/Lettuce.pm:

  package Topping::Lettuce;
  use ImplicitThis; ImplicitThis::imply();
  @ISA = qw(Topping);
  sub query_price { return 0.05 + ($we_top ? $we_top->query_price() : 0); }
  

ProxyPattern

  package GenericProxy;

  sub new {
    my $type = shift;
    my $this = { };
    my $obj = shift; ref $obj or die;
    $this->{'obj'} = $obj;
    $type .= '::' . ref $obj;
    # copy inheritance info.
    @{ref($this).'::ISA'} = @{ref($obj).'::ISA'};
    bless $this, $type;
  }

  # bug XXX - autoload is only used after @ISA is searched!

  sub AUTOLOAD {
    my $this = shift;
    (my $methodName) = $AUTOLOAD m/.*::(\w+)$/;
    return if $methodName eq 'DESTROY';
    $this->{'obj'}->$methodName(@_);
  }

AdapterPattern

FacadePattern

ResultObject

  $foo->do($arg, $str, $bleah, $blurgh);

VisitorPattern

  foreach my $class ( qw(NAME SYNOPSIS CODE) ) {
          no strict 'refs';
          push @{ "POD::${class}::ISA" }, "POD::POD";
  }

  package Taco::Topper;

  sub top_taco { 
    my $self = shift;
    die "we're an abstract class, moron. use one of our subclasses" if ref $self eq __PACKAGE__;
    die "method strangely not implemented in subclass";
  }

  sub new {
    my $class = shift;
    bless [], $class;
  }

  package Taco::Topper::Beef;

  sub top_taco {
    my $self = shift;
    my $taco = shift;
    if($taco->query_flags()) {
       die "idiot! the beef goes on first! this taco is ruined!";
    }
    $taco->set_flags(0xdeadbeef);
    $taco->set_cost($taco->query_cost() + 0.95);
  }

  package Taco::Topper::Cheese;

  sub top_taco {
    my $self = shift;
    my $taco = shift;
    if(! $taco->query_flag(0xdeadbeef) and ! $taco->query_flag(0xdeadb14d)) {
      # user is a vegitarian. give them a sympathy discount because we feel
      # bad for them for some strange reason, even though they'll outlive us by 10 years
      $taco->set_cost($taco->query_cost() - 1.70);
    }
    $taco->set_flags(0xc43323);
    $taco->set_cost($taco->query_cost() + 0.95);
  }

  package Taco::Topper::Gravy;

  # and so on...

  $topping_counter->get_cheese_gun()->top_taco($self);

ClassAsTypeCode

  # using TypeSafety:

  sub set_day {
    die unless $_[0]->isa('Day');
    $day = shift;
    return 1;
  }

  # using a plain old hash:

  sub set_day {
    die unless exists $daysref->$_[0];
    $day = shift;
    return 1;
  }

  
  package Day;
  
  use ImplicitThis; ImplicitThis::imply();

  $mon = new Day 'mon';
  $tues = new Day 'tues';

  my @days;

  sub new { 
    die unless caller eq __PACKAGE__;
   my $me = { id=>$_[1] }
    bless $me, $_[0];
    push @days, $me;
    return $me;
  }

  sub get_id { return $id };

  sub get_days { return @days; }

  # in Apopintment.pm:
  
  package Appointment;
  
  my $day;

  sub set_day {
    die unless $_[0]->isa('Day');
    $day = shift;
    return 1;
  }
  

  $mon eq $mon;        # true
  $mon eq $tues;       # false

StatePattern

  package Pocket::Computer;

  sub record_audio {
    # implemented in some subclasses but not others
  }

  sub take_a_memo {
    # that we can do
  }

  sub make_a_call {
    die "don't know how, and the FCC would have a cow";
  }

  package Pocket::Phone;

  sub record_audio {
    # some do, some don't. most don't.
  }

  sub take_a_memo {
    die "i'm not a PDA";
  }

  sub make_a_call {
    # this we can do
  }

MomentoPattern

  package Memento;
  
  sub new {
    my $type = shift;
    my %opts = @_;
    die __PACKAGE__ . " requires an object passed on its constructor: new Memento object=>\$obj"
      unless $opts{'object'};
    my $this = { object=>$opts{'object'}, checkPoint=>undef };
    bless $this, $type;
  }
  
  sub mementoCheckPoint {
    my $this = shift;
    $this->{'checkPoint'} = $this->deepCopy($this->{'object'});  
  }
  
  sub mementoRestore {
    my $this = shift;
    $this->{'object'} = $this->{'checkPoint'};
  }
  
  sub AUTOLOAD {
    my $this = shift;
    (my $method) = $AUTOLOAD =~ m/.*::(\w+)$/;
    return if $method eq 'DESTROY';
    return $this->{'object'}->$method(@_);
  }
  
  sub deepCopy {
    my $this = shift;
    my $ob = shift;
    die unless caller eq __PACKAGE__; # private
    return $ob if(!ref $ob);
    if(ref $ob eq 'SCALAR') {
      my $value = $$ob; return \$value;
    }
    if(ref $ob eq 'HASH') {
      my %value = %$ob; return \%value;
    }
    if(ref $ob eq 'ARRAY') {
      my @value = @$ob; return \@value;
    }
    # FILEHANDLE, GLOB, other cases omitted
    # assume its an object based on a hash
    # XXX man perlfunc say that $ob->isa('HASH') works...?
    my $type = ref $ob;
    my $newself = { };
    foreach my $i (keys %$ob) {
      $newself->{$i} = $this->deepCopy($ob->{$i});
    }
    return $newself;
  }

SingletonPattern

  package MountRushmore; 
  
  my $oneTrueSelf;
  
  sub new {
    if($oneTrueSelf) {
      return $oneTrueSelf;
    } else {
      my $type = shift;
      my $this = {presidents => 
        ['George Washington', 'Thomas Jefferson', 'Theodore Roosevelt', 'Abraham Lincoln']
      };
      $oneTrueSelf = bless $this, $type;
      return $this->new();
    }
  }
  
  sub someMethod { ... }

CurryingConcept

  package Roulette::Table;

  sub new {

    my $class = shift;
    my $this;

    # if new() is called on an existing object, we're providing additional
    # constructors, not creating a new object

    if(ref $class) {
      $this = $class;
    } else {
      $this = { };
      bless $this, $class;
    }

    # read any number of and supported type of arguments

    foreach my $arg (@_) {
      if($arg->isa('Roulette::Color')) {
        $this->{'color'} = $arg;
      } elsif($arg->isa('Roulette::Number')) {
        push @{$this->{numbers}}, $arg;
      } elsif($arg->isa('Money')) {
        if($this->{money}) {
          $this->{money}->combine($arg);
        } else {
          $this->{money} = $arg;
        }
      }
    }

    return $this;

  }

  sub set_color { new(@_); }
  sub add_number { new(@_); }
  sub add_wager { new(@_); }

  package Roulette::Table;

  use MessageMethod;

  sub new {
    my $class = shift;
    my $this;
    my $curry;

    bless $this, $class;
    
    $curry = MessageMethod sub {

        my $msg = shift;

        if($msg eq 'spin_wheel') {
          die "Inconsistent state: not all arguments have been specified";
        }

        if($msg eq 'set_color') {
          $this->{'color'} = shift;
        } 

        if($msg eq 'add_number') {
          $this->{'numbers'} ||= [];
          my $numbers = $this->{'numbers'};
          push @$numbers, $arg;
        }

        if($msg eq 'add_add_money') {
          if($this->{'money'}) {
            $this->{'money'}->combine($arg);
          } else {
            $this->{'money'} = $arg;
          }
        }

        if($msg eq 'is_ready') {
          return 0;
        }

        if($this->{'money'} and $this->{'color'} and $this->{'numbers'}) {
          return $this;
        } else {
          return $curry;
        }
        
    };

    return $curry;

  }

  sub spin_wheel {
    # logic here...
  }

  sub is_ready {
    return 1;
  }

  sub create_roulette_table {
    my $color;
    my $money;
    my $numbers;
    return sub {
      $color = shift;
      return sub {
        $money = shift;
        return sub {
          push @$numbers, shift;
          return sub {
            # play logic here
          };
        };
      };
    };
  }

  # to use, we might do something like:

  my $table = create_roulette_table()->('red')->('500')->(8);
  $table->(); # play
  $table->(); # play again

  # or we might do something like:

  my $table_no_money = create_roulette_table()->('red')->('500');
  my $table;
  $table = $table_no_money->(100);
  $table->(); # play
  $table->(); # play again -- oops, lost everything
  $table = $table_no_money->(50);
  $table->(); # play some more
  

CloningPattern

  package Mumble;

  sub new { ... }; # standard constructor

  sub clone {
    my $self = shift;
    my $copy = { %$self };
    bless $copy, ref $self;
  };

    my $copy = { %$self };

  sub clone {
    my $self = shift;
    my $copy;
    foreach my $key (keys %$self) {
      $copy->{$key} = $self->{$key};
    }
    bless $copy, ref $self;
  }

  sub clone {
    my $self = shift;
    my $copy;
    foreach my $key (keys %$self) {
      if(ref $self->{$key}) {
        $copy->{$key} = $self->{$key}->clone(); 
      } else {
        $copy->{$key} = $self->{$key};
      }
    }
    bless $copy, ref $self;
  }

FlyweightPattern

  package FooFlyweight;

  my $objectCache;

  sub new {
    my $type = shift;
    my $value = shift;  # just a scalar
    if(exists $objectCache->{$type}->{$value}) {
      return $objectCache->{$type}->{$value};
    } else {
      my $this = { value => $value, moonPhase=>'full' };
      bless $this, $type;
      $objectCache->{$type}->{$value} = $this;
      return $this;
    }
  }

  package TinyNumberOb;

  sub new {
    my $type = shift;
    my $value = shift; # scalar value
    my $this = \$value; # scalar reference
    bless $this, $type;
  }

  sub getValue {
    my $self = shift;
    return $$self;
  }

  sub setValue {
    my $self = shift;
    $$self = shift;
    return 1;
  }

ImmutableObject

  $number->add(10);

  $number = $number->add(10);

  sub add {
    my $me = shift;
    my $newval = $$me + shift;
    return bless \$newval, ref $me;
  }

AbstractFactory

  package Car::Factory;
  
  sub create_car {
    my $self = shift;
    my $passengers = shift;
    my $topspeed = shift;
    
    return new Car::Ford if $topspeed < 100 and $passengers >= 4;
    return new Car::Honda if $topspeed < 120 and $passengers <= 2;
    return new Car::Porsche if $topspeed > 160 and $passengers <= 2;
    # etc
  }

  # in main.pl:

  package main;

  use Car::Factory;

  my $car = Car::Factory->create_car(2, 175); $car->isa('Car') or die;
  

  package Car::Factory;

  sub create_car {
    # this way we can do Car::Factory->create_car(...) or $carfactoryref->create_car(...)
    # see NewObjectFromExisting 
    my $package = shift; $package = ref $package if ref $package;
  
    my $car = new Car::GenericAmericanCar;
  
    my $kind = ucfirst(shift());
  
    push @{$kind.'::ISA'}, 'Car', 'Car::GenericAmericanCar';
  
    return bless $car, 'Car::' . $kind;

  }

 
  if ($topsped < 100 and $passengers >= 4) {
    require Car::Ford;
    return new Card::Ford ;
  }

FactoryObject

  my $factory = new FordFactory; 

  my $wifes_car = $factory->create_car(); 
  $wifes_car->isa('Car') or die; 

  # later:

  $factory = new ChevyFactory;

  my $husbands_car = $factory->create_car();
  $husbands_car->isa('Car') or die; 

RunAndReturnSuccessor

  # Non ObjectOriented:

  my $parser = do {
    my $html;             # HTML to parse
    my $tag;              # name of the current HTML tag
    my $name;             # name of current name=value pair we're working on
    my $namevalues;       # hashref of name-value pairs inside of the current tag
    my $starttag = sub {
      if($html =~ m{\G(<!--.*?-->)}sgc) {
        return $starttag;
      }
      if($html =~ m{\G<([a-z0-9]+)}isgc) {
        $tag = $1;
        $namevalues = {};
        return $middletag;
      }
      if($html =~ m{\G[^<]+}sgc}) {
        return $starttag;
      }
      return undef;
    };
    my $middletag = sub {
      if($html =~ m{\G\s+}sgc) {
        return $middletag;
      }
      if($html =~ m{\G<(/[a-z0-9]*)>}isgc) {
        $name = $1;
        return $middlevalue;
      }
      if($html =~ m{\G>}sgc) {
        $namevalues->{$name} = 1 if $name;
        return $starttag;
      }
      return undef;
    };
    my $middlevalue = sub {
      if($html =~ m{\G=\s*(['"])(.*?)\1}isgc) {
        $namevalues->{$name} = $1 if $name;
        return $middletag;
      }
      if($html =~ m{\G\s+}sgc) {
        return $middlevalue;
      }
      return $middletag;
    };
    return sub {
      $html = shift;
      return $starttag;
    };
  };

  open my $f, 'page.html' or die $!; read my $f, my $page, -s $f; close $f;

  $parser = $parser->($page);
  $parser = $parser->() while($parser);

InlineObjects

  my $ob = bless { color => 'yellow', size => 'large' }, 'GetAndSet';

  package GetAndSet;

  sub AUTOLOAD {
      my $this = shift;
      (my $method) = $AUTOLOAD =~ m/::(.*)$/;
      return if $method eq 'DESTROY';
      (my $request, my $attribute) = $method =~ m/^([a-z]+)_(.*)/;
      if($request eq 'set') {
        $this->{$attribute} = shift;
        return 1;
      }
      if(request eq 'get') {
        return $this->{$attribute};
      }
      die "unknown operation '$method'";
  }

AboutInheritance

  /*
   * If you are going to copy this file, in the purpose of changing
   * it a little to your own need, beware:
   *
   * First try one of the following:
   *
   * 1. Do clone_object(), and then configure it. This object is specially
   *    prepared for configuration.
   *
   * 2. If you still is not pleased with that, create a new empty
   *    object, and make an inheritance of this objet on the first line.
   *    This will automatically copy all variables and functions from the
   *    original object. Then, add the functions you want to change. The
   *    original function can still be accessed with '::' prepended on the name.
   *
   * The maintainer of this LPmud might become sad with you if you fail
   * to do any of the above. Ask other wizards if you are doubtful.
   *
   * The reason of this, is that the above saves a lot of memory.
   */
  

StateVsClass

  package Parrot;

  sub new {
    my $type = shift;
    my $me = { @_ };
    bless $me, $type;
  }

  sub perch {
    my $this = shift;
    $this->{perch} = shift;
    $this->{perch}->add_weight(38);
    return 1;
  }

  sub squak {
    print "Eeeeeeeeeeek!\n";
  }

  package Parrot::African;
  use base 'Parrot';
  
  sub squak {
    print "EEEEEEEEEEEEEEEEEEEEEEEEK!\n";
  }

  package Parrot::Pining;
  use base 'Parrot';

  sub perch {
    my $this = shift;
    return SUPER::perch(@_) if $this->{at_fjords};
    return undef;
  }
  
  sub squak {
    my $this = shift;
    return SUPER::squak(@_) if $this->{at_fjords};
    return undef;
  }

CommandObject

  # example of a switch style arrangement:

  sub doCommand {
    my $me = shift;
    my $cmd = shift; $cmd->isa('BleahCommand') or die;
    my $instr = $cmd->getInstructionCode();
    if($instr eq 'PUT') {
      # PUT logic here
    } elsif($instr eq 'GET') {
      # GET logic here
    }
    # etc
  }

  # example of a variable method call arrangement:
  
  sub doCommand {
    my $me = shift;
    my $cmd = shift; $cmd->isa('BleahCommand') or die;
    my $instr = $cmd->getInstructionCode();
    my $func = "process_" . $instr;
    return undef unless defined &$func;
    return $func->($cmd, @_);
  }

  # example of a variable subclass arrangement.
  # this assumes that %commandHandlers is set up with a list of object references.

  sub doCommand {
    my $me = shift;
    my $cmd = shift; $cmd->isa('BleahCommand') or die;
    my $insr = $cmd->getInstructionCode();
    my $objectRef = $commandHandlers{$instr};
    return $objectRef ? $objectRef->handleCommand($cmd, @_) : undef;
  }

  sub AUTOLOAD {
    my $me = shift;
    (my $methodName) = $AUTOLOAD m/.*::(\w+)$/;
    return if $methodName eq 'DESTROY';
    my $objectRef = $commandHandlers{$methodName};
    return $objectRef ? $objectRef->handleCommand($methodName, @_) : undef;
  }

IteratorInterface

  package Iterator;

  sub hasNext { die; }
  sub getNext { die; }

  package SampleTree;

  sub new {
    my $type = shift;
    my $this = { @_ };

    bless $this, $type;
  }

  sub getIterator {
    my $this = shift;
    return new Foo::Iterator node=>$this;
  }

  sub get_left {
    my $this = shift;
    return $this->{'leftNode'};
  }

  sub get_right {
    my $this = shift;
    return $this->{'rightNode'};
  }

  package SampleTree::Iterator;

  sub new {
    my $type = shift;
    my %opts = @_;
    my $this = {state=>0, iterator=>undef, node=>$opts{'node'};
    bless $this, $type;
  }

  sub getNext {
    my $this = shift;
    my $result;
    if($this->{'iterator'}) {
      $result = $this->{'iterator'}->getNext();
    }
    if($result) { 
     return $result;
    } elsif($this->{'state'} == 0) {
      # try the left node
      $this->{'iterator'} = $this->{'node'}->get_left();
      $this->{'state'} = 1; 
      return $this->getNext();
    } elsif($this->{'state'} == 1) {
      # try the right node
      $this->{'state'} = 2;
      $this->{'iterator'} = $this->{'node'}->get_right();
      return $this->getNext();
    } else {
       # state == 2
       return undef;
    }
  }

  # slurp everything into memory, then work on it:

  open my $file, 'dataset.cvs' or die $!;
  read $file, my $data, -s $file or die $!;
  close $file;

  foreach my $i (split /\n/, $data) {
    # process
  }

  # process as we read:

  my $process = sub {
    # process
  };

  open my $file, 'dataset.cvs' or die $!;
  while(my $record = <$file>) {
    $process->($record);
  }
  close $file;

  package RecordReader;

  use ImplicitThis;
  @ISA = qw(Interface);

  sub new {
    my $type = shift;
    my $file = shift;
    open my $filehandle, $file or die $!;
    my $me = { handle => $filehandle, next => undef };
    bless $me, $type;
  }

  sub getNext {
    return $next if defined $next;
    return <$handle>;
  }

  sub hasNext {
    return 1 if defined $next;
    $next = <$me>;
    if($next) {
      return 1; 
    } else {
      close $fh;
      return 0;
    }
  }

  $a = "aaa"; $a++; print $a, "\n"; # prints "aab"

PassingPattern

WrapperModule

  # note: no package statement

  use DBI;
  use CGI;
  use Mail::Sendmail;

  use config;

  my $userid = CGI::param('userid');
  # etc...

  # back in config.pm:

  my %config = (
    maxusers => 100,
    retriespersecond => 2,
    loglevel => 5
  );

  sub import {
    my $caller = caller;
    foreach my $i (keys %config) {
      local ${$caller.'::'.$i};
      *{$caller.'::'.$i} = $config{$i};
    }
  }

AnonymousSubroutineObjects

  package Preferences;

  sub new {
    my $class = shift;
    my %args = @_;
    bless {color=>$args{'color'}, petname=>$args{'petname'}, street=>{'street'} }, $class;
  }

  sub query_color { return $_[0]->{'color'}; }
  sub set_color { return $_[0]->{'color'} = $_[1]; }
  # other accessors here

  1;

  package main;

  $| = 1;

  print "Whats your favorite color? "; my $color = <STDIN>;
  print "Whats your pets name? "; my $petname = <STDIN>;
  print "What street did you grow up on? "; my $street = <STDIN>;

  my $foo = new Preferences (color=>$color, petname=>$petname, street=>$street);

  package main;

  $| = 1;

  sub get_preferences {
    print "Whats your favorite color? "; my $color = <STDIN>;
    print "Whats your pets name? "; my $petname = <STDIN>;
    print "What street did you grow up on? "; my $street = <STDIN>;
    return MessageMethod sub {
      my $arg = shift;
      ({
        query_color => sub { return $color; }
        set_color => sub { $color = shift; return 1; }
        # etc
      }->{$arg} || sub { die "Unknown request: $arg" })->(@_);
    };
  }

  my $ob = get_preferences();
  print $ob->get_street(), "\n";

  package MessageMethod;

  sub new {
    my $type = shift;
    return $type->new(@_) if ref $type eq __PACKAGE__;
    my $ref = shift; ref $ref eq 'CODE' or die;
    bless $ref, $type;
  }

  sub AUTOLOAD {
    my $me = shift;
    (my $method) = $AUTOLOAD =~ m/::(.*)$/;
    return undef if $method eq 'DESTROY';
    return wantarray ? ($me->($method, @_)) : scalar $me->($method, @_);
  }

  1;

  # place this code in hashclosure.pm

  # tell Perl how to find methods in this object - run the lambda closures the object contains

  sub AUTOLOAD {
      (my $method) = $AUTOLOAD =~ m/::(.*)$/;
      return if $method eq 'DESTROY';
      our $this = shift;
      if(! exists $this->{$method}) {
        my $super = "SUPER::$method";
        return $this->$super(@_);
      }
      $this->{$method}->(@_);
  } 
  
  1;

  title: "Dispatch Order"
  color: lightcyan
  manhattan_edges: yes
  edge.color: lilac
  scale: 90

  node: { title:"A" label: "$foo = new Foo(); \n$foo->bar();" }
  node: { title:"A1" label: "Foo::new()" }
  node: { title:"B" label: "Foo::AUTOLOAD()" }
  node: { title:"C" label: "$foo->{'bar'}->() runs" }
  edge: { sourcename:"A" targetname:"A1" anchor: 1}
  edge: { sourcename:"A" targetname:"B" anchor: 2}
  edge: { sourcename:"B" targetname:"C" }

  package Foo;

  sub new {

    my $class = shift;  
    my %args = @_;
    our $this;

    my $foo;
    my $bar;

    bless {

      get_foo => sub { return $foo },
      set_foo => sub { $foo = shift },
      get_bar => sub { return $bar },
      set_bar => sub { $bar = shift },

      get_foo_bar_qux => sub {
        return $this->get_foo(), $this->get_bar(), get_qux();
      },

      dump_args => sub {
        foreach my $i (keys %args) {
          print $i, '=', $args{$i}, "\n";
        }
      },

    }, $class;

  }

  sub get_qux { return 300; }

    my $class = new class sub{
        my $field = shift;
        $this->field = $field;
        $this->arrayref = [1,2,3];
        $this->hashref = {a => b, c => d};
        $this->method = sub{ return $this->field };
    };

  package BaseballPlayer::Pitcher; {
      use vars '@ISA';
      @ISA = 'BaseballPlayer';
 
      my (%ERA, %Strikeouts);
   
      sub ERA        : lvalue {$ERA        {+shift}}
      sub Strikeouts : lvalue {$Strikeouts {+shift}}
      sub DESTROY {
          my $self = shift;
          delete $ERA {$self}, $Strikeouts {$self}
      }
  }

ConstraintSystem

  package Constrain;
  
  # component - anonymous functions that exert force on each other.
  #             these are generated by various functions, much as an
  #             object in OO Perl would be created.
  
  sub new {
  
    my $type = shift;
    my $subtype = shift;

    return new Constrain::Adder(@_)     if $subtype eq 'adder';
    return new Constrain::Constant(@_)  if $subtype eq 'constant';
    return new Constrain::Probe(@_)     if $subtype eq 'prober';
    return new Constrain::Connector(@_) if $subtype eq 'connector';

    warn "Unknown Constrain subtype: $subtype";

  }
  
  package Constrain::Adder;
  
  sub new {
    my $type = shift;
  
    my $a1 = shift;         # the name of our first connector
    my $a2 = shift;         # the name of 2nd connector we are tied to
    my $sum = shift;        # the name of 3rd connector we are tied to
  
    my $obj = { a1=>$a1, a2=>$a2, sum=>$sum };
    bless $obj, $type;
  
    $a1->xconnect($obj);
    $a2->xconnect($obj);
    $sum->xconnect($obj);
  
    return $obj;
  
  }
  
  sub forgetvalue {
     my $this = shift;
  
     $a1->forgetvalue($obj);
     $a2->forgetvalue($obj); 
     $sum->forgetvalue($obj); 
     $this->set_value(undef);
  }
  
  sub setvalue {
    my $this = shift;
    local *a1 = \$this->{a1};
    local *a2 = \$this->{a2};
    local *sum = \$this->{sum};
  
    if($a1->hasvalue() and $a2->hasvalue()) {
      $sum->setvalue($a1->getvalue() + $a2->getvalue(), $this);
  
    } elsif($a1->hasvalue() and $sum->hasvalue()) {
      $a2->setvalue($sum->getvalue($sum) - $a1->getvalue($a1), $this);
  
    } elsif($a2->hasvalue() and $sum->hasvalue()) {
      $a1->setvalue($sum->getvalue() - $a2->getvalue(), $this);
    }
  }
  
  sub dump {
     my $this = shift;
     local *a1 = \$this->{a1};
     local *a2 = \$this->{a2};
     local *sum = \$this->{sum};
  
     print("a1 has a value: ", $a1->getvalue(), "\n") if $a1->hasvalue();
     print("a2 has a value: ", $a2->getvalue(), "\n") if $a2->hasvalue();
     print("sum has a value: ", $sum->getvalue(), "\n") if $sum->hasvalue();
  }
  
  package Constrain::Constant;
  
  sub new {
  
    my $type = shift;
  
    my $value = shift;     # our value. we feed this to anyone who asks.
    my $connector = shift; # who we connect to.
  
    my $obj = { value => $value, connector => $connector };
  
    bless $obj, $type;
  
    $connector->xconnect($obj);
    $connector->setvalue($value, $obj);
  
    return $obj;
  
  }
  
  sub setvalue {
    my $this = shift;
    my $value = shift; 
    $this->{connector}->setvalue($value, $this);
  }
  
  sub getvalue {
    my $this = shift;
    return $this->{value};
  }
  
  package Constrain::Probe;
  
  sub new {
  
    my $type = shift;
    my $connector = shift;
    my $name = shift;
  
    my $obj = { connector => $connector, name => $name };
    bless $obj, $type;
  
    $connector->xconnect($obj);
  
    return $obj;
  
  }
  
  sub setvalue {
    my $this = shift;
    my $name = $this->{name};
    print "Probe $name: new value: ", $this->{connector}->getvalue(), "\n";
  }
  
  sub forgetvalue {
    my $this = shift;
    my $name = $this->{name};
    print "Probe $name: forgot value\n";
  }
  
  package Constrain::Connector;
  
  sub new {
  
    my $type = shift;
    my $obj = { informant=>undef, value=>undef, dontreenter=>0, constraints=>[] };
    bless $obj, $type;
  
  }
  
  sub hasvalue {
    my $this = shift;
    return $this->{informant}; 
  }
  
  sub getvalue {
    my $this = shift;
    return $this->{value};
  }
  
  sub setvalue {
    my $this = shift;
    local *constraints = \$this->{constraints};
    my $newval = shift;
    my $setter = shift or die;
  
    return if $this->{dontreenter}; $this->{dontreenter} = 1;
  
    $this->{informant} = $setter;
    $this->{value} = $newval;
  
    foreach my $i (@$constraints) {
      $i->setvalue($newval, $this) unless $i eq $setter;
    } 
  
    $this->{dontreenter} = 0; 
  }
  
  sub forgetvalue {
    my $this = shift;
    local *constraints = \$this->{constraints};
    my $retractor = shift;
  
    if($this->{informant} eq $retractor) {
      $this->{informant} = undef;
      foreach my $i (@$constraints) {
        $i->forgetvalue($this) unless $i eq $retractor;
      }
    }
  }
  
  sub xconnect {
    my $this = shift;
    local *constraints = \$this->{constraints};
    local *value = \$this->{value};
    my $newconstraint = shift or die;
  
    push @$constraints, $newconstraint;
    $newconstraint->setvalue($value, $obj) if $value;
  
  }
  
  package main;
  
  my $a =         Constrain::Connector->new();
  my $a_probe =   Constrain::Probe->new($a, 'a_probe');
  
  my $b =         Constrain::Connector->new();
  my $b_probe =   Constrain::Probe->new($b, 'b_probe');
  
  my $c =         Constrain::Connector->new();
  my $c_probe =   Constrain::Probe->new($c, 'c_probe');
  
  my $a_b_adder = Constrain::Adder->new($a, $b, $c);
  
  my $a_const =   Constrain::Constant->new(128, $a);
  
  my $b_const =   Constrain::Constant->new(256, $b);
  

RevisitingNamespaces

  *{'ExistingPackage::new_function} = sub {
     # new accessor
  };

  sub ExistingPackage::new_function {
    # new accessor
  };

  sub ExistingPackage::new_function {
    my $self = shift;
    local *existing_var = \${ref($self) . '::existing_var'};
    # code here that uses $existing_var freely, as if it were in
    # out package scope.
    $existing_var++;
  }

  local $ExistingPackage::new_variable;

  do {
    my $oldnew = \&ExistingPackage::new;
    *ExistingPackage::new = sub {
      my $self = $oldnew->(@_);
      $self->{new_variable} = compute_value();
      $self;
    };
  };

ObjectsAndRelationalDatabaseSystems

  package DBI::Record;
  
  my $foreign_keys = {};
  
  sub import {
    # read foreign key information
    # translates a foreign column name to a table to its table
    # $foreign_keys{'FooID'} = 'Foo';
    while(my $i = shift) {
      $foreign_keys{$i} = shift;
    }
  }
  
  sub new {
    my $type = shift; $type = ref $type if ref $type;
    my $me = { };
    my $usage = 'usage: new DBI::Record $dbh, $sql | ($sth, $sth->fetchrow_hashref())';
    my $dbh = shift; ref $dbh or die $usage;
    my $rs = shift; my $sth; my $sql;
    die $usage unless @_;
    if(ref $_[0]) { 
      $sth = shift;
      $rs = shift or $rs = $sth->fetchrow_hashref();
    } else {
      $sql = shift;
      $sth = $dbh->prepare($sql); $sth->execute(); $rs = $sth->fetchrow_hashref();
    }
    $me->{'database_handle'} = $dbh;
    $me->{'record_set'} = $rs;
    $me->{'statement_handle'} = $sth;
    # generate accessors
    foreach my $i (keys %$rs) {
      *{$i} = sub {
        my $me = shift;
        my $sth = $dbh->prepare("select * from $foreign_keys{$i} where $i = $rs->{$i}");
        $sth->execute();
        my $newrs = $sth->fetchrow_hashref;
        return $me->new($dbh, $newrs, $sth); 
      }
    }
    bless $me, $type;
  }
  
  sub next {
    my $me = shift;
    my $sth = $me->{'statement_handle'} or return undef;
    my $newrs = $sth->fetchrow_hashref() or return undef;
    return $me->new($me->{'database_handle'}, $sth, $newrs);
  }
  
  package main;
  
  use DBI::Record
    CustomerID => Customers,
    BillID => Bills;
  
  use DBI;
  
  my $dbh = DBI->connect("DBI:Pg:dbname=geekpac", 'ingres', '') or die $dbh->errstr;
  
  my $customer = new DBI::Record $dbh, "select * from Users limit 1";
  
  my $bill = $customer->BillID();
  while($bill) {
    print $bill->{'BillID'}, " ", $bill->{'Amount'}, "\n";
    $bill = $bill->next();
  }

SelfJoiningData

  select self1 as foo, self2 as bar
  from   self as self1,
         self as self2
  where  self1.name = self2.param

  foreach my $i (keys %hash) {
    if(exists $hash{$i} and exists $hash{$hash{$i}}) {
      push @results, [$i, $hash{i}, $hash{$hash{$i}}];
    }
  }

  select  p1.value as email,
          p2.value as name,
          p3.value as gender
  from    form
          parameters as p1,
          parameters as p2,
          parameters as p3
  where   form.formid = ?
  and     p1.formid = form.formid
  and     p1.name = 'email'
  and     p2.formid = form.formid
  and     p2.name = 'name'
  and     p3.formid = form.formid
  and     p3.name = 'gender'

  select emails.email   as email, 
         names.name     as name, 
         genders.gender as gender
  from   forms, emails, names, genders
  where  forms.formid  = ?
  and    forms.nameid   = names.nameid
  and    forms.emailid  = emails.emailid
  and    forms.genderid = gender.genderid

  <TakeFive> Juerd: I think I'm going to go with multiple tables after all.
             It will save me headaches in the future.
             And I can pull them (assuming the 'header' record is in %h) with:
             "select value from $h{datatype} where id = $h{id} order by sequence"

  <Juerd> subqueries, subqueries, subqueries, joins.
          subqueries, subqueries, subqueries, joins.

  <TakeFive> :)

  <Juerd> Ideally, you don't use a query just to have enough information to do the next

  <scrottie> Except for meta applications like database admins, usually you 
             don't want a variable table name.
 
  <Juerd> That is correct.
          Same goes for column names.

  <Juerd> TakeFive: Think symbolic references

  <scrottie> If all of your things are of essentially of the same type, put atleast
             the parts of them that describe the primary key in one table. You
             can always OutterJoin a lot of other tables, so you get kind of an 
             ObjectOriented like thing going on - everything "is a" foo, but 
             you have some MixIns going on as well.
             Not that MixIns are encouraged in OO, but it is kind of the same idea.

  <TakeFive> scrottie: the problem is (going back to the oceanographic implementation)
             right now, with the dataset I have, all the actual data is floating 
             point numbers --

  <scrottie> i've always said we should dump our problems in the ocean =)

  <TakeFive> salinities, depths, current speeds and such.
             but now i've been told i need to support character fields, 
             latitude/longitude pairs, and timestamps, and ultimately, I'll
             need to be able to generate pictures of buoys as they float, or 
             purely text output.
             If I use a single table, I'll always have to check what kind of data 
             I have.

  <scrottie> n:1 relationships break out into another table,
             so if you have a bunch of buoys for one given primary record (what 
             is the primary record anyway?), then throw them all in another
             table.
             If you have an arbitrary number of other things of types that you can't 
             anticipate, you could promote everything to the same object type
             and allow recurisve references between objects ;)
             Perlers tend to write databases like that... like perlmonks's 
             codebase... but it is best not to talk of such things

  <Juerd> It's called Everything

  <scrottie> If you have a lot of different things, you can set up an attribute-value 
             pairs table. Think of HTML forms. Someone posts a form. That
             gets a record in a Posts table, lets say. it has a bunch of name value 
             pairs. Each of those gets a record in the Attribute table,
             where each record references the Posts table entry.

  <TakeFive> scrottie: ah, add a column like: "datatype" for each record.

  <scrottie> Yeah. You lose the ability to cleanly join at that point - 
             everything is nested subqueries with another self-join for each 
             (lag) record you want from Attributes. ugly. So, that way is 
             sometimes - seldom but sometimes - better. 

  <Juerd> subqueries, subqueries, subqueries, joins.

  <scrottie> Well, the value in the attribute-value pair will always be the 
             largest thing - if you're holding binary data, it will be a blob. 
             Few databases index blobs.

  <scrottie> You probably don't want SelfJoiningData, and you don't want to 
             promote all records to the same type. That leaves creating a lot
             of tables, one for each type of thing, and doing a lot of joins
             and OutterJoins. It kind of sucks, but it is powerful, and a lot
             less ugly in the end than any alternative. 
             The relation between tables is based purely on references
             between fields. Never list table names in a database as a means
             of creating references.

ManyToManyRelationship

  select count(*) as isDongle
  from   Product, Category, ProductToCategory
  where  Product.ProductID = ProductToCategory.ProductID
  and    ProductToCategory.CategoryID = Category.CategoryID
  and    Category.Name = 'Dongle'

OneToOneRelationshipsTurnIntoOneToManyRelationships

BiDirectionalRelationshipToUnidirectional

  my $output = new Output;
  my $backend = new Backend($output);
  $output->set_backend($backend);

  my $output = new Output($this);

  my $output = new Output;
  my $backend = new Backend($output->get_backend_adapter());
  $output->set_backend($backend->get_output_adapter());

  my $output = new Output($this->get_output_adapter());

NamedArguments

  sub foo {
    my %args = @_;
    my $color = $args{color};
    my $number = $args{number};
    # ...
  }
  
  foo(color=>'red', number=>13);
  
  The || operator lets you easily provide defaults and error checking:
  
  sub foo {
    my %args = @_;
    my $color = $args{color} || 'red';
    my $number = $args{number} || die 'number=> paramer required';
    # ...
  }
  
  Or, you may explicitly list the argument names and defaults, providing a self-documenting framework:
  
  sub foo {
    my %args = (
      Arg1        => 'DefaultValue',
      Blah        => 42,
      Bleh        => 60*60*24,
      Hostname    => undef,
      @_
    );
    # Handle error-checking here
    defined $args{Hostname} or die 'Required parameter "Hostname" not defined';
  }
  

PassingState

  my $context = { 
        increment    => sub { my $context = shift; $context->{sum}++; return ''; },
        currentvalue => sub { my $context = shift; return $context->{sum}; }
  };

  sub expand_macros {
    my $context = shift;
    my $text = shift;
    my $macro = qr{([A-Z][A-Z0-9]{2,})};
    $text =~ s/$macro/$context->{lc($1)}->($context)/ge;
    return $text;
  }

  expand_macros($context, "INCREMENT INCREMENT The current value is: CURRENTVALUE");

  $context->{doubleincrement} = sub { 
    my $context = shift; 
    expand_macros($context, "INCREMENT INCREMENT CURRENTVALUE"); 
  }

  expand_macros($context, "The current value is: DOUBLEINCREMENT");

FunctionTemplating

  # defining our mini language:

  # format of our macro escapes. returns the name of the macro.
  $macro = qr{([A-Z][A-Z0-9]{2,})};
  sub fetchvalue() {
    my $symbol = lc(shift());
    my $ob = shift;
    return $ob->{$symbol} if defined $ob->{$symbol};
    return $symbol->($ob) if defined &{$symbol};  # if its available as a function, recurse into it
    return $$symbol;                                              # assume its a scalar
  }

  sub createtemplate {
    my $name = shift; 
    my $text = shift;
    *{$name} = sub {
      my $ob = shift;
      my $text = $text; # private copy, so we don't ruin the original
      $text =~ s{$macro}{ fetchvalue($1, $ob); }oges;
      return $text;
    };
  }

  sub createquery {
    my $name = shift;    # name of function to create 
    my $sql = shift;        # query this function will execute
    my $inner = shift;     # name of function to call with each result, optional
    my @queryargs; $sql =~ s{('?)$macro\1}{push @queryargs, lc($2);'?'}oges;
    my $sth = $dbh->prepare($sql, @queryargs);
    *{$name} = sub {
      my $ob = shift;
      my $row;
      my $ret;
      $sth->execute(map { fetchvalue($1, $ob); } @args);
      my @names = @{$sth->{'NAME'}};
      while($row = $sth->fetchrow_arrayref()) {
        # store each item by its column name
        for(my $i=0;$i < @names; $i++) {
          $ob->{$names[$i]} = $row->[$i];
        }
        # if we're supposed to send each record to someone, do so.
        $ret .= $inner->($ob) if($inner);
      }
      $sth->finish();
      return $ret;
    };
  }

  # writing code in our mini language:

  createquery('readnames', qq{
    select Name as name from Users where Name is not null
  });

  createquery('readnumberbyageinstate', qq{
      select count(*) as number, Age as agearoup
      from Users where State = STATE
      group by Age 
  }, 'drawbargraph');

 createtemplate('drawbargraph', qq{
    <div align="left"><img src="reddot.png" height="20" width="NUMBER"></div>
  });

  print readnames();
  print readnumberbyageinstate({state=>'MD'});

  print createquery($readnumberbystatesql, {drawpiechart => createpiechart() }, 'drawpiechart');

AssertPattern

  eval {
    run_query();
  };
  if($@) {
     $dbh = DBI->connect("DBI:Pg:dbname=blog;host=localhost;port=5432", 'scott', 'foo');
     run_query();
  }

CodeAsData

NonReenterable

  my $lock;

  sub notify_all {
    if($lock) {
      warn "Don't respond to an event with an event!";
      $lock++;
    }
    foreach my $listener (@listeners) {
      $listener->send_event(@_);
    }
    $lock = 0;
  }

  sub notify_all {

    if($testing) {
      # never do this in production code!
      my $calldepth = 0;
      $callerdepth++ while(caller($calldepth));
      die "arbitrary limit exceeded: stack depth too deep, possible runaway recursion detected"
        if $callerdepth > 100;
    }
    
    foreach my $listener (@listeners) {
      $listener->send_event(@_);
    }

  }

  # expand includes in HTML templates
  # eg, <!-- #include virtual="/includes/header_logo.html" -->

  my $numfound;

  FOUNDSOME: 

  $numfound = 0;

  $tmpl =~ s{<!--\s*#include\s*virtual\s*=\s*('")(.*?)\1\s*-->}{
    die "invalid include path: '$2'" if $2 =~ m{\/\.\./\/};
    open my $f, "$inputdir/$2" or die "include not found: $inputdir/$2 $!";
    read $f, my $repl, -s $f;
    close $f;
    $numfound++;
    return $repl;
  }gie;

  goto FOUNDSOME if($numfound);

  my $numfound;
  my %done;  # added this

  FOUNDSOME: 

  $numfound = 0;

  $tmpl =~ s{<!--\s*#include\s*virtual\s*=\s*('")(.*?)\1\s*-->}{
    die "invalid include path: '$2'" if $2 =~ m{\/\.\./\/};
    die "file '$2' included entirely too many times" if $done{$2}++ > 30;   # added this
    open my $f, "$inputdir/$2" or die "include not found: $inputdir/$2 $!";
    read $f, my $repl, -s $f;
    close $f;
    $numfound++;
    return $repl;
  }gie;

  goto FOUNDSOME if($numfound);

SelectPollPattern

    my $shbit = 1 << fileno($sh);
    my $sibit = 1 << fileno($si);

    my $inbitmask = $shbit | $sibit;

    # select(readtest, writetest, exceptiontest, max wait)
    select($inbitmask, undef, undef, 0);

    if($inbitmask & $shbit) {
      # $sh is ready for read
    }

    if($inbitmask & $sibit) {
      # $si is ready for read
    }

    if($inbitmask & $sibit) {
      $si->process_input();
    }

  package IO::Network::GnutellaConnection;

  use base 'IO::Handle';

  sub process_input() {
    my $self = shift;
    $self->read(...);
  }

  use Socket;
  use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  use POSIX qw(:errno_h :fcntl_h); 

  my $proto = getprotobyname('tcp');
  socket($server, PF_INET, SOCK_STREAM, $proto)                 or die "socket: $!";
  setsockopt($server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))   or die "setsockopt: $!";
  bind($server, sockaddr_in($port, INADDR_ANY))                 or die "bind: $!";
  listen($server, SOMAXCONN)                                    or die "listen: $!";

  # non blocking listens:

  fcntl($client, F_SETFL, fcntl($server, F_GETFL, 0) | O_NONBLOCK) or die "fcntl: $!"; 

  while(1) {

    my $paddr = accept($client, $server);
    (my $remoteaddress, my $remoteport) = sockaddr_in($paddr);
    my $remotehostname = gethostbyaddr($iaddr,AF_INET);

  }

JournalingPattern

  package Xfor;
  
  sub new {

    my $pack = shift;
  
    my $filecache;       # holds all of the name->value pairs for each item in each file
    my $buffered;        # same format: data to write to file yet
  
    bless {

      # open a flatfile database. create it if needed.

      open => sub {
        my $fn = $_[0]; 
        unless(-f $fn) {
          open F, '>>'.$fn or return 0;
          close F;
        }
        $self->openorfail($fn);
      },
  
      # open a flatfile database. fail if we are unable to open an existing file.

      openorfail => sub {
        my $file = shift;       # which file the data is in
        open my $f, $file or die $!;
        my $k; my $v;
        while(<$f>) {
            chomp;
            %thingy = split /\||\=/, 'key='.$_;
            while(($k, $v) = each %thingy) {
              $filecache->{$file}->{$thingy{'key'}}->{$k} = $v;
            }
        }
        close $f;
        return 1;
      },
  
      # fetch a value for a given key
  
      get => sub {
        my $file = shift;   #    which file the data is in
        my $thingy = shift; #    which record in the file - row's primary key
        my $xyzzy = shift;  #    which column in that record
        $logic->openflatfile($file) unless(exists $filecache->{$file});
        return $filecache->{$file}->{$thingy}->{$xyzzy};
      },
  
      keys => sub {
        my $rec = $filecache;
        while(@_) {
          $rec = $rec->{$_[0]}; shift;
        }
        if(wantarray) {
          keys %{$rec};
        } else {
          $rec;
        }
      },
  
      set => sub {
        my $file = shift;   #    which file the data is in
        my $thingy = shift; #    which record in the file - row's primary key
        my $x = shift;      #    which column in that record
        my $val = shift;    #    new value to store there
        $filecache->{$file}->{$thingy}->{$x} = $val;
        $buffered->{$file}->{$thingy}->{$x} = $val;
        1;
      },
  
      close => sub {
        my $file = shift;       # which file the data is in
        my $thingy;             # which record in the file - row's primary key
        my $x;                  # which column in that record
        my $val;                # new value to store there
        my $line;               # one line of output to the file
        open my $f, '>>'.$file or die "$! file: $file";
        foreach $thingy (keys %{$buffered->{$file}}) {
          $line = $thingy;
          foreach $x (keys %{$buffered->{$file}->{$thingy}}) {
            $line .= '|' . $x . '=' . $buffered->{$file}->{$thingy}->{$x};
          }
          print F $line, "\n";
        }
        $buffered->{$file} = ();
        close $f;
      },
   
      recreate => sub {
        my $file = shift;       # which file the data is in
        my $thingy;             # which record in the file - row's primary key
        my $x;                  # which column in that record
        my $val;                # new value to store there
        my $line;               # one line of output to the file
        open my $f, ">$file.$$" or die "$! file: $file.$$";
          foreach $thingy (keys %{$filecache->{$file}}) {
          $line = $thingy;
          foreach $x (keys %{$filecache->{$file}->{$thingy}}) {
            $line .= '|' . $x . '=' . $filecache->{$file}->{$thingy}->{$x};
          }
          print $f $line, "\n";
        }
        close F;
        rename "$file.$$", $file or die "$! on rename $file.$$ to $file";
      },

    } , $pack;

  }
  
  

  use Xfor;
  my $hash = new Xfor;
  $hash->open('carparts.nvp');

  # read:

  $hash->get('carparts.nvp', 'xj-11', 'muffler');   # which muffler does the xj-11 use?

  # write:

  $hash->set('cartparts.nvp', 'xj-11', 'muffler', 'c3p0');

  # then later:

  $hash->close('carparts.nvp');

  # or... 

  $hash->recreate('carparts.nvp');

ApplicationGenerator

WebAuthentication

• .htaccess

• Cookies

• Munged links.

  # go out of our way to include sid=$sid:

  print qq{<a href="otherprog.cgi?foo=bar&color=red&sid=$sid">Go To Otherprog</a>};

  print qq{
    <form action="anotherprog.cgi" method="post"> 
      <input type="hidden" name="sid" value="$sid">
      Enter answer: <input type="text" name="answer"><br>
      <input type="submit">
    </form>
  };
  

  $oOo =~ s/<(a|frame)([^>]*) (src|href)=(['"]?)(?!javascript)([^'"]+\.htm)(l)?(\?)?([^'">]*)?\4(?=\w|>>)/<$1$2 $3="$5$6\?$8\&sid=$sid"/ig;
    
  # $1: 'a' or 'frame'
  # $2: any random name=value pairs (exa 'name="mainFrame"')
  # $3: 'src' or 'href'
  # $4: any begin qouting character, be it ' or "
  # $5: whatever.htm
  # $6: optional 'l'
  # $7: optional '?' (discarded)
  # $8: optional cgi get string
  # $9: 0-width lookahead assertion: > or space isn't matched but is looked for
    

  # Sample validateuser.pm:
  
  use CGI;
  use CGI::Carp qw/fatalsToBrowser/;
  use DBI;
  
  use lib "/home/scott/cgi-bin/DBD";
  
  BEGIN {
  
    $dbh = DBI->connect("DBI:Pg:dbname=sexcantwait;host=localhost;port=5432", 'scott', 'pass')
      or die $DBI::errstr;
  }
  
  use TransientBaby::Postgres;
  use TransientBaby;
  
  createquery('validateuser', qq{
    select   UserID as userid
    from     Users
    where    Name = [:username:]
    and      Pass = [:userpass:]
  });
  
  sub validated {
    $userid = -1;
    my $sid=CGI::cookie(-name=>"sid");
    return 0 unless $sid;
    ($username, $userpass) = split /,/, $sid;
    validateuser();
    return $userid == -1 ? 0 : 1;
  }
  
  sub is_guest {
    return $username =~ /^guest/;
  }

  sub offer_login {
    print qq{
      Sorry, you aren't logged in. Please enter your name and password:<br><br>
      <form action="login.cgi" method="post">
        <input type="hidden" name="action" value="login">
        User name: <input type="text" name="username"><br>
        Password: <input type="password" name="password"><br>
        Are you a new user? <input type="checkbox" name="newuser"><br>
        <input type="submit" value="Log in"><br>
      </form>
    };
    exit 0;
  }
  
  1;
  

  print qq{Content-type: text/html\n\n}; 
  use validateuser;
  validated() or offer_login();

  # rest of the script here, for users only

  #!/usr/bin/perl

  # example login/create user script that uses validateuser.pm.
  # this should be named login.cgi to match the form in validateuser.pm, unless of course
  # that form's action is changed.
  
  use validateuser;
  
  createquery('userexists', qq{
    select count(*) as num
    from   Users
    where  Users.Name = [:name:]
  });
  
  createquery('createuser', qq{
    insert into Users
    (Name, Pass, CreationIP)
    values
    ([:name:], [:pass:], [:creationip:])
  });
  
  my $action = CGI::param('action');
  my $newuser = CGI::param('newuser');
  
  if(!$action) {

    offer_login();

  } elsif($action eq 'login' and !$newuser) {
  
    $username = CGI::param("username");
    $userpass = CGI::param("userpass");
  
    validateuser();
  
    if($userid != -1) {
  
      my $cookie=CGI::cookie(
        -name=>'sid', -expires=>'+18h', -value=>qq{$username,$userpass},
        -path=>'/', -domain=>'.sexcantwait.com'
      );
      print CGI::header(-type=>'text/html', -cookie=>$cookie);
  
      print qq{Login successful.\n};

    } else {
      
      sleep 1; # frustrate brute-force password guessing attacks
      
      print qq{Content-type: text/html\n\n};
      
      print qq{Login failed! Please try again.<br>\n};

      offer_login();
      
    } 
    
  } elsif($newuser and $action eq 'login') {
    
    local $name = CGI::param("username");
    local $pass = CGI::param("userpass");
    
    userexists(); if($num) {
      print qq{User already exists. Please try again.<br>\n};
      offer_login();
    }
  
    local $creationip = $ENV{REMOTE_ADDR};
  
    createuser();
    validateuser(); # sets $userid
  
    print qq{Creation successful! Click on "account" above to review your account.<br>\n};
  
  }
  

FileUpload

  <gogamoga> well, i`ll ask: how do i fetch attached file from the query?
  <scrottie> ask to ask?
  <Perl-fu> Don't ask to ask. Don't ask if anybody can help you with x. 
            Just ask!  Omit any irrelevant details. If nobody answers then we 
            don't know or are busy for a few minutes. Wait and don't bug us. 
            If you must ask again wait until new people have joined the channel.
  <scrottie> my $fh = CGI::upload($fn); my $buffer; while (read($fh,$buffer,length($buffer)) { }; 
  <scrottie> where $fn is the name of the CGI param. make sure the from has the right enctype. 
  <scrottie> i don't remember the enctype, but "perldoc CGI" will tell you
  <scrottie> unless the form uses that special enctype, file uploads won't be uploaded, rather mysteriously
  <gogamoga> THANK YOU SOOOOOOOOO MUCH
  <gogamoga> i got lost in cgi.pm reference :(
  <scrottie> heh, you're welcome. let me know if you get stuck.
  <scrottie> yeah, someone really needs to slim that down.
  <gogamoga> i use only jpg enctype so i wont even check it
  <gogamoga> just fetch the file and save it
  <scrottie> you don't understand.
  <scrottie> hang on. let me find it.
  <gogamoga> ok
  <scrottie> if your form doesn't say 
             <form method="post" enctype="multipart/form-data">, then 
             <input type="file"> tags wont work. they won't upload the file.
  <scrottie> reguardless of the type of the file, the file won't be uploaded.
  <scrottie> Netscape 2 introduced the ability to upload files, and in order to 
             support this feature, they had to introduce a
             new format for sending data to the server - the old 
             application/x-www-form-urlencoded one couldn't handle large
             blocks of arbitrary data
  <gogamoga> ah
  <gogamoga> damn, it wont upload it but it still takes ages as it uploads it :)
  <gogamoga> ah, sorry i am dumb
  <scrottie> no, we all have to work through the standard mistakes ;)
  <gogamoga> dreamweaver adds multipart/form-data by default
  <gogamoga> :)
  <scrottie> good. no one uses Netscape 1 anymore ;)

WebScraping

  use TransientBaby::Forms;
  use TransientBaby;

  my $accessor;
  my %opts;

  my @table;
  my $tablerow;
  my $tablecol = -1;

  parse_html($document, sub {

    $accessor = shift;
    %opts = @_;

    if($opts{tag} eq 'tr') {

      # create a new, blank array entry on the end of @table
      $tablerow++; $table[$tablerow] = [];
      $tablecol = 0;

    } elsif($opts{tag} eq 'td') {

      # store the text following the <td> tag in $table[][]
      $table[$tablerow][$tablecol] = $accessor->('trailing');
      $tablecol++;

    }

  });

  select table1.a, table2.b, table3.c
  from table1, table2, table3
  where table1.id = table2.id
  and   table2.param = table3.id
  order by table1.a, table2.b, table3.c

  aaa
  aab
  aac
  aad
  aba
  aca
  ada
  baa
  bab
  (And so on...)

    } elsif($opts{tag} eq '/tr') {

      if(!$tablerow or $table[$tablerow][0] ne $table[$tablerow-1][0]) {
        $dbh->execute("insert into tablea (a) values (?)", $table[$tablerow][0]);
        $table_a_id = $dbh->insert_id();
        # else $table_a_id will retain its value from the last pass
      }

      if(!$tablerow or $table[$tablerow][1] ne $table[$tablerow-1][1]) {
        $dbh->execute("insert into tableb (b, id) values (?, ?)", $table[$tablerow][1], $table_a_id);
        $table_b_id = $dbh->insert_id();
        # else $table_b_id will retain its value from the last pass
      }

      if(!$tablerow or $table[$tablerow][2] ne $table[$tablerow-1][2]) {
        $dbh->execute("insert into tablec (c) values (?, ?)", $table[$tablerow][1], $table_b_id);
        $table_c_id = $dbh->insert_id();
        # else $table_c_id will retain its value from the last pass
      }

    }
      

ReadingAFile

  {
    local $/ = undef;
    open FH, "<$file";
    $data = <FH>;
    close FH;
  }

  @ARGV = ($file);
  my $data = join '', <>;

  my $data = `cat $file`;

  open my $fh, '<', $file or die $!;
  read $fh, my $data, -s $fh or die $!;
  close $fh;

  use Sys::Mmap;
  new Mmap my $data, -s $file, $file or die $!;

ConfigFile

  require 'config.pl';

  # config.pl:

  $config = {
    widgets=>'max',
    gronkulator=>'on',
    magic=>'more'
  };

  # configTest.pl:

  use Data::Dumper;
  require 'config.pl';

  $config->{gronkulator} = 'no, thanks';

  open my $conf, '>config.pl' or die $!;
  print $conf Data::Dumper->Dump($config);
  close $conf;

  $dumping = "xterm -display $display";

  $dumping = sub { system 'xterm', $arg, $arg; };

ErrorHandling

  open my $f, 'file.txt' or die $!;

  # from the Fatal.pm perldoc:

  use Fatal qw(open close);

  sub juggle { . . . }
  import Fatal 'juggle';

  use Fatal qw(open close read write flock seek print);

  sub update_data_file {
    my $this = shift;
    my $data = shift;
    my $record;
    local *filename = \$this->{filename};
    local *record = \$this->{record};

    eval {

      open my $f, '>+', $filename;
      flock $f, 4;
      seek $f, $record, 0; 
      print $f, $data;
      close $f;

    };

    return 0 if $@;   # update failed
    return 1;         # success

  }

  sub generate_report {
    local $SIG{__DIE__} = { 
      print "Whoops, report generation failed. Tell your boss it was my fault. Reason: ", @_;
    }
    foreach my $i ($this->get_all_data()) {
      $data->update_data_file($i);
    }
  }

  sub checkpoint_app {
    local $SIG{__DIE__} = { 
      print "Whoops, checkpoint failed. Correct problem and save your data. Reason: ", @_;
    }
    $data->update_data_file($this->get_data());
  }

  RETRY:

  eval {
    alarm 30; # send a $SIG{ALRM} after 30 seconds - default is death
    # do something that might time-out
    alarm 0;  # disable alarm
  };

  if($@) {
    # there was an error - error text is in $@ - do what you will - perhaps retry:
    goto RETRY;
  }

ErrorReporting

  # don't do this

  sub barf {
    print "something went wrong!\n", @_;
    exit 1;
  }

  # ...

  barf("number too large") if($number > $too_large);

  # send diagnostic output to the end of a log

  open my $debug, '>>bouncemail.debug';
  $SIG{__WARN__} = sub { print $debug $_, join(" - ", @_); };
  $SIG{__DIE__} = sub { print $debug $_, join(" - ", @_); exit 0; };

 - a word processor probably does __not__ want to exit with unsaved

  local $SIG{__DIE__} = sub {
    # yeah, whatever
  };

  # or...

  local $SIG{__DIE__} = 'IGNORE';

  
  # intercept death long enough to scream bloody murder

  $version = '$Id: ErrorReporting,v 1.20 2003/05/15 09:58:41 phaedrus Exp $'; # CVS will populate this if you use CVS

  $SIG{qq{__DIE__}} = sub {

    local $SIG{qq{__DIE__}}; # next die() will be fatal

    my $err = '';

    $err .= "$0 version $version\n\n";

    # stack backtrace

    $err .= join "\n", @_, join '', map { 
      (caller($_))[0] ? sprintf("%s at line %d\n", (caller($_))[1,2]) : ''; 
    } (1..30);

    $err.="\n";

    # report on the state of global variables. this includes 'local' variables 
    # and 'our' variables in scope. see PadWalker for an example of inspecting
    # lexical 'my' variables as well.

    foreach my $name (sort keys %{__PACKAGE__.'::'}) {
      my $value =  ${__PACKAGE__.'::'.$name};
      if($value and $name ne 'pass' and $name =~ m/^[a-z][a-z0-9_]+$/) {
        $err .= $name . ' ' . $value . "\n" 
      }
    }

    $err .= "\n";

    foreach my $name (sort keys %ENV) {
      $err .= $name . ' ' . $ENV{$name} . "\n";
    }

    $err .= "\n";

    # open the module/program that triggered the error, find the line
    # that caused the error, and report that.

    if(open my $f, (caller(1))[1]) {

      my $deathlinenum = (caller(1))[2];
      my $deathline;

      # keep eof() from complaining:
      <$f>; 

      $deathline = <$f> while($. != $deathlinenum and !eof);

      $err .= "line $deathline reads: $deathline\n";

      close <$f>;

    }

    # send an email off explaining the problem
    # in text mode, errors go to the screen rather than by email

    require Mail::Sendmail;
    sendmail(To=>$errorsto, From=>$mailfrom, Subject=>"error", Message=>$err) unless($test);

    print "<pre>\n", CGI::escapeHTML($err), "</pre>\n" if($test);

    # reguardless, give the user a way out. in this case, we display what was in their
    # shopping cart and give them a manual order form that just sends an email, and we
    # call them back for payment info.

    $|=1;
    # print "Those responsible for sacking the people that have just been sacked, have just been sacked.<br><br>\n";
    print "A software error has occured. Your order cannot be processed automatically. ";
    print "At the time of the error, your cart contained:<br><br>\n";
      
    open my $cart, $cartdir.$sid;
    print "$_<br>\n" while(<$cart>);
    print qq{
      <script language="javascript">
        window.open($errororderpage);
      </script>
    };
    close $cart;

    # finally, give up 

    exit 0;

  };

ExtensibilityPattern

  # the config.pl file defines @listeners to contain a list of class names
  # that should receive notices from an EventListener broadcaster, 
  # referenced by $broadcaster. 

  require 'config.pl';

  foreach my $listener (@listeners) {
    require $listener;
    my $list_inst = $listener->new();
    $broadcaster->add_listener($list_inst);
  }

  
  pacakge UserExtention1;

  # we are expected to have a "run_macro" method

  sub run_macro {
    my $this = shift;
    my $app = shift;

    $app->place_cursor(0, 0);
    $app->set_color('white');
    $app->draw_circle(radius=>1);
    $app->set_color('red');
    $app->draw_circle(radius=>2);
    # and so on... make a little bull's eye

    return 1;
  }

    place_cursor(0, 0)
    set_color(white)
    draw_circle(radius=1)
    set_color(red)
    draw_circle(radius=2)

  # read in the users program
  my $input = join '', <STDIN>;

  # 0 if we're expecting a function name, 1 if we're expecting an argument,
  # 2 if we're expecting a comma to seperate arguments
  my $state = 0;

  # perl code we're creating
  my $perl = '
    package UserExtention1;

    sub run_macros {
      my $this = shift;
      my $app = shift; 
  ';

  while(1) {
    # function call name
    if($state == 0 && $input =~ m{\G\s*(\w+)\s*\(}cgs) {
      $perl .= '  $app->' . $1 . '(';
      $state = 1;
 
    # a=b style parameter
    } elsif($state == 1 && $input =~ m{\G\s*(\w+)\s*=\s*([\w0-9]+)}cgs) {
      $perl .= qq{$1=>'$2'};
      $state = 2;

    # simple parameter
    } elsif($state == 1 && $input =~ m{\G\s*([\w0-9]+)}cgs) {
      $perl .= qq{'$1'};
      $state = 2;

    # comma to seperate parameters
    } elsif($state == 2 && $input =~ m{\G\s*,}cgs) {
      $perl .= ', ';
      $state = 1;

    # end of parameter list
    } elsif(($state == 1 || $state == 2) && $input =~ m{\G\s*\)}cgs) {
      $perl .= ");\n";
      $state = 0;

    # syntax error or end of input
    } else {
      return 1 unless $input =~ m{\G.}cgs;
      print "operation name expected\n" if $state == 0;
      print "parameter expected\n" if $state == 1;
      print "comma or end of parameter list expected\n" if $state == 2;
      return 0;
    }
  
  }

  $perl .= qq<
      return 1;
    }
  >;

  eval $perl; if($@) {
     # display diagnostic information to user
  }

CutAndPasteProgramming

  $money = $player->query_money();
  if($player->query_max_money() < $x + $payout) {
    $player->set_money($money + $payout); 
    $nickels_on_floor = 0;
  } else {
      $nickels_on_floor =  $money + $payout - $player->query_max_money();
      $player->set_money($player->query_max_money());
  }

  package Util;

  package Casino;
  use ImplicitThis; ImplicitThis::imply();

  sub pay_out {

    # this method would go in $player, since it is mostly concerned with $player's variables,
    # but we don't want to clutter up $player's package, and we don't know if anyone else
    # will ever want to use this code.

    my $player = shift;
    my $payout = shift;

    my $money = $player->query_money();
    if($player->query_max_money() < $money + $cost) {
      $player->set_money($money + $payout); 
      $nickels_on_floor = 0;
  } else {
      $nickels_on_floor =  $money + $payout - $player->query_max_money();
      $player->set_money($player->query_max_money());
    }
  }

PrematureOptimization

BlindFaith

BigBallOfMud

SpaghettiCode

  10 let a=a+1
  20 if a > 10 then goto 50
  30 print a:print "\n"
  40 goto 10
  50 stop

  foreach my $a (1..10) {
    print "$a\n";
  }

LavaFlow

BoatAnchor

BusySpin

  while(1) {
    if(@queue) {
      dosomething();
    }
  }

  while(! -f $file) { }
  # do something with $file here

  # this program attempts to use 100% of CPU time

  use IO::Socket::INET;
  my $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
                                   PeerPort => 'http(80)',
                                   Proto    => 'tcp');
  $sock->blocking(0);

  while(1) {
    read $sock, my $buffer, 8192;
    do_something_with_data($buffer);
  }

  while(<$fh>) {
    print;
  }

  my $waketime = scalar(time()) + 60*60*8.5; # longer on the weekends
  while(scalar time() < $waketime) {
    sleep $waketime - scalar time(); # sleep the rest of the duration - probably
  }

RaceCondition

  Malak tells you: wee! :-)  ok here is the question.  if i have two
  copies of a script downloading the same set of files (to make it go faster) i
  want to make sure that one script doesnt try to download the same file as the
  other.  right now i'm using a -e check to see if the file exists but im not
  sure if this will ever cause a problem if both scripts happen to hit the same
  file at the same time

  Yes, there is a race condition between the time that you test for the file
  with //-e// and when you create the file with //open()//. It could well
  happen that you test to see if the file, is there, it isn't, you go to
  open it for write and over write another process.

    if(! -e $file) {
      open my $f, '>', $file;
      download($f);
    }

  You tell Malak: yes. use sysopen(). open for write but not create. if
  it returns error status, the race condition bit ya, move on to the next file

  Malak tells you: not sure if i can do that. im calling an external
  program to actually do the download...

  You tell Malak: why don't you use threads, then? then you can create
  a hash that is shared between all threads and use it to do locking

    use threads::shared;
    my :shared %locks;

  Malak tells you: i wonder if the race condition matters though...  
  which ever process finishes downloadig last should write the file and replace
  whatever the other file wrote, right?

  You tell Malak: yeah

  Malak tells you: i dont care if that happens, all i care about is
  that no files get corrupted, seemingly downloaded good when they arent

  You tell Malak: actually, on unix, what would happen is the same
  would be downloaded, twice, at the same time, but only one of the inodes would
  actually exist on the filesystem, so when the other processed closes its
  filehandle, the filesystem will deallocate the blocks

  #!/usr/bin/perl
  
  print "Content-type: image/gif\n";
  print "Pragma: no-cache\n";
  print "\n";

  my $pid = $$; # our pid, not the pid of some shell or something
  
  umask 000;
  local $ENV{PATH} = '/usr/local/bin';

  open my $f, '+<', 'counter';
  flock $f, 2;
  $counter=<$f>;
  $counter++;
  seek $f, 0, 0;
  printf $f $counter + "\n";
  close $f;
  
  system "pbmtext $counter | pnmcrop 2>/dev/null | pnmenlarge 3 > counter10.$pid.pbm 2>/dev/null ";
  for(my $i=10;$i<30;$i++) {
    my $j = $i + 1;
    system "pbmlife counter$i.$pid.pbm > counter$j.$pid.pbm 2>/dev/null";
  }
  open my $gif, "ppmtogif -delay 40 -loop 100 counter??.$pid.pbm 2>/dev/null|";
  while(read $gif, my $buf, 1024, 0) {
    print $buf;
  }
  close $gif;
  
  # this isn't working :(
  
  for(my $i=10;$i<31;$i++) { 
    unlink "counter$i.$pid.pbm"; 
  }

           $hits = int( (time() - 850_000_000) / rand(1_000) );

GodObject

  # procedural code gives exactly one possible definition for a function call - 
  # the code and data are mixed all over the place

  sub do_a { $thing->[0]++; }
  sub do_b { $thing->[1]++; }
  sub do_c { $thing->[2]++; }

  sub do_stuff {
    my $thing = shift;
    do_a($thing);
    do_b($thing);
    do_c($thing);
  }

  sub do_a { $thing->[0]++; }
  sub do_b { $thing->[1]++; }
  sub do_c { $thing->[2]++; }

  sub do_a_neg { $thing->[0]--; }
  sub do_b_neg { $thing->[1]--; }
  sub do_c_neg { $thing->[2]--; }

  sub do_stuff {
    my $thing = shift;
    if($thing->[0] < 0) {
    } else {
      do_a($thing);
    }
    do_b($thing);
    do_c($thing);
  }

  # object oriented code allows method calls to be defined any number of different ways -
  # the data has its own code

  package ThingOne;

  sub new { bless [], shift(); }
  sub do_a { my $thing = shift; $thing->[0]++; }
  sub do_b { my $thing = shift; $thing->[1]++; }
  sub do_c { my $thing = shift; $thing->[2]++; }

  package ThingTwo;

  sub new { bless [], shift(); }
  sub do_a { my $thing = shift; $thing->[0]--; }
  sub do_b { my $thing = shift; $thing->[1]--; }
  sub do_c { my $thing = shift; $thing->[2]--; }

  package main;

  sub do_stuff {
    my $thing = shift;
    $thing->do_a();
    $thing->do_b();
    $thing->do_c();
  } 

  my $t1 = new ThingOne();
  do_stuff($t1);

  my $t2 = new ThingTwo();
  do_stuff($t2);

  my $treasure_location_x = 3;
  my $treasure_location_y = 10;
  my $treasure_value = 1000;
  my $treasure_weight = 30;

  # is better written:

  my $treasure = {};
  $treasure->{location}->{x} = 3;
  $treasure->{location}->{y} = 10;
  $treasure->{value} = 1000;
  $treasure->{weight} = 30;

  # or even:

  ($treasure->{location}->{x}, $treasure->{location}->{y}, $treasure->{value},
   $treasure->{weight}) = (3, 10, 1000, 30);

  ${$varname} = $value;

  # is better written:

  $table->{$varname} = $value;

  my @array = (1, 2, 3);
  $array[2]++;

  # all occurances of @array manually changed:

  my $array = new Array::Wrapper();     # our container for something that was an array
  my $value = $array->get_element(2); 
  $array->set_element(2, $value+1);

  # in your code:

  my @array;
  my $array = new Array::Wrapper(\@array);

  $array[3] = 10;     # this works
  $array->set(3, 10); # so does this

  # in Array::Wrapper.pm:

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

  sub get {
      my $self = shift;
      my $index = shift;
      return $self->[$index];
  }

  sub set {
      my $self = shift;
      my $index = shift;
      $self->[$index] = shift;
      return $self;
  }

  # At the top of the main program:

  my @treasure;  # [x, y, bot, weight, destx, desty]

  # Logic that generates a status report with map, written before I knew what 
  # I was getting into:

  foreach my $i (grep {ref $_} @treasure)  { 
    push @objs, [$i->[0], $i->[1], 't'] unless $i->[2];
  }

  # In logic that reads updates from server, I was overcome with complexity,
  # created a helpful wrapper, and blessed my array into it:

  my $treasure = new Treasure::Chest(\@treasure) or die;

  # ... later in same area... 
 
  $treasure->get($t)->set_bot($bots[$curbot]);

  # In logic that considers possible actions:

  foreach my $i ($treasure->by_bot($bot)) {
      my $dropoff = $i->get_dropoff();
      my @coords = ($bot->[0], $bot->[1], $dropoff->x(), $dropoff->y());
      my $route = [$dropoff, sub { plot_route(@coords) }, undef ];
      $route->[2] = approx_cost(@coords);
      $route->[2] -= 100 if($cap < $carry / 2);
      $route->[2] -= 100 if($cap < $carry / 3);
      $route->[2] -= 100 if($cap < $carry / 4);
      push @routes, $route;
  };

  # In another possible action agent:

  @goodies = SortPackages::go(
      $treasure, $blockbuilder, $carry-$bot->[2], $bot->[0], $bot->[1]
  );

  # Deliver everything destined for this spot:

  foreach my $i ($treasure->by_bot($bot)) {
    if($i->destx == $bot->[0] and $i->desty == $bot->[1]) {
      my $id = $i->id();
      return [90, sub {
          $treasure->zero($id);
          "1 Drop $id"   
      }];
    }
  }

  my $treasure = new Treasure::Chest(\@treasure) or die;

  $fooLogic->doAnotherThing($stuff, $morestuff);
  # or...
  $fooLogic->doAnotherThing($stuff->{some_thing}, $morestuff->{some_other_thing});

  $blockbuilder->plot_route($bot, $i);
  # or...
  $blockbuilder->plot_route($bot->[0], $bot->[1], $i->[0], $i->[1]);

  # or a mixture...
  @goodies = SortPackages::go(
    $treasure, $blockbuilder, $carry-$bot->[2], $bot->[0], $bot->[1]
  );

  # other functions in the god object still think plot_route() is a local
  # function rather than a method in another object

  sub plot_route {
    my $sx = shift; my $sy = shift;
    my $fx = shift; my $fy = shift;
    # logic moved into $blockbuilder object
    return $blockbuilder->plot_route($sx, $sy, $fx, $fy);
  } 

  # square foo when foo is a regular variable:
  $foo = $foo * $foo; 

  # square foo when foo is an object instance variable:
  $this->{'foo'} = $this->{'foo'} * this->{'foo'}; 

  sub setvalue {
    no strict 'refs';
    my $this = shift;
    local *foo = \$this->{foo};

    $foo = $foo * $foo;
  }

  sub new {
      my $class = shift;
      my $hashref = shift;
      my $self = { 
          foo => 'bar',
          num => 10,
          hashref => $hashref,
      }; 
      bless $self, $class;
  }

  sub dog_years {
      my $self = shift;
      my $age = shift;
      # no need to take $hashref as an argument, we have it stashed in $self
      return $age * $self->{hashref}->{'dog_factor'};
  }

  sub new {
      my $class = shift;
      my %options = @_;
      my $self = {
          foo => 'bar',
          num => 10,
          thing => $options{'thing'},
      };
      bless $self, $class;
  }

  # which bot is holding treasure $x, if any?
  $treasure = $treasure_chest->get($x)->bot();  

  # which map region is bot $green standing on?
  $block = $block_builder->bounded_by($bots->get($green)->x(), $bot->get($green)->y());

  # what objects stand between us and where we want to be?
  @route = $block->solve_maze($x, $y);

ObjectOrgy

FeatureEnvy

EmptySubclassFailure

CheckingTypeInsteadOfMembership

  die "Invalid" unless $obj->isa('FOO');

ExplicitTypeCaseAnalysis

  my $appointment = $sunday->query_scheduler()->schedule_appointment($sunday, '9:00am');
  if(!$appointment) {
    warn "failed to book appointment. sorry, boss.";
  }

AccumulateAndFire

ActionAtADistance

        foreach $num ($[ .. $#entry) {
          print "  $num\t'",$entry[$num],"'\n";
        }

  package WhineyScalar;
  
  sub new { tie $_[1], $_[0]; }

  sub TIESCALAR {
    bless \my $a, shift;
  }

  sub FETCH {
    my $me = shift;
    $$me;
  }

  sub STORE {
    my $me = shift;
    my $oldval = $$me;
    $$me = shift;
    (my $package, my $filename, my $line) = caller; 
    print STDERR "value changed from $oldval to $$me at ", join ' ', $package, $filename, $line, "\n";
  }

  1;

  use WhineyScalar;
  new WhineyScalar my $foo;
  $foo = 30;  # this generates diagnostic output
  print $foo, "\n";
  $foo++;     # this generates diagnostic output
  

InterfaceBloat

FatCommands

HardcodesAreEvil

CachingFailure

NoSexUntilMarriage

AbstractionInversion

AboutRefactoring

• The design isn't to be trusted to the programmer
• The program isn't to depend on a specific implementation by any one programmer
• Management desires a high-level view of the structure of the product that they can understand

• Returning a complex data structure from a module
• There is no procedural interface to a module

• Features are anticipated that would make an object useful
• Datastructures may have to expand in the future to hold more data
• This programmer is merely a designer, not involved in the actual programming

• There is too much data in a data structure
• There are too many functions in a program

RefactoringPattern

  x*5 + 10 = x*2 + 32

  15 = 5 * 3

GeneralizePattern