FunctionalProgramming
  ShortHandInstanceVariables
  AccessorPattern
  TypeSafety
  TypedVariables
  PrivateFunctions
  AbstractClass
  AbstractFactory
  InnerClasses
  OverloadOperators
  ClassAsTypeCode
  ImmutableObject
  FlyweightPattern
  AnonymousSubroutineObjects
  ConfigFile
  FunctionTemplating
  TooManyArguments
  ConstraintSystem
  DecoratorPattern
  ExportingPattern
  GodObject
  MoveCollectionsOfFunctionsToObjects
  MoveLargeDatastructuresToContainers
  SharedData
  StateVsClass
  TooManyArguments
  TypedVariables

  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;

  @ISA = qw(Cart::Item);

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

  # other query_ routines here...

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

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

  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(@_);
  }

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

  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::Gravey;

  # and so on...

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

  # 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

  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
  }

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

  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 { ... }

  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 {
      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')) {
        my $numbers = $this->{'numbers'};
        push @$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
  

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

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

  $number->add(10);

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

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

  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(...)
    my $package = shift; $package = ref $package if ref $package;
  
    my $car = new Car::GenericAmericanCar;
  
    my $kind = shift;
  
    return bless $car, 'Car::Ford' if $kind eq 'ford';
    return bless $car, 'Car::Dodge' if $kind eq 'dodge';
    return bless $car, 'Car::Buick' if $kind eq 'buick';
    return bless $car, 'Car::Pontiac' if $kind eq 'pontiac';
    die "I don't think we make $kind in this country. Try Mexico."; 
  }

  package Car::Factory;
  
  sub create_american_car {
    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;

  }
  

  my $factory = new FordFactory; 

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

  # later:

  $factory = new ChevyFactory;

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

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

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

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

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

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

  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;

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

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

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

  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 count(*) as isDongle
  from   Product, Category, ProductToCategory
  where  Product.ProductID = ProductToCategory.ProductID
  and    ProductToCategory.CategoryID = Category.CategoryID
  and    Category.Name = 'Dongle'

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

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

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

  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(@_);
    }

  }

    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(...);
  }

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

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

  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
      }

    }
      

  {
    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 $!;

  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;

  # don't do this

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

  # ...

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

  
  # intercept death long enough to scream bloody murder

  $version = '$Id: ErrorReporting,v 1.7 2003/03/04 11:51:24 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;

  };

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

  
  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
  }

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

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

  $fooLogic->doSomething($stuff, $morestuff);

  $fooLogic->doAnotherThing($stuff->querySomeThing(), $morestuff->queryOtherThing());

  package DoEverythingThenSome;

  my $foo;
  my $bar;
  sub nastysub1 { $foo += 300; ... }
  sub nastysub2 { ... }
  ...
  sub nastysub300 { ... }

  package FooBarUlator;

  use ImplicitThis; ImplicitThis::imply();

  sub new {
    my $type = shift;
    my %args = @_;
    bless {
      foo => $args{foo},
      bar => $args{bar}
    }, $type;
  }

  # cut and paste directly from DoEverythingThenSome:

  sub nastysub1 { $foo += 300; ... }
  sub nastysub2 { ... }
  ...
  sub nastysub100 { ... }

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

  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
  

• 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

  100 OLDA=A
  110 A=50
  120 GOSUB 200
  130 PRINT "The result is: ";PRINT $A
  140 A=OLDA
  ...
  200 A=B*100
  210 RETURN

  opendir my $d, "arts/" or die $!;

  my $processedflag = 0;
  my $file;

  FILE: while($file = readdir($d)) {
    # attempt to process the file, set $processedflag if successful
    handle_delete();
  }

  sub handle_delete {
    unlink $file if $processedflag;
    $processedflag = 0;
  }

  sub process_directory {
    my $dir = shift;

    opendir my $d, $dir or die $!;

    my $processedflag = 0;
    my $file;

    FILE: while(my $file = readdir($d)) {
      if(-d $file) {
        process_directory($file); 
      } else {
        # attempt to process the file, set $processedflag if successful
        # we now have to explicitly pass our arguments!
        handle_delete($file, $processedflag);
    }
  }

  sub handle_delete {
    my $file = shift;
    my $processedflag = shift;
    unlink $file if $processedflag;
    $processedflag = 0;
  }

  process_directory('arts/');

  # store things in the correct array - ugly

  print "Who should get a cookie? "; my $name = <STDIN>;
  print "What kind of cookie should they get? "; my $cookie = <STDIN>;

  push @{'cookies_for_'.$name}, $cookie;  

  # store things in the correct array - clean

  my $peoples_cookies = {};

  print "Who should get a cookie? "; my $name = <STDIN>;
  print "What kind of cookie should they get? "; my $cookie = <STDIN>;
  
  push @{$peoples_cookies->{$name}}, $cookie;

  # scalars are easy:

  my $cookie = $peoples_cookies->{'fred'}->[0];

  # but refering to an array or hash inside of a data structure is confusing:

  my @cookies = @{$peoples_cookies->{'fred'}};

  @{...something...}        # this is how you dereference something as an array
  %{...something...}        # this is how you dereference something as a hash

  open my $wordsfile, '/usr/share/dict/words' or die $!;
  my @words = <$words>; 
  close $wordsfile;

  my $something = \@words;

  print "The words I know are: ", @{$something}, "\n";

  $peoples_cookies->{'fred'}->[0] = 'sugar cookie';
  print *{'cookies_for_fred'}, "\n";                    # theres nothing there, and no warning

  <Spike[y]> does anyone know if theres a way to name a Hash like this:   %hash$i{$a} = $blah;   ?
  <hull> i dont understand:P
  <hull> cant you use %hash{$i}{$a} in your program?
  <Spike[y]> can you? i'm trying to make the name of a new hash go up each time it hits a certian thing (ie. go from %hash1 to %hash2)
  <hull> hmm
  <hull> like, in a for loop?
  <hull> for (my $i=0; $i<$k; $i++) { $hashname{$i}{$k} = "R0xx0R!"; }
  <hull> you can do it like that:P
  <Spike[y]> yeah!
  <Spike[y]> i can?!
  <Spike[y]> wierd
  <Spike[y]> it tells me its an error
  <Yaakov> $ not %
  <cp5> ${"hash$i"}{$a} = $blah
  <Spike[y]> hm .. ok
  <Yaakov> NO!
  <Yaakov> NO NO NO
  * cp5 runs
  <Yaakov> DON'T USE SYMREFS!
  <perl-fu> ew... the green apple squirts
  <Yaakov> DEATH
  <perl-fu> AAAAAAAAAh!!
  <Spike[y]> ??
  <Yaakov> Use a hash of hashes
  <Yaakov> read perldoc perldsc
  <hull> Yaakov: hash of hashes... sorta like multi-dimensional hash, uh?
  <scrottie> http://wiki.slowass.net/?SoftrefsToHash
  <scrottie> hull, you've been here before
  

  my $tests_skipped = 0;
  my $subtests_skipped = 0;

  sub runtests {
        my(@tests) = @_;
        my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests);
        my $totmax = 0;
        my $totok = 0;
        my $files = 0;
        my $bad = 0;
        my $good = 0;
        my $total = @tests;
        ...

        foreach my $file (@tests) {
            $ok = $next = $max = 0;
            @failed = ();
            my %todo = ();
            my $bonus = 0;
            my $skipped = 0;
            my $skip_reason;
            ...
        }
  }

  # Refactored:

  sub runtests {

    my(@tests) = @_;
    my(%failedtests);

    # Test-wide totals.
    my(%tot) = (
                bonus    => 0,              # $totbonus
                max      => 0,              # $totmax
                ok       => 0,              # $totok
                files    => 0,              # $files
                bad      => 0,              # $bad
                good     => 0,              # $good
                tests    => scalar @tests,  # @tests
                sub_skipped  => 0,          # $subtests_skipped
                skipped  => 0,              # $tests_skipped
               );

    ...
    foreach my $file (@tests) {
        ...
        # state of the current test.
        my %test = (
                    ok          => 0,       # $ok
                    'next'      => 0,       # $next
                    max         => 0,       # $max
                    failed      => [],      # @failed
                    todo        => {},      # %todo
                    bonus       => 0,       # $bonus
                    skipped     => 0,       # $skipped
                    skip_reason => undef,   # $skip_reason
                   );
        ...
    }
    ...
  }

  my $a = new MapDaemon($mapob);
  my $i = shift();
  $a->send_region($i, 10, 15, $x2, $y2);

  my $a = new MapDaemon($mapob);
  my $i = shift();
  my $send_region = sub { $a->send_region($i, 10, 15, shift(), shift()); };
  $send_region->($x2, $y2);

  my $a = new MapDaemon($mapob);
  my $i = shift();
  my $send_region_x = sub { $a->send_region($i, $x1, $y, $x2, $y); };
  my $send_region_y = sub { $a->send_region($i, shift(), $y, shift(), $y); };
  foreach $x1 (1..100) {
    foreach $x2 (1..100) {
      $send_region->();
      # $send_region->($x1, $x2) would do exactly the same thing
    }
  }

  #!/usr/bin/perl

  my $con = connect_to_server(@ARGV);

  my @treasure;
  my $x;
  my $y;
  my $bot;
  my @bots;

  # ...

  sub process_treasure {
    # build a list of treasure
    my $line = $con->('read');
    while($line =~ m/\G(\d+) (\d+) (\d+) (\d+) ?/g) {
      # read from server: id destx desty weight ..., eg: 17 133 28 50 89 11 57 78
      # add fields for the $x, $y location of the treasure and the (optional) object that holds it, if any
      push @treasure, [$x, $y, undef, $4, $2, $3, $1];
    }
  }

  sub available_treasure {
    # return a list of treasure at our location
    my @result;
    foreach my $treasure (@treasure) {
      # huh?
      push @result, $treasure if $treasure->[0] == $x and $treasure->[1] == $y and !$treasure->[2];
    }
    return @result;
  }

  # in Treasure.pm:

  package Treasure;

  sub new { my $type = shift; bless [@_ || (0)x7], $type; }
  sub x :lvalue { $_[0]->[0] }
  sub y :lvalue { $_[0]->[1] }
  sub bot :lvalue { $_[0]->[2] }
  sub weight :lvalue { $_[0]->[3] }
  sub destx :lvalue { $_[0]->[4] }
  sub desty :lvalue { $_[0]->[5] }
  sub id :lvalue { $_[0]->[6] }

  1;

  package Treasure::Chest;

  sub new { bless $_[1] || [], $_[0]; }
  sub get { my $t = $_[0]->[$_[1]] ||= new Treasure; bless $t, 'Treasure'; $t->id() = $_[1]; $t; }
  sub all_treasure { my $self = shift; map { $self->[$_] ? $self->get($_) : undef } (0..scalar(@$self)-1); }

  1;

  # back in our main program:

  use Treasure; 
  my $treasurechest = new Treasure::Chest(\@treasure); 

  # lets see available_treasure() again, rewritten to use the named fields:

  sub available_treasure {
    # return a list of treasure at our location
    my @result;
    foreach my $treasure ($treasurechest->all_treasure()) {
      push @result, $treasure if $treasure->x == $x and $treasure->y == $y and !$treasure->bot;
    }
    return @result;
  }

  sub take_treasure {
    my $treasureid = shift;
    my $treasure = $treasurechest->get($treasureid);
    # associate the treasure with our bot:
    $treasure->bot = $bot;
    # add the treasures weight to our weight:
    $bot->[3] += $treasure->weight;
  }

  $treasure->bot() = $bot;

  sub foo :lvalue { $_[0] ? $a : $b }
  foo(0) = 10; # assign 10 to $a
  foo(1) = 30; # assign 30 to $b

  sub bar :lvalue { substr($a, 10, 5) }
  bar() = "xyzzy";

  $treasure->{'wegiht'} = 30; # this would go unnoticed by the compiler
  $treasure->wegiht = 30; # this would be caught the first time it ran

  if($treasure->bot) {
    $x = $treasure->bot->x;
    $y = $treasure->bot->y;
  } else {
    $x = $treasure->x;
    $y = $treasure->y;
  }

  sub x :lvalue { $_[0]->bot ? $_[0]->bot->x : $_[0]->[0]; }
  sub y :lvalue { $_[1]->bot ? $_[0]->bot->y : $_[0]->[1]; }

  $treasure->y-- if $dir eq 'north';
  $treasure->y++ if $dir eq 'south';
  $treasure->x++ if $dir eq 'east';
  $treasure->x-- if $dir eq 'west';

  ($angle, $distance) = Converter::cartesian_to_polar($treasure->x, $treasure->y);

  ($angle, $distance) = $treasure->to_polar();

  sub set_x {
    if($_[0]->bot) {
      die "Cretin! I've TOLD you to check ->bot() before trying to set the location! It is illegal to set the location on an object thats being carried!";
    }
    # "x" is the first array position
    $_[0]->[0] = $_[1];
  }

  sub query_x {
    return  $_[0]->bot ? $_[0]->bot->x : $_[0]->[0];
  }

  package Class::Null;

  use vars '$VERSION';
  $VERSION = '1.02';

  my $singleton;

  sub new { $singleton ||= bless {}, shift }
  sub AUTOLOAD { *{$AUTOLOAD} = sub {}; undef }

  1;

  sub play {
    my $me = shift;
    my $investor = shift; $investor->isa('InvestmentBanker') or die;
    my $stock = shift; $stock->isa('Stock') or die;
    my $amount = shift;
    $stock->set_quantity($amount);
    $me->{$investor}={$stock};
  }

    my $arrayref = shift; ref $arrayref eq 'ARRAY' or die;

  # Haskell qsort:
  
  qsort []     = []
  qsort (x:xs) = qsort elts_lt_x ++ [x] ++ qsort elts_greq_x
                 where
                   elts_lt_x   = [y | y <- xs, y < x]
                   elts_greq_x = [y | y <- xs, y >= x]
  
  # perl qsort:
  
  sub qsort {
    !@_ ? () : (qsort(grep { $_ < $_[0] } @_[1..$#_]),
               $_[0],
               qsort(grep { $_ >= $_[0] } @_[1..$#_]));
  }
  
  print "output: ", join ' ', qsort(51,382,5,28,382,28,6,3,92,8), "\n";
  
  

  !@_ ? () : ...

  sub get_save_filter {
    my $ext = shift;
    my $stream = shift;
    return sub {
      # do something with $stream here
    } if $ext eq 'gif';
    return sub {
      # do something with $stream here for pngs
    } if $ext eq 'png';
    return sub {
      # do something with $stream here for jpgs
    } if $ext eq 'jpg';
  }

  print "Enter a filename to save the image:\n";
  my $filename = <STDIN>;
  
  # find file extention: png, jpg, gif, etc
  (my $ext) = $filename =~ m/\.([a-z]+)/;
  my $save_filter = get_save_filter($ext);

  open my $f, '>', $filename;
  print $f $save_filter->($image_data);

  $dispatch_table->{$request}->();

  GOTO REQUEST*1000

  # procedural

  for(my $i=0; $i<scalar @arr; $i++) {
    ...do something to $arr[$i]...
  }

  # functional

  @arr = map { ...do something to $_... } @arr; 

  @arr = grep { $_ % 3 == 0 } (1..10000000); # out of memory
  foreach my $i (@arr) {
    do_something($arr[$i]);
  }

  # ... would be implemented internally using LazyEvaluation something like...

  my @arr;
  my $gen;
  do {
    my $counter;
    $gen = sub { $counter++; };
  };
  while(my $i = $gen->()) { do_something($i); }
  

  # Until p f x
  # Keep on applying f to x until p(x) is true, and then return x at that point. eg:

  $x = Until { shift() % 10 == 0 } \&inc, 1; # 10

  # iterate f x
  # This returns the infinite list (x, f(x), f(f(x)), f(f(f(x)))...) and so on. 
  # Outputs [1, 2, 4, 8, 16, 32, 64, 128]

  $x = take(8, iterate { shift() * 2 } 1);

  # And xs
  # Returns true if all the elements in xs are true. Returns false otherwise. 
  # Note the capital A, so as not to clash with the Perl command 'and'. You 
  # should not try to And an infinite list (unless you expect it to fail, as it
  # will short-circuit). 

  $x = And([1, 1, 1]); # 1

  # Or xs
  # Returns true if one of the elements in xs is true. Returns false otherwise.
  # Note the capital O, so as not to clash with the Perl command 'or'. You may 
  # try to Or an infinite list as it will short-circuit (unless you expect it 
  # to fail, that is). 

  $x = Or([0, 0, 1]); # 1

  # any p xs
  # Returns true if one of p(each element of xs) are true. Returns false 
  # otherwise. You should not try to use with an infinite list (unless you expect it
  # to fail, as it will short-circuit). 

  $x = any { even(shift) } [1, 2, 3]; # 1

  # all p xs
  # Returns true if all of the p(each element of xs) is true. Returns false 
  # otherwise. You may try to use with an infinite list as it will short-circuit 
  # (unless you expect it to fail, that is). eg:

  $x = all { odd(shift) } [1, 1, 3]; # 1

  # elem x xs
  # Returns true is x is present in xs. You probably should not do this with 
  # infinite lists. Note that this assumes x and xs are numbers. 

  $x = elem(2, [1, 2, 3]); # 1

  # minimum xs
  # Returns the minimum value in xs. You should not do this with a infinite list. 

  $x = minimum([1..6]); # 1

  # maxiumum xs

  $x = maximum([1..6]); # 6

  # sum xs

  $x = sum([1..6]); 

  # product xs

  $x = product([1..6]);

  # reduce BLOCK LIST
  # Reduces LIST by calling BLOCK multiple times, setting $a and $b each time. 
  # The first call will be with $a and $b set to the first two elements of the 
  # list, subsequent calls will be done by setting $a to the result of the 
  # previous call and $b to the next element in the list.

  $foo = reduce { $a < $b ? $a : $b } 1..10       # min
  $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
  $foo = reduce { $a + $b } 1 .. 10               # sum
  $foo = reduce { $a . $b } @bar                  # concat

  # java:

  public void mouseDown(Event e, int x, int y) {
    lastx = x; lasty = y;
    return true;
  }

  # perl:

  sub mouseDown {
    my($this, $event, $x, $y) = @_;
    $this->{'lastx'} = $x;
    $this->{'lasty'} = $y;
    return 1;
  }

  sub mouseDown {

    my($this, $event, $x, $y) = @_;

    local *lastx = \$this->{'lastx'};
    local *lasty = \$this->{'lasty'};

    # now we can refer to $this->{'lastx'} merely as $lastx, just like Java and C++!

    $lastx = $x;
    $lasty = $y;

  }

  package Yawn;

  sub public { 
    local $this = shift;
    my $coderef = pop;
    my @fields = keys %$this;
    my $field;
    FIELD:
      $field = pop @fields;
      local *{$field};
      *{$field} = \$this->{$field};
    goto FIELD if(@fields);
    $coderef->(@_);
  }

  sub private {
    caller(1) eq PACKAGE__ or 
      die sprintf "Cannot invoke private method %s from outside %s", 
        (caller(1))[3], PACKAGE__;
    public(@_);
  }

  sub set_x {
    private @_, sub {
      $x = shift;
    };
  }

  Cannot invoke private method Yawn::setb_x from outside Yawn at foo.pl line 17.

  package Foo;

  use ImplicitThis;
  ImplicitThis::imply;

  sub new {
    my $type = shift;
    my %options = @_;
    my $me = { x => $options{'x'}, y => $options{'y'}};
    bless $me, $type;
  }

  sub setx {
    $x = $shift;
  }

  sub get_x {
    return $x;
  } 

  package SerialNumbered;
  
  my $globalSerialNumber;
  
  sub new {
    my $type = shift;
    $serialNumber++;
    my $me = {@_, SerialNumber=>$serialNumber}; 
    bless $me, type;
  }
  

  print ${ref($obj).'::globalSerialNumber'};

  foreach my $i (qw(name price quantity)) {
    my $field = $i;
    *{"get_$field"} = sub {
      my $me = shift;
      return $me->{$field};
    };
    *{"set_$field"} = sub {
      my $me = shift;
      @_ or die "not enough arguments to set_$field, stopped";
      $me->{$field} = shift;
      return 1;
     };
  }

  $stock->{'price'} *= 2;

  # Rather than the more OO:

  $stock->set_price($stock->get_price() * 2);

  $foo->query_ob()->add($baz->query_qux());

  $foo{ob}->{bar} += $baz{qux};

  # before: direct access to instance variable

  $ob->{foo};         # Perl
  ob->foo             # Java

  # after: using an accessor

  $ob->foo()          # Perl
  ob->foo()           # Java

  #!/usr/bin/perl

  package Cart::Item;

  sub TIESCALAR { die unless(ref $_[1] eq 'CODE'); my $foo=$_[1]; bless $foo, $_[0]; }
  sub STORE { my $me=shift; $me->(@_); }
  sub FETCH { my $me=shift; $me->(); }

  sub new {
    my $class = shift;
    my $name_value;
    my $me = { };
    tie $me->{'name'}, PACKAGE__, sub {
      $name_value = shift if @_;
      $name_value;
    };
    # repeat for price and quantity
    my $color_value;
    tie $me->{'color'}, PACKAGE__, sub { 
      die "I *HATE* blue" if $_[0] eq 'blue'; 
      $color_value = shift if @_;
      return $color_value;
    }; 
    bless $me, $class;  
  }

  # create accessors as above, slightly modified

  foreach my $i (qw(name price quantity)) {
    my $field = $i;
    *{"get_$field"} = sub :lvalue {
      my $me = shift;
      $me->{$field};
    };
    *{"set_$field"} = sub {
      my $me = shift;
      @_ or die "not enough arguments to set_$field, stopped";
      $me->{$field} = shift;
      return 1;
     };
  }

  $datastructure{'color'} = \$color;

  my $foo_value;
  my $foo_logic = sub {
    # code
    $foo_value;
    # code
  };

  $ob->get_value() += $ob->query_value() * $economy->query_inflation();

  $ob->{'color'} = 'blue'; # this blows up because we're able to trap it

  die unless $ob->isa('Number::Complex');

  or more typically:

  if(!$ob || $ob->error) {
    print "well that didnt work\n";
  }

  # in Scalar/Typed/Factory.pm:

  package Scalar::Typed::Factory;
  
  sub import {
    my $package = shift;
    my $referencetype = shift or
      die PACKAGE__ . ': import statement must specify reference type';
    $package .= '::' . $referencetype;
    my $caller = caller;

    # construct a package for this type.
    # note that $referencetype is lexically bound to this context

    *{$package.'::TIESCALAR'} = sub { 
      bless \$_[1], $_[0]; 
    };

    *{$package.'::FETCH'} = sub { 
      my $me = shift; $$me; 
    };
  
    *{$package.'::STORE'} = sub { 
      my $me = shift; 
      my $val = shift;
      ref $val and $val->isa($referencetype) or 
        die sprinf "Incorrect type in assignment: expecting $referencetype: " .
                   "%s in package %s at line %d in %s\n", 
                   (caller)[1, 0, 2];
      $$me = $val;
    };
  
    # finally, export a constructor for this new datatype to our users package:

    (my $constructor) = $referencetype =~ s/[^A-Za-z]//g; 
    $constructor = lc $constructor;

    *{$caller.'::'.$constructor} = sub ($) :lvalue {
      tie $_[0], PACKAGE__.'::'.$referencetype;
      $_[0];
    };
  }
  
  1;

  # in the main program:

  package main;

  use Scalar::Typed::Factory 'XML::Parser';
  use CGI;
  use XML::Parser;
  use XML::Parser::Compatiable;

  xmlparser my $parser = new XML::Parser;   # ok
  xmlparser my $compat = new XML::Parser::Compatiable; # ok
  xmlparser my $other = new CGI; # dies
  $parser = new CGI; # dies
  $parser = 10; # dies
  $parser = undef;  # dies - see IntroduceNullObject

  sub muckWithSomething {
    caller eq PACKAGE__ or die;
    my $self = shift;
    my $arg = shift;
    # code here using $self and $arg
  }

  package Item;

  sub new {
    my $type = shift;
    my %args = @_;
    $me->{name} = $args{name};
    $me->{price} = $args{price};
    $me->{image} = $args{image};
    $me->{description} = $args{description};
    $me->{weight} = $args{weight};
  }
  
  foreach my $i (qw(name price weight desciption image)) {
    # create accessor
  }
  

  package Item;

  sub import {
    push @{caller().'::ISA'}, PACKAGE__;
  }

  use Item;
  push @ISA, 'Item';

  # example of making sure that an interface is implemented

  package FooAbstractClass; # rename this with your abstract class

  sub import {
    my $caller = caller;
    eval "use $caller;"; # let them finish loading
    foreach my $i (grep { defined &{$_} } keys %{__PACKAGE__.'::'}) {
      die PACKAGE__ . " is listed as a base type in $caller, but the $i method is not implemented!"
        unless defined &{$caller.'::'.$i};
    }
  }

  use interface 'Class::Struct', 'Clonable';

  package BetterGronkulator;

  @ISA=('Gronkulator');

  sub new {
    my $type = shift;
    my $me = SUPER::new($type, @_);
    $me->{'spiffyNewThing'} = new BetterGronkulator::SpiffyNewThing;
    return $me;
  }

  # redefining compute_gcd() in a sublass won't affect this code
  $gcd = compute_gcd($x, $y);     

  # this will use the top-most version of compute_gcd() 
  $gcd = $this->compute_gcd($x, $y); 

  package main;

  our $this = PACKAGE__;

  sub template_records {
    my @records = $this->query_records();
    foreach my $record (@records) {
      $this->per_record($record);
      my $output = $this->template_record($record);
      $this->save_record($output);
    }
  }

  sub per_record {
    # do nothing
  }

  sub query_records {
    # default implementation
  }

  sub template_record {
    # populate a template with data from $record
  }

  sub save_record {
    # save $output to disc
  }

  # in MegaCorp.pm:

  package MegaCorp;

  our $this = PACKAGE__;
  @ISA = qw(main);

  sub per_record {
    my $this = shift;
    my $record = shift;
    if($record->{price} == 0) {
      $record->{availability} = "Sold Out";
    }
  }

  1;

  sub new {
    my $type = shift;
    $type = ref $type if ref $type;
    my $this = { };
    bless $this, $type;
  }

  MyPackage->new();
  ... and ...
  new MyPackage;

  $anothermypack = $mypack->new();

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

  use overload
    '<=>' => sub { 
      my $me = shift;
      my $them = shift;
      # return -1 to indicate we go before them
      # return 1 to indicate we go after
      # 0 means logically same
      return $me->foo <=> $them->foo;
    },
    '""' => sub {
      my $this = shift;
      return join '.' map {
        $this->{$_}
      } qw(field1 field2 field3);
    };

  my @obs = sort $ob1, $ob2, $ob3;

  package LinkedList;
  use ImplictThis; ImplicitThis::imply();

  sub new {
    my $type = shift;
    bless { next=>'', previous=>'' }, $type;
  }

  sub next { return $next; }
  sub set_next { $next = shift; return 1; }
  sub previous { return $previous; }
  sub set_previous { $previous = shift; return 1; }
  sub append { 
    my $ob = shift; $ob->isa(__PACKAGE__) or die;
    $next or do { $next = $ob; $ob->set_previous($this); return 1; }
    $ob->set_next($next);  $next->set_previous($ob);
    $ob->set_previous($this); $this->set_next($ob);
    return 1;
  }

  package TriceQueuedObject;
  use LinkedList;
  use ImplicitThis; ImplicitThis::imply();

  sub new {
    my $type = shift;
    my $me = { 
      sort_order => new LinkedList,
      size_order => new LinkedList,
      save_order => new LinkedList,
      @_
  }

  # create accessors that defer the action to each object, for each object composing us:
  # method A: see text below

  sub next_sort { return $sort_order->next(); }
  sub previous_sort { return $sort_order->previous(); }
  sub set_next_sort { return $sort_order->set_next(@_); }
  sub append_sort { return $sort_order->append(@_); }

  sub next_size { return $size_order->next(); }
  sub previous_size { return $size_order->previous(); }
  sub set_next_size { return $size_order->set_next(@_); }
  sub append_size { return $size_order->append(@_); }

  sub next_save { return $save_order->next(); }
  sub previous_save { return $save_order->previous(); }
  sub set_next_save { return $save_order->set_next(@_); }
  sub append_save { return $save_order->append(@_); }

  # directly return references to objects that compose us:
  # method B: see text below

  sub get_sort_order { return $sort_order; }
  sub get_size_order { return $size_order; }
  sub get_save_order { return $save_order; }

  # using method A:

  $ob->next_sort($ob2);

  # using method B:

  $ob->get_sort_order()->set_next($ob2);

  # a module that exports:

  use Foo;
  foo("module Foo does something with this");

  # a module that doesn't export:

  use Bar;
  my $bar = new Bar;
  $bar->do_something("module Bar does something with this");

  use Bar qw(do_something);
  do_something("module Bar does something without a lot of typing, just like Foo!");

  package Bar;

  sub import {
    my $caller = caller;
    my $foo;
    my $bar;
    my %methods = (
      get_foo = sub { $foo;  },
      set_foo = sub { $foo = shift; },
      get_bar = sub { $bar; },
      set_bar = sub { $bar = shift; },
      do_something =  sub { $foo . ' and ' . $bar . ' sitting in a tree... ' },
    );
    foreach my $i (keys %methods) {
      *{$caller.'::'.$i} = $methods{$i};
    }
  }

  1;

  package Bar;

  sub new {
    my $type = shift;
    my $foo;
    my $bar;
    my $object = {
      get_foo = sub { $foo;  },
      set_foo = sub { $foo = shift; },
      get_bar = sub { $bar; },
      set_bar = sub { $bar = shift; },
      do_something =  sub { $foo . ' and ' . $bar . ' sitting in a tree... ' },
    };
    bless $type, $object;
  }

  sub import {
    my $caller = caller;
    my $methods = PACKAGE__->new();
    foreach my $i (keys %$methods) {
      *{$caller.'::'.$i} = $methods->{$i};
    }
  }

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

  1;

  $me->{$method}->(@_);

  *{$caller.'::'.$i} = $methods->{$i};

  use 5.9.34;
  print "Perl 6 should be just about ready by now!\n";

  package PrintLN;
  use Exporter;
  @ISA = qw(Exporter);

  @EXPORT = qw(println);                 # symbols to export by default
  @EXPORT_OK = qw(printpf);              # symbols to export on request

  sub println { print @_, "\n"; }        # print a line with a line feed
  sub printpf { print @_, chr(0x0c); }   # print a line with a page feed

  package main;
  use PrintPL qw(printpf);

  printpf("This page intentionally left blank.");

  sub import  {
    *{caller().'::printpf'} = sub { 
      print @_, chr(0x0c); 
    };
  }

  use CGI 2.4;

  5 relational principles

  ... XXX

  full-life cycle development

  ... XXX

  OSI layers

  ... XXX

  CVS

  FORK & MERGE

  BACKING OUT CHANGES AND THE LOG

  threads::shared::semaphore - thread::safe semaphores
    use threads::shared::semaphore;
    my $s = new threads::shared::semaphore;
    $s::>up;     # Also known as the semaphore V ::operation.
    # The guarded section is here
    $s::>down;   # Also known as the semaphore P ::operation.


    # The default semaphore value is 1.
    my $s = new threads::shared::semaphore($initial_value);
    $s::>up($up_value);
    $s::>down($up_value);


  threads::shared::queue - thread::safe queues

    use threads::shared::queue;
    my $q = new threads::shared::queue;
    $q::>enqueue("foo", "bar");
    my $foo = $q::>dequeue;    # The "bar" is still in the queue.
    my $foo = $q::>dequeue_nb; # returns "bar", or undef if the queue was
                              # empty
    my $left = $q::>pending;   # returns the number of items still in the queue

  B::Xref - Generates cross reference reports for Perl programs
  perl ::MO=Xref[,OPTIONS] foo.pl

  PeekPoke
  Sys::CPU
  Mmap

  POSIX - Perl interface to IEEE Std 1003.1

    use POSIX;
    use POSIX qw(setsid);
    use POSIX qw(:errno_h :fcntl_h);
    printf "EINTR is %d\n", EINTR;
    $sess_id = POSIX::setsid();
    $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644);
    # note: that's a filedescriptor, *NOT* a filehandle

  Barcode::Code128
  Business::UPS
  Date::Calc

  CGI_Lite
  CGI

  Carp::Assert
  traceFunc
  Test::MockObject
  Test::Class
  Text::Balanced

  Math::LP::Solve
  Math::LinearCombination
  Math::SimpleVariable
  PDL::R::math              Routines from the "R" statistical language. "R" is like "S".
  Statistics::Regression 

  Text::Metaphone
  Text::English             Porter's stemming algorithm  
  Text::NLP
  Festival::Client
  Sort::Naturally 
  Text::Metaphone 
  WWW::Babelfish 

  Error                     Gives try { } catch { } finally { }
  Devel::Coverage
  Devel::Peek
  Inline
  Inline::Files
  Jvm 
  parrot_0.0.6.tgz
  Perl6::Currying
  Perl6::Variables
  Coy
  Safe::Hole
  Safe::b2.tar.gz
  Symbol::Approx::Sub       Call methods by approximate names
  Switch
  PadWalker                 Inspect lexicals from enclosing subroutines
  B::Graph
  Memoize
  Softref
  Sub::Uplevel
  Alias                     Like ImplicitThis.pm, but they beat me to the punch =(
  AnyLoader                 Automatic module loading on-demand
  Apache::Mmap              mmap interface, not sure about Apache assocation
  Attribute::Deprecated
  Attribute::Handlers
  English::Reference        Use words to dereference things - Jerrad Pierce 
  Language::Functional

  Scalar::Utils
  List::Utils 

      blessed dualvar isweak readonly reftype tainted weaken Scalar keywords.
      Weak references, scalar attributes.
      Array::mode sum(), min(), max() etc methods.

  overload 

    Package for overloading perl operations - See OverloadOperators

    package SomeThing;
    use overload
        '+' => \&myadd,
        '::' => \&mysub;
        # etc
    ...
    package main;
    $a = new SomeThing 57;
    $b=5+$a;
    ...
    if (overload::Overloaded $b) {...}
    ...
    $strval = overload::StrVal $b;

  perl::vgalib
  OpenGL
  SDL::sdlpl
  GDGraph3d
  ANSIColor
  Curses
  GD
  Tk
  X11::Protocol

  Compress::Zlib
  File::PathConvert

  IO 

    Load various IO modules
    IO provides a simple mechanism to load some of the IO modules at one go. 
    Currently this includes:

    IO::Handle
    IO::Seekable
    IO::File
    IO::Pipe
    IO::Socket

  IPC::Open3

    open3 - open a process for reading, writing, and error handling

    $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH, 'some cmd and args', 'optarg', ...);

  IPC::Open2

    open2 - open a process for both reading and writing

    use IPC::Open2;
    $pid = open2(\*RDR, \*WTR, 'some cmd and args'); # or
    $pid = open2(\*RDR, \*WTR, 'some', 'cmd', 'and', 'args');

  File::stat 

    By-name interface to Perl's built::in stat() functions

    use File::stat;
    $st = stat($file) or die "No $file: $!";
    if ( ($st::>mode & 0111) && $st::>nlink > 1) ) {
        print "$file is executable with lotsa links\n";
    }
    use File::stat qw(:FIELDS);
    stat($file) or die "No $file: $!";
    if ( ($st_mode & 0111) && $st_nlink > 1) ) {
        print "$file is executable with lotsa links\n";
    }

    File::LockDir
    File::Path
    File::Spec

  
  IO::Socket::SSL
  Crypt::SSLeay
  Crypt::OpenSSL::Random
  Crypt::OpenSSL::RSA
  Crypt::OpenSSL::DSA

  Net::DNSServer        cnpOa Secure and Extensible Name Server
  Net::FTP              adpf? Interface to File Transfer Protocol
  Net::AIM              adpO? AOL Instant Messenger TOC protocol           ARYEH
  Net::AOLIM            RdpO? AOL Instant Messenger OO Interface (TOC)     RWAHBY
  Net::Gnutella         bdpO? Gnutella network (v0.4) interface
  Net::LDAPapi
  Net::NNTP
  Net::ICQ              bmpO? Client interface to ICQ messaging
  Net::IMAP             adpO? Interface to IMAP Protocol (RFC2060)
  Net::IRC              cdpO? Internet Relay Chat interface
  Net::Ident            RdpO? Performs ident (rfc1413) lookups
  Net::POP3             adpO? Client interface to POP3 protocol
  Net::Ping             SupOp TCP, UDP, or ICMP ping
  Net::SFTP             bdpOp Secure File Transfer Protocol client
  Net::SMPP             cdpO? Protocol for sending SMS (to GSM or CDMA).   SAMPO
  Net::SMS              RdpOp Send SMS wireless text::messages.
  Net::SMTP             adpf? Interface to Simple Mail Transfer Protocol   GBARR
  Net::SNMP             MdpOp Object oriented interface to SNMP            DTOWN
  Net::SNPP             cdpO? Client interface to SNPP protocol            DREDD
  Net::SOCKS            cdcf? TCP/IP access through firewalls using SOCKS  SCOOPER
  Net::SSH              Rdphp Perl extension for secure shell              IVAN
  Net::SSL              RdcO? Glue that enables LWP to access https URIs 
  Net::ICQV5CD
  Net::IRC
  Net::Server
  Net::Telnet
  NNTPClient
  SNMP::Util
  Socket6
  X11::Protocol
  Math::ematica
  POP3Client
  Geo::WeatherNOAA
  IPTables
  News::Article
  Mail::Header
  Mail::Internet
  Mail::Mailer
  Mail::Sendmail

  CGI_Lite
  CGI
  URI
  URI::Escape
  Template
  HTML::Mason
  HTML::Parser
  HTML::Template
  CGI::Application
  CGI::Carp
  HTML::Form
  HTML::TokeParser

  DBI
  DBD::JDBC
  DBD::Pg
  DBD::Mysql
  DBD::Oracle
  DBD::Sybase
  Sybase::DBlib
  DB_File

  Storable
  SOAP                      cmpO? SOAP/Perl language mapping 
  SWF::File
  Archive::Any
  Archive::Tar
  Pod::DocBook
  Roman
  ArrayHashMonster
  DateManip
  Mail::MboxParser
  Tie::CArray
  XML::Parser
  XML::QL                   An XML query language
  Spreadsheet::ParseExcel 
  Spreadsheet::ParseExcel::Simple
  MD5
  MIME::Base64
  MIME::Head
  Number::Format
  Crypt::Blowfish
  Date::Calc
  Date::Format
  Date::Parse
  Date::Simple
  Digest (and friendes SHA/MD5, etc)
  Compress::Zlib
  Archive::Tar
  Archive::Zip

  Clone                     idch? Recursive copy of nested objects             RDF
  FreezeThaw                bdpf? Convert arbitrary objects to/from strings    ILYAZ
  Persistence::
  Class::Object             adpO? Store Object definitions with Data::Dumper   VIPUL
  Storable                  Smcrp Persistent data structure mechanism          AMS
  Marshal::Dispatch         cdpO? Convert arbitrary objects to/from strings    MUIR
  Marshal::Packed           cdpO? Run::length coded version of Marshal module   MUIR
  Marshal::Eval             cdpO? Undo serialization with eval                 MUIR
  Tangram                   RmpO? Object persistence in relational databases   JLLEROY
  Module::Reload
  Module::Require
  Module::Use
  Class::Container
  Class::Contract
  Class::Contract
  Class::Date (high MilliGraham weight)
  Class::DBI
  Class::Inner
  Class::Loader
  Class::MethodMaker
  Class::Multimethods
  Class::ObjectTemplate
  Class::Observable
  Class::Privacy
  Class::PseudoHash
  Class::Singleton
  Class::Virtual
  Class::Visitor
  Class::Data::Inheritable
  Class::Delegation
  Class::Fields
  Interface::Polymorphism  Gives "implements" and "interface" keywords.
  import                   use import qw( org::w3c::dom );  # Loads all .pm's in org/w3c/dom/*
  NEXT                     Redispatch method lookups
  Event                    Base implementation of channel/event listeners and daemon
  Concurrent::Object       See MailOrder - fires off a method call in the background
  Protect
  Sub::Parameters - http://search.cpan.org/author/RCLAMP/Sub-Parameters-0.03/lib/Sub/Parameters.pm

  Persistent::Base             bdpO? Persistent base classes (& DBM/File classes) DWINTERS
  Persistent::DBI              bdpO? Persistent abstract class for DBI databases  DWINTERS
  Persistent::MySQL            bdpO? Persistent class for MySQL databases         DWINTERS
  Persistent::Oracle           bdpO? Persistent class for Oracle databases        DWINTERS
  Persistent::Sybase           bdpO? Persistent class for Sybase databases        DWINTERS
  Persistent::mSQL             bdpO? Persistent class for mSQL databases          DWINTERS
  Persistent::LDAP             bdpO? Persistent class for LDAP directories        DWINTERS
  Persistence::Database::SQL
  Persistence::Object::Postgres
  Storable
  CGI::Persistent

  CORBA::IOP::IOR              adpO? Decode, munge, and re::encode CORBA IORs      PHILIPA
  CORBA::IDLtree               Rdpf? IDL to symbol tree translator                OMKELLOGG

  Bone::Easy
  Sex 
  Acme::Inline::PERL
  Class::Classless - http://search.cpan.org/author/SBURKE/Class-Classless-1.34/Classless.pm

        Authen::SASL
        Bit::Vector (broken)
        CPAN
        Devel::Cover
        Devel::Coverage (broken, but not sure since we got Devel::Cover)
        Devel::Peek
        Expect
        Event
        FCGI
        LWP
        Mon
        Pod::Man (used by Makefile generated by Makefile.PL)
        POE
        PDL (very large, complex and lots of XS)
        Time::HiRes
        WxPerl? (lots of XS, very chummy with MakeMaker?)

  =pod   Starts a chunk of documentation. The tags below are then valid.

  =cut   Ends a chunk of documentation, returns to code.

  =head1 Heading

       1st level header.

  =head2 Heading 

       2nd level header.

  =over n

       Starts an enumerated list indented n spaces. 

  =item Text

       A bullet item in an enumerated list.

  =back  

       Ends an enumerated list.

  =begin FMT

       Subsequent text up to a matching =end is only included when processed for formatter FMT.

  =end FMT

       End enumerated list.

  =for FMT

       Following paragraph is included conditionally if formatter FMT is used.

  B Bold - for command-line switches and program names.

  C Code

  E Escape - Character names from HTML escape sequences, eg lt, gt, amp

  F Filename

  I Italics

  L Link - Cross reference. 

      May be a URL, name of a man page, or the name of =head1, =head2, or =item.
      May contains optional quotes. A slash may be used to seperate the name of a man page from the section in the man page.

  S Non-breaking string - will not linewrap on spaces

  X Index entry.

  =head1 NAME

  Bleah::D::Bleah - Put the actual name of the program there give a 
  sentance about it here

  =head1 SYNOPSIS

  ..short usage example

  =head1 DESCRIPTION

  ..what it's used for. The body of the document is contained here or
  in subsections.

  =head1 EXAMPLES

  ..how to use it

  =head1 SEE ALSO

  ..related works: other modules, programs, RFCs

  =head1 AUTHORS

  ..names, email addresses of authors

  <book>, <chapter>, <section>

  # all the time
  cvs commit file          sends changes to repository
  cvs update file          freshens your files
  
  # useful too
  cvs diff files           compare your files to repository
  cvs log file             comments on changes in each file
  cvs update file          merge in changes from the repository
  cvs update -j currentrev -j previousrev file 
                           regress to a previous version
  
  # not very often
  cvs tag string files
  cvs add files            introduce to repository pending commit
  cvs remove files         nuke file from repository
  cvs checkout file        get a file or project initially
  

  $Id: CvsQuickRef,v 1.5 2003/01/24 16:08:41 httpd Exp $
  $Author: httpd $
  $Revision: 1.5 $

  (my $version) = '$Revision: 1.5 $' =~ /([\d\.]+)/;

       If you want to release a 'beta' or 'alpha' version of a
       module but don't want CPAN.pm to list it as most recent
       use an '_' after the regular version number followed by at
       least 2 digits, eg. 1.20_01. If you do this, the following
       idiom is recommended:

         $VERSION = "1.12_01";
         $XS_VERSION = $VERSION; # only needed if you have XS code
         $VERSION = eval $VERSION;

       With that trick MakeMaker will only read the first line
       and thus read the underscore, while the perl interpreter
       will evaluate the $VERSION and convert the string into a
       number. Later operations that treat $VERSION as a number
       will then be able to do so without provoking a warning
       about $VERSION not being a number.

  our $VERSION = '0.02';
  $VERSION = eval $VERSION;  # see 

  http://www.pobox.com/~schwern/cgi-bin/perl-qa-wiki.cgi?ModuleNaming

   [1] Notes on Synthesis of Form - Christopher Alexander, Ale 1964
   [2] A Pattern Language - Christopher Alexander,  Ale, 1977 ISBN 0-19-501919-9
   [3] Design Patterns: Elements of Reusable Object Oriented Code, Gang of Four, XXX
       C2 DesignPatternsElementsOfReusableObjectOrientedSoftware 
       DesignPatternsBook by the GangOfFour
   [4] Refactoring: Improving the Design of Existing Code, XXX MartinFowler's book, ISBN 0201485672 .
       C2 RefactoringImprovingtheDesignofExistingCode
   [5] Ward et el. http://c2.com/cgi/wiki/
        C2 FunctionalPatternSystemForObjectOrientedDesign
   [6] Bitter Java ISBN 1-930110-43-X (not my favorite)
   [7] Applied Java Patterns ISBN 0-13-093538-7 (very good)
   [8] Java Threads, O'Reilly (very good)
   [9] Joy of Patterns - Brandon Goldfedder - ISBN 0-201-65759-7  (good)
   [10] "Object Oriented Perl", Damian Conway (good)
   [11] Advanced Algorithms in Perl
   [12] Structure and Interpretation of Computer Programs by Harold Abelson, Gerald Jay Sussman and Julie Sussman (very good)
        C2 StructureAndInterpretationOfComputerPrograms
   [13] perlmodlib
   [14] perlnewmod
   [15] http://www.cpan.org/modules/00modlist.long.html
   [16] Anti-Patterns, ISBN 471197130 
   [17] Elements of Programming with Perl, ISBN 1-884777-80-5, Andrew Johnson
   [18] Practice of Programming, Brian W. Kernighan, Rob Pike, ISBN 0-201-61586-X
   [19] Object Oriented Design Heuristics, Arthur J. Riel, Prentice Hall, ISBN 0-201-63385-X
   [20] The Mythical Man Month, Frederick Brooks
        C2 TheMythicalManMonth - the greatest project management book ever written
   [21] Pattern Language of Program Design 4
   [22] 6.170 Software Laboratory, MIT Open Courseware: http://ocw.mit.edu/6/6.170/f01/lecture-notes/index.html
    http://mitpress.mit.edu/sicp/full-text/book/book.html - available online
   [23] Zen and the Art of Motorcycle Maintenance
        C2 ZenAndTheArtOfMotorcycleMaintenance - ideas on quality as the essense of existance
   [24] StructuredProgramming, Dahl, Dijkstra, TonyHoare, Academic Press, 1972

  $a = wussup;

  $a = "wussup";

  # this is a comment
  $a = 10; # and so is this

  # CGI.pm does this to learn about local linefeed insanity:
  $OS = $Config::Config{'osname'};

  print "Search path: ", $ENV{PATH}, "\n";

  my @files = grep { $_ !~ m/^\./ } sort readdir $fh;

  my @files = get_file_list($ENV{'HOME'}, '.', `pwd`);

  print (32/8)+10; # this prints "4"

  print((32/8)+10); # this prints "14"

  sprintf "The number is: %d\n", 0 && return; # this won't return

  sprintf "The number is: %d\n", 0 and return; # this will return

  substr($foo, $i, 1); 

  *pi = \3.14159; # I'm not a math geek

  @array = (1, 2, 3, 'hi');

  function(9, 10, @array);

  function(9, 10, 1, 2, 3, 'hi');

  use warnings;
  my $sum = 0;
  my @prices = (10.95, 15.95, 5.95, 25.95, 45.95);
  foreach my $price (@prices) {
    $sum += $price;
  }
  print "$sum was yesterdays price. It isn't valid anymore. Sorry! Offer expired!\n";
  $sum = undef;
  print "The total for this order is: $sum\n"; # this gives an error message

  if(undef == 0) { print "True\n"; }

  my $a = undef;
  if($a == 0) { print "True\n"; }

  if(defined my $line = <>) {
    # deal with more frivelous user demands
  }
  # user has shut up now and hit Control-D or closed the connection