PatternLanguage, IntroductionPattern, PerlAndPatterns, PrefacePattern Resources to tap, tangent subject, and more information: PerlPatternsResources, ReferencesMeta Perl Design Patterns excerpts as a Perl Mongers presentation: http://www.slowass.net/~phaedrus/slides/ Say "Hi", information about the project: GuestLog, AboutPerlPatternsProject, PerlPatternsToDo
AbstractRootClasses StateVsClass
DesignPatternCatalog
CommandProcessingChainOfResponsibility RouterPattern ModelViewController BeamPattern
WrapperModule AnonymousSubroutineObjects InnerClassHoldingOntoParentContext InnerClassHoldingOntoParentInstance GeneratedRoutinesOperatingOnObjects GeneratedMethods ConstraintSystem RevisitingNamespaces FakingAccessorsUsingTiedData FakingAccessorsUsingAutoload FakingDelegationUsingAutoload
NamedArguments PassingState FunctionTemplating JournalingPattern AssertPattern ExportingFunctionsWhichAreLexicallyBoundToGenerators SelectPollPattern MemoizationPattern KeepItSimple CodeAsData NonReenterable
WebAuthentication ConfigFile ErrorReporting ExtensibilityPattern ModuleReloadsOnChange
None of these are filled in yet, just placeholders, sorry. Mix and match, as usual. DecisionSupport DatabaseSystem KnowledgeBase TroubleTicketDatabase WorkFlow CollaborationGroupware InventoryFulfillment DaemonProcess
AntiPatterns - Negitive examples, just for fun
AboutRefactoring RefactoringPattern GeneralizePattern ExpressionsBecomeFunctions BreakDownLargeFunctions LocalVariablesReplaceGlobalVariables GlobalToLexical SoftrefsToHash TooManyVariables TooManyArguments LexicalsMakeRefactoringEasy MoveLargeDatastructuresToContainers MoveCollectionsOfFunctionsToObjects WholeObject SuperClassAbstraction ConditionalElimination TemplateMethodFromSubclassCommonalities OneToOneRelationshipsTurnIntoOneToManyRelationships BidirectionalRelationshipToUnidirectional IntroduceNullObject RemoveMiddleman MixingPerlSqlHtml
ConceptsCrossReference OnceAndOnlyOnce WhereItBelongs LooseCoupling TypeSafety DesignContract LayeringPattern PrototypeConcept PolicyVsImplementation FunctionalProgramming
ReferencesMeta OtherStructuredSystems SelectCPANModules ObjectOrientationOrientation BasicPerlOOSyntax PerlOoNutsAndBolts HowDoesPerlStackUp PerlDoc DocBook CvsQuickRef ClassNaming
PlanToThrowOneAway ArtAndScience HowPerlDiffersFromCPerl Design Patterns is a book in progress. Will it sell? Probably not. Will it make a great series of http://phoenix.pm.org presentations? Damn stright. See IntroductionPattern for more information.
PerlDesignPatterns GuestLog http://wiki.slowass.net/everything.cgiWelcome to TinyWiki!
Have Fun! - ScottWalters$Id: HomePage,v 1.6 2002/10/19 01:30:15 httpd Exp $
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 TypedVariablesReading through the table of contents at PerlDesignPatterns, things will seem out of order. They are. TopDownDesign dictates that we start with the largist elements - ApplicationTypes - and work towards the nuts and bolts. The cookbook approach dictates that the nuts and bolts be presented, and users will know what to do with them.
InvariantsArentAlwaysConstants CopyThisBook RandomThoughts WorseIsBetter IdiomaticProgramming HowPerlDiffersFromC
Cheers! -scott
Links Related to PerlDesignPatterns (mostly on WikiWiki): Perl Design Patterns Sites: http://patternsinperl.com/ - Nigel Wetters' less complete but more polished site http://hatena.dyndns.org/~jkondo/DesignPattern/ - less talk, more code! http://magnonel.guild.net/~schwern/talks/Design_Patterns/full_slides/ http://magnonel.guild.net/~schwern/talks/Refactoring/slides/ My (Yet Incomplete) List of References: ReferencesMeta Individual DesignPatterns: TransactionsAndAccounts on WikiWiki PerlSingleton on WikiWiki - a daemon-like object that is singular by nature ValueObject on WikiWiki - from FunctionalPatternSystemForObjectOrientedDesign ResultObjectPattern on WikiWiki - use a type/interface to communicate complex results C2 RunAndReturnSuccessor - implement the state transitions in your program as objects InfocomZork on WikiWiki - the natural language parser is brilliant due to a simple idea http://www.samag.com/documents/s=1273/sam05020007/ - ThePerlJournal's Iterator http://ask.slashdot.org/article.pl?sid=02/10/15/2352256&mode=thread&tid=156 - UI Design Patterns Individual AntiPatterns: C2 AntiPatterns - how not to do it, and what to do if you do EveryNightAtMidnight on WikiWiki - polling without wait/notify is inheriently problematic ArrowAntiPattern on WikiWiki - nested ifs and whiles should refactor to objects and methods respectively BackPedalling on WikiWiki - having to recreate state: symptom of insufficient state VoodooChickenCoding on WikiWiki - symptoms of desperation or paranoia C2 FeatureEnvy - "... a method that seems more interested in a class than the one its in.." http://www.jwz.org/doc/java.html - Why Java sucks - we've overcome many of these but good lessons to learn! http://www.rahul.net/kenton/40errs.html - 40 most common XWindows programming mistakes Other DesignPatterns Stuff: http://www.samag.com/documents/s=1280/sam02010001/ - Program Like Ya Mean It: TPJ http://perlmonks.org/?node_id=193340 - Are Design Patterns Worth It? http://perlmonks.org/index.pl?node_id=133399 - Design Patterns Considered Harmful http://perl.plover.com/yak/design/ - "Design Patterns" Aren't - Dominus http://www.norvig.com/design-patterns/ - Design Patterns in Dynamic Languages Refactoring: WikiPagesAboutRefactoring on WikiWiki Background and cool information: http://www.perlmonks.org - Perl Monks GreatProgramsToRead on WikiWiki WhenToUseInnerClasses on WikiWiki - alternative to multiple inherits, too many interfaces DontNameClassesObjectManagerHandlerOrData on WikiWiki - touches on many design ideas in conjuction DualityBetweenStateAndClass on WikiWiki - given kinds of things, at which point to make subclasses? LexicalClosure on WikiWiki - give a code ref to continue an evaluation which was started and has state BizarreLoveTriangleInJava on WikiWiki - solution looks like multiple inheritance, tho the InfocomZork parser certainly cuts it http://www.cs.rit.edu/~afb/20013/plc/slides/procedures-07.html - Jensen's Machine - local value pools http://www.cs.rit.edu/~afb/20013/plc/slides/procedures.html - Wow - Language Cencepts http://www.construx.com/seminars/onsite/topic-intro-oo.htm -- Good OO outline http://industriallogic.com/papers/learning.html - a learning guide to the GoF book http://java.sun.com/people/jag/Presentations/TheStoryOfJava/img20.htm - Java's Design Principles http://java.sun.com/people/jag/pathfinder.html - Prioty Inversion with Thread Deadlocks http://conferences.oreillynet.com/pub/w/15/presentations.html - Perl Presentations http://www.htdp.org/2002-05-09/Book/curriculum-Z-H-1.html - How to Design Programs http://www.cs.indiana.edu/eopl/ - Essentials of Programming Languages http://www.devx.com/dotnet/articles/ym81502/ym81502-1.asp - Perl & .NET Interop via Interfaces http://slashdot.org/article.pl?sid=02/08/28/1655207 - Literate programming http://www.cs.uu.nl/people/franka/ref - Programming Language Theory Texts - Excellent! C2 FunctionalProgramming http://www.slowass.net/phaedrus/todospool.pl?mesgid=29 - Never Rewrite Software http://www.bagley.org/~doug/shootout/ - Language Shootout - Awesome! http://icfpcontest.cse.ogi.edu/ - Functional Programming Competition - all languages welcome! http://www.gnu.org/prep/standards_toc.html - GNU Coding Standards http://www.advogato.org/article/539.html - Long term programming techniques http://www.ultratechnology.com/forth.htm - Thoughtful programming in Forth http://www.csd.uwo.ca/gradstudents/chicha/aa.html - Algorithm Animations http://www.owasp.org/guide/ - Web Applications Security Paper http://www-106.ibm.com/developerworks/linux/library/l-genperl/?t=gr,lnxw01=PerlGenetics Genetic Algorithms in Perl http://www.osnews.com/story.php?news_id=1901&page=1 - Fred Brooks references http://www.riehle.org/vuw-mirror/CS-TR-02-9.pdf - Postmodern Programming http://ask.slashdot.org/askslashdot/02/10/26/2223230.shtml?tid=156 - Programming Disasters http://savannah.nongnu.org/projects/latex-manual/ - Free LaTeX manual http://savannah.nongnu.org/projects/style-guide/ - Programming Style Guide http://savannah.gnu.org/projects/wcpp-book/ - Webclient Programming In Perl, Free Book http://savannah.nongnu.org/projects/pup/ - Picking Up Perl, Free Book http://documentation.perl.org/ - Perl Documentation Project http://ocw.mit.edu/6/6.170/f01/index.html - MIT Open Courseware - Software Engineering Lab http://perl.about.com/cs/intermediateperl/ - http://about.com 's Intermediate Perl Area http://perl.about.com/cs/advancedperl/ - http://about.com 's Advanced Perl Area http://perl.about.com/library/glossary/blglossary.htm - http://about.com 's Perl Glossary http://www.wall.org/~larry/perl.html - LarryWall 's Perl page http://www.pobox.com/~schwern/talks/ http://www.pobox.com/~schwern/cgi-bin/perl-qa-wiki.cgi - MichaelSchwern's Perl Wiki! Related email to/from me: My initial post to PheonixPerlMongers list: http://www.slowass.net/phaedrus/todospool.pl?mesgid=104 Perl with Meta-Lists a la Lisp http://www.slowass.net/phaedrus/todospool.pl?mesgid=42 Conversation with JB: http://www.slowass.net/phaedrus/todospool.pl?mesgid=75 http://www.slowass.net/phaedrus/todospool.pl?mesgid=76 http://www.slowass.net/phaedrus/todospool.pl?mesgid=77 SecondSystemSyndrome care of PerlSixInternals: http://www.slowass.net/phaedrus/todospool.pl?mesgid=63 Many assorted thoughts on things: http://www.slowass.net/phaedrus/todospool.pl?mesgid=41 Speaking and Publishing Tips: http://www.advogato.org/article/549.html - How to get a conference topic accepted Excerpts:"The whole point of objects is that they are a technique to package data with the processes used on that data. A classic [code] smell is a method that seems more interested in a class other than the one it is in. The most common focus of the envy is the data."
h2xs -AX -n Net::AcmeThe -A omits the Autoloader code, -X omits XS elements, and -n specifies the name of the module
[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 DesignPatternsElementsOfReusableObjectOrientedSoftware on WikiWiki DesignPatternsBook by the GangOfFour [4] Refactoring: Improving the Design of Existing Code, XXX MartinFowler's book, ISBN 0201485672 . RefactoringImprovingtheDesignofExistingCode on WikiWiki [5] Ward et el. http://c2.com/cgi/wiki/ FunctionalPatternSystemForObjectOrientedDesign on WikiWiki [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) StructureAndInterpretationOfComputerPrograms on WikiWiki [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 TheMythicalManMonth on WikiWiki - 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 ZenAndTheArtOfMotorcycleMaintenance on WikiWiki - ideas on quality as the essense of existance [24] StructuredProgramming, Dahl, Dijkstra, Hoare, Academic Press, 1972$Id: ReferencesMeta,v 1.10 2002/11/06 10:03:04 httpd Exp $
tar -xzvf X11-Protocol-0.04.tar.gz cd X11-Protocol-0.4 perl Makefile.PL make make test make installThis makes a great number of assumptions - that you've downloaded the 0.04 version of the module using a text mode fetch utility and are still sitting in that shell window looking at the freshly downloaded module, and that it is an appropriate place to uncompress an archive, among other things. The case where you stop because of an error and seek help is neglected as well. Reguardless, this is the standard way to install any random Perl module you come across. CreatingCpanModules talks about the flip side of the process.
#!/usr/bin/perl use X11::Protocol; use IO::Select; my $x = X11::Protocol->new(); sub res { $x->new_rsrc() }; my $eventmask = $x->pack_event_mask(qw(KeyPress Exposure ButtonPress ButtonRelease PointerMotion)); $x->CreateWindow(my $win = res(), $x->root, 'InputOutput', $x->root_depth, 'CopyFromParent', 0, 0, 600, 400, 1, 'background_pixel' => $x->white_pixel, 'event_mask' => $eventmask, ); $x->ChangeProperty($win, $x->atom("WM_NAME"), $x->atom("STRING"), 8, 'Replace', 'Perl Paint'); $x->MapWindow($win); $x->event_handler(do { my @lastxy; my $buttonpressed = 0; $x->CreateGC(my $black = res(), $win, 'foreground' => $x->black_pixel, 'graphics_exposures' => 0); $x->CreateGC(my $white = res(), $win, 'foreground' => $x->white_pixel, 'graphics_exposures' => 0); sub { my %e = @_; if($e{name} eq 'MotionNotify') { $x->PolyLine($win, $black, 'Origin', @lastxy, $e{event_x}, $e{event_y}) if $lastxy[0] and $lastxy[1] and $buttonpressed; @lastxy = ($e{event_x}, $e{event_y}); } elsif ($e{name} eq 'ButtonPress') { @lastxy = ($e{event_x}, $e{event_y}); $buttonpressed = 1; } elsif ($e{name} eq 'ButtonRelease') { $buttonpressed = 0; } elsif ($e{name} eq 'Expose') { $x->PolyRectangle($win, $white, [($e{'x'}, $e{'y'}), $e{width}, $e{height}]); } }; }); my $sel = IO::Select->new($x->connection->fh); while(1) { for my $fh ($sel->can_read) { $x->handle_input if $fh == $x->connection->fh; } }Don't expect to understand the entire program. It is here to give you the flavor of a low-level windowing interface and the authors gung-ho programming style. The first thing to notice when browsing through this code is that my bracket style probably doesn't match yours, and the code swims with strange symbols, often clustered in frightening little posses. It makes heavy use of my to declare LexicallyScopedVariables, and lots of brackets to create and dereference datastructures. Aside from that, it looks somewhat like C.
# # Tomatos, olives, and guacamole cost extra # if($topping eq 'tomato') { $price += 0.05; } elsif($topping eq 'olive') { $price += 0.25; }Is this a bug? I don't know! You can't tell. Someone must have changed something about guacamole at some point and missed changing things in one spot.
package Color; sub new { my $type = shift; bless { }, $type; } sub set_color { my $me = shift; my $color = shift; $me->{'color'} = $color; } sub get_color { my $me = shift; return $me->{'color'}; } package main; use Color; my $c1 = new Color; $c1->set_color('green'); my $c2 = new Color; $c2->set_color('blue'); print "c1: ", $c1->get_color(), " c2: ", $c2->get_color(), "\n";Even though both $c1 and $c2 are instances of the "Color" object, they have different values. We call these variables "instance variables" because the variable is associated with a specific instance of the class.
# 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; }$this->{'lastx'} is hardly a worthy substitute for being able to merely say $lastx and have the language remember the fact that $lastx is an instance variable. This requirement is going a long way towards making our little program ugly. For longer functions, we can make some symbol table aliases to allow us to access things inside of a hash or array using a short name:
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; }This just makes the problem worse for shorter functions, cluttering them with unneeded syntax. As a comprimise, you can use this trick for large functions where instance variables are referenced over and over again, and for short functions, use the plain old hash dereference syntax that you already know and tolerate. Don't like those options? Me either. Lets see what else we can dig up:
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(@_); }Including these methods at the top of your class will allow you to abbreviate method classes:
sub set_x { private @_, sub { $x = shift; }; }Call public() or private() with the arguments and a subroutine to execute. public() will run the passed subroutine unconditionally, while private() will only run it if your method was invoked from within the object. If another object or package tries to invoke your private method directly, it will generate an error message:
Cannot invoke private method Yawn::setb_x from outside Yawn at foo.pl line 17.Additionally, you don't need to say $me->{'x'} to get at your "x" field: you can refer to it directly as $x. For each value in the object hash, a local temporary alias is set up with the same name. $this is set to $me in the same way, which is similar to what other languages provide.
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; }ImplicitThis::imply() is called separately because ImplicitThis.pm needs to wait until your package finishes loading before taking action. When imply() is run, it looks through your name table, finds all of the functions, and puts a thin wrapper around them. The wrapper creates temporary aliases to all of the instance variables, once again giving them the same name.
package SerialNumbered; my $globalSerialNumber; sub new { my $type = shift; $serialNumber++; my $me = {@_, SerialNumber=>$serialNumber}; bless $me, type; }This example keeps a serial number in a variable. Every object has access to this, in addition to their own "SerialNumber" instance variable.
print ${ref($obj).'::globalSerialNumber'};This assumes that $obj is an object of type SerialNumbered, and $globalSerialNumber were a "local" instead of a "my" variable.
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; }; }Another option is to step inside of another object and access the variable directly. When we do this, we use knowledge about the underlining datatype used to construct the object, in this case a hash:
$stock->{'price'} *= 2; # Rather than the more OO: $stock->set_price($stock->get_price() * 2);Of course, if anyone does that to our neat little package, they void the warranty.
$foo->query_ob()->set_bar($baz->query_qux());While the basic arithmetic, logic, and other operators represented by symbols in languages (especially in Perl) account for 99% of what people want to do at any given moment, reading OO code gives you the impression that the only one that hasn't been robbed of its usefulness is the -> operator. [ I think you could elaborate on this more. I think I know what you are talking about, but I'm not sure. :) - JustThisGuy ] This is hardly expressive. You have to fetch everything you want to do a computation on into a variable, do your operation, then use an accessor to stow this value away where it belongs. *
# 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; }; }A lot of this is out of the scope of this chapter. You can read on, you can employ faith and cut and paste this into your code, or you can just rest assured that there is a solution to the "-> is the only useful operator" problem.
$datastructure{'color'} = \$color;The backslash operator takes a reference of a scalar, hash, array, etc. We store this reference in something else. Code, created by with the sub { } mechanism, can store references, too. It looks a little bit different:
my $foo_value; my $foo_logic = sub { # code $foo_value; # code };There are two secret ingredients to make this work. First, the value that we want to keep a reference to in our code must be declared using "my". Second, we use that variable normally in our sub { } block from a place where that variable is visible. This is before the end of the code block that the variable was defined in - be it a subroutine, eval, do. If it was defined outside of any of those, it is visible until the end of the file. If we define $color_value and $name_value inside of the subroutines, they would get created each time these subroutines are evaluated, then forgotten when they returned. By declaring the variables outside, the subroutines hold on to already existing variables, and they retain their values from call to call. Thats really all there is to it!
$ob->get_value() += $ob->query_value() * $economy->query_inflation();2. If someone completely bypasses our accessors, it doesn't matter one bit: our logic still runs.
$ob->{'color'} = 'blue'; # this blows up because we're able to trap itSee also: Class::Accessor on CPAN will make accessors for you, programatically.
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}; }This is the play() method from our TradingFloor.pm example. We mentioned this briefly in ObjectOrientationOrientation, but it bears lassification [ classification? - JustThisGuy ]. Each object passed in is tested to see if they fit that type. For ->isa(), either being blessed into that package directly, or inheriting from that package will work. In the case of references, check the reference type directly:
my $arrayref = shift; ref $arrayref eq 'ARRAY' or die;Given a bless object, ref() will return its blessed type, but this usual isn't what we want: see CheckingTypeInsteadOfMembership. For references, it will return 'ARRAY', 'HASH', 'SCALAR', 'GLOB', or one of several other possible values XXX.
die unless $ob->isa('Number::Complex'); or more typically: if(!$ob || $ob->error) { print "well that didnt work\n"; }When variables are created to hold exactly one datatype, we often do a lot of checking to make sure thats the case. This clutters up code. Perl is difficult enough to understand without clutter.
package TypedScalar; sub TIESCALAR { my $obj; my $type = $_[1]; my $foo = sub { return $obj unless @_; my $arg = shift; die sprinf "Incorrect type in assignment: %s at line %d in %s\n", ref($arg) || 'primitive', (caller)[0, 1] unless defined $arg or (ref $arg and $arg->isa($type)); # correct caller fields? $obj = shift; }; bless $foo, $_[0]; } sub STORE { my $me=shift; $me->(@_); } sub FETCH { $_[0]->(); } package main; use TypedScalar; use CGI; use XML::Parser; tie my $cgi, 'CGI'; # or: new TypedScalar my $cgi, 'CGI'; XXX add 'new' method $cgi = new CGI; # ok $cgi = undef; # ok $cgi = 10; # dies $cgi = new XML::Parser; # diesThis is "runtime type checking". Some languages do this checking at compile time. If we had that, it would prevent the program from ever reaching the "die" point: if it were even possible to reach it, the program wouldn't compile.
sub muckWithSomething { caller eq PACKAGE__ or die; my $self = shift; my $arg = shift; # code here using $self and $arg }When you write something yourself, you can usually remember what parts of objects you plan to keep around and which parts you want to keep open to revision. You may, on the other hand, completely forget this, or collaborate with other programmers. This gets you stuck in the trap of having to keep making your object exactly the same way. OO says that the implementation should be separate from the interface. Opting to not allow foreign code to access your internals buys you privacy and freedom to change around your internals.
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 }Then the store adds paper, toner, refill kits, cables, dye sublimation ink, impact ribbons, and new ribbons. Then the store starts giving discounts for toner and inkjet cartridge returns. Then you're asked to give warnings if someone tries to buy a new printer with the wrong kind of paper or ink. Fields are introduced to specify compatibilty and compatibility requirements, as well as return discount amout and eligability.
package Item; sub import { push @{caller().'::ISA'}, PACKAGE__; }Viola! Whenever anyone uses Item.pm, their package will be marked as being (is-a) Item. Should that object ever be tested with ->isa('Item'), it will come back true. We have this one bit of @ISA munging logic in the abstract marker class rather than:
use Item; push @ISA, 'Item';...floating around everywhere.
# 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}; } }interface.pm by yours truly (look for it on CPAN) implements compile-time interface checking in Perl, similar to the example above, merely with a cleaner interface itself:
use interface 'Class::Struct', 'Clonable';This tells Perl that we must define all of the methods listed in Class::Struct as well as Clonable. If we fail to, we don't compile, and we don't run.
package BetterGronkulator; @ISA=('Gronkulator'); sub new { my $type = shift; my $me = SUPER::new($type, @_); $me->{'spiffyNewThing'} = new BetterGronkulator::SpiffyNewThing; return $me; }We let SUPER::new() (our parent's new() method) create the object for us. If they do it correct, using the type in the first argument, we don't need to bless it. We are now free to modify the object however suits us. Here, we're creating a new object and storing a reference to it. This lets us add to the features of a class without having to rewrite their entire constructor, and risk having it change in a future version. If someone extends us, they can apply this same pattern, and add features to what we do.
# redefining compute_gcd() in a sublass won't affect this code $gcd = compute_gcd($x, $y);They will continue using the methods and functions defined in the same class as themselves, unless they go out of their way:
# this will use the top-most version of compute_gcd() $gcd = $this->compute_gcd($x, $y);A method that does some work, but passes off sub-tasks using the -> syntax is said to be a "template method". This method forms the basis for an operation, but is open-ended. Its behavior can be tailored, customized and specialized in subclasses. This aids in code re-use.
sub new { my $type = shift; $type = ref $type if ref $type; my $this = { }; bless $this, $type; }Line 3 does the work of making sense out of either a package name or a reference. The normal case is a scalar containing the package name. Thats the case with:
MyPackage->new(); ... and ... new MyPackage;The new case we handle is when someone already has a reference but wants a new one:
$anothermypack = $mypack->new();
($foo = $bar) * 100;In Perl, the result of an assignment is the variable that got assigned to. This lets you chain operations. It is pleasant to be able to do the same thing objects:
$fooOb->setBar($bar)->multiply(100);Instead of returning "1", we return $fooOb back, to be used again.
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(); }The full listing is available at XXX. WebsafeColors::Iterator implements all of the functions required to be an instance of Iterator. If something takes an argument, and insists it implement Iterator, it will accept the result of calling getIterator() on a WebsafeColors object. However, WebsafeColors itself does not implement these methods, or inherit the base abstract class for Iterators. The package that does is contained entirely inside WebsafeColors's getIterator() method. This technique lets you localize the impact of having to provide an interface, and keep code related to supporting that interface together and away from the rest of the code. This supports the basic idea of putting code where it belongs.
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); };Your object now knows how to stringify itself, and can be sorted and compared to like objects:
my @obs = sort $ob1, $ob2, $ob3;More importantly, you can test objects for equality using a benchmark other than rather or not the two pointers reference the exact same object.
package SomeThing; use overload '+' => \&myadd, '-' => \&mysub; # etc ... package main; $a = new SomeThing 57; $b=5+$a; ... if (overload::Overloaded $b) {...} ... $strval = overload::StrVal $b;B
One to one correspondence between two different things: a person has one social security number and a social security number refers to one (living) person. One object may refer to several others: a person may oven several pets. An intersection of sets: many people have tried many flavors of ice cream. Asking a person which ice cream flavors they have tried returns a list; asking which people have tried a flavor of ice cream also returns a list.In the same way, object oriented systems that aren't backed by a database still have one to one, one to many, and many to many relationships between the objects. It can be useful exercise to sit down with pencil and paper and map out which kinds of relationships which kinds of objects are going to have. This often exposes design limits in a system where the things can happen in reality that the software isn't prepared for.
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(); }This makes it easy to navigate relationships in a relational database system, but doesn't do a lot for us in the way of reporting.
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; }We can inherit this, but inheriting it multiple times doesn't do us any good: we only ever have one instance of the LinkedList this way - ourselves. Using composition gives us what we want:
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; }Where it says "method A" and "method B" illustrate two very different approaches to giving users of our object access to the our parts. "Method A" creates all new accessors which do their work by calling accessors in the composing objects. "Method B" simply returns the composing objects and lets the user call the methods directly. For example:
# using method A: $ob->next_sort($ob2); # using method B: $ob->get_sort_order()->set_next($ob2);Which is better? Well, it depends. If your object is merely a container for other objects, B makes more sense. If your object is a Facade, providing a new interface to several objects, A makes more sense. If you consider the objects you contain to be implementation dependent, and you don't want to have to support returning intermediate objects in the future, A lets you hide your implementation better. B makes for shorter code and less typing when the relationship between the objects isn't likely to change.
# 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");If you're only reasonably going to be using one instance of a "Bar" object, why go through the hassle of giving it a name ($bar)? Which object we're talking about when we say do_something("bar!") is unambiguous as well - we only have one Bar object to call it in. The handiness of the first approach is so loved that many modules that provide a strictly OO interface (as in the second example, Bar) also provide a syntactical sugar, exporter interface as well (as in the first example). This is accessed, by convention, as:
use Bar qw(do_something); do_something("module Bar does something without a lot of typing, just like Foo!");Here, we tell Bar just to make the method do_something() available to us. If Bar creates a single instance of an object behind the scenes, so be it - we never have to know.
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;This example uses LexicallyScopedVariables to generate a scalar for each package that imports our logic. In other words, if multiple packages use Bar, each gets copies of set_foo(), get_foo(), do_something(), and so on, but each package has its own private values for $foo and $bar used by these functions. One packages actions won't step on another packages data.
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;We're coming in from a lot of angles at once here, but it still isn't very much code. Our former import() logic found its way into new(), with a few changes: we're using a hash reference instead of a hash, and we're blessing it as an object. This object is exceptional: instead of merely containing variables, it contains anonymous code references. These anonymous code references are lexically bound to their data, exactly like our former example. Perl doesn't know how to use this kind of an object, but thankfully we can teach it: the AUTOLOAD() method is used to look up methods on demand. This should be invoked for every method call except for new(), since no other methods are defined. When it is invoked, we get our hash reference passed in, and to get at our anonymous subroutine reference we tucked away in the hash reference, use this syntax:
$me->{$method}->(@_);This looks up the method, by name, in our hash reference, then calls it as a subroutine, passing the current argument list. Viola! A new sort of object that keeps a hash reference of code lexically bound to data rather than just plain old boring data.
use 5.9.34; print "Perl 6 should be just about ready by now!\n";To write a module that exports functions when use'd, the Exporter offers a convinient way:
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 feedFunctions named in @EXPORT always get exported to the program that uses us. They can use them (almost) just like normal built in Perl functions. Functions listed in @EXPORT_OK must be requested:
package main; use PrintPL qw(printpf); printpf("This page intentionally left blank.");You could do the same thing manually, of course. Define an import method in your module, like so:
sub import { *{caller().'::printpf'} = sub { print @_, chr(0x0c); }; }This doesn't have a lot to do with Object Oriented programming. It is a staple of Perl programming, so we need to know about it.
use CGI 2.4;This will die unless $CGI::VERSION >= 2.4. Perl checks the target module's $VERSION package global variable variable and verifies that it is equal to or greater than the number you specify. Perl understands "ordinals", comparing 2.4.1 against 2.4.2 does the right thing: 2.4.2 is larger.
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 queueXXX O'Reilly's Java Threads is a really good gentle introduction to threads. Something like that would be in order for Perl, in a condensed format.
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; }Call squak() in a parrot is a notification that it should squak, or a request to swauk, never a garantee that a squak will be emitted.
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 { ... }Since many programs have a proliferation of Singletons, it may be handy to place all of them in a global Static Object, which itself is a Singleton.
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; } package Appointment; my $day; sub set_day { die unless $_[0]->isa('Day'); $day = shift; return 1; }XXX examples of use, what you can and cannot do, etc.
# 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; }To do it this way, they would have to create a class for each and every topping, as well as each and every combination of toppings! With two toppings this isn't out of hand. With 8 toppings, you've got 256 possible combinations. With 12 toppings, you've 4096 combinations. Creating a permanent inheritance is the root of the problem, here. If we could do something similar, but on the fly, we wouldn't need to write out all of the possible combinations in advance. We could also make the inheritance chain deeper and deeper as we needed to.
# 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...The astute reader will notice that this isn't much more than a linked list. Since inheritance is now dynamic, we've gotten rid of needing to explicit create each combination of toppings. We use inheritance and a recursive query_price() method that calls its parent's version of the method. When we add a topping, we tell it to inherit it from the last topping (possibly the base taco). When someone calls query_price() on the taco, we pass off the request to our first topping. That topping passes it on down the line, adding them up as it goes.
# 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); }There! We finally have something that passes as workable! This solution is good for something where we want to change arbitrary features of the object without the containing object (in this case, taco) knowing before hand. We don't make use this strength in this example. Since the query_price() method of the taco object just passes the request right along, we can do any math we want. We would be using this strength if we had a two-for-taco-toppings-Tuesday, where all toppings were half price on Tuesdays. With a press of a button, a new object could be pushed onto the front of the list that defined a price method just returned half of whatever the price_method() in the next object returns. The important thing to note is that we can stack logic by inserting one object in front of another when "has-a" relationships.
# a bridge: package SpreadSheet; # create the objects we need my $model = new SpreadSheet::CellLogic; my $controller = new SpreadSheet::CellDisplay; # tell them about each other $model->set_controller($controller); $coontroller->set_model($model);Don't even think about creating all of your objects in one place and setting up the entire hierarchy this way. See God Object in Anti-Patterns, Chapter XXX. It is valid to set up relationships between two objects like the above example shows. This should be done as late as possible, or when reasonable. If you want to encapsulate the cell display and logic inside of a spreadsheet, and put the spreadsheet inside an office suite, the ./officesuite.pl shouldn't create SpreadSheet::CellLogic and SpreadSheet::CellDisplay objects. Rather, SpreadSheet.pm should. Having that logic in the main program doesn't make any sense.
# a model-view-controller arrangement: package SpreadSheet; my $model = new SpreadSheet::CellLogic; my $view = new SpreadSheet::CellDisplay; my $controller = new SpreadSheet::CellController model=>$model, view=>$view;See also: Two way relationship, Refactoring Chapter XXX.
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(@_); }This simple idea has many uses:
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;To be OO "pure" (polymorphic) each kind of car should @ISA = (Car), so that they pass the $ob->isa('Car') test. This lets programs know that it is a car (reguardless of kind) and can thus be used interchangably.
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."; }If you do something like that, you will prolly want Car::Ford to inherit Car::GenericAmericanCar with a line at the top reading @ISA = qw(Car::GenericAmericanCar Car) so that the methods continue to be available after you re-bless it (and so that they are marked as being a Car). Going hog wild, we could make our code do this for us:
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; }There! No matter what kind of car the user requests, we create it - even if it didn't exist before we created it. We set the @ISA array to inherit from Car and Car::GenericAmericanCar. Even if the package was completely empty, it now contains the minimal amount of definition to make it useful: an inheritance. You probably don't want to do exactly this, unless you really want the same product rebadged with a bizarre variety of different names.
$number->add(10);You'll write instead:
$number = $number->add(10);Other modules using the old $number can continue doing so in confidence, while every time you change yours, you get a brand new one all your own. If your class is a blessed scalar, your add() method might look like:
sub add { my $me = shift; my $newval = $$me + shift; return bless \$newval, ref $me; }I've got a FuzzyLogic package I've written. Each object encapsulates a fuzzy set. Different subtypes combine their fuzzy set with other fuzzy sets different way when combined with overloaded operators. Since a fuzzy rule system uses certain fuzzy sets over and over, and since a rule system can be very large, I want to be able to pass out commonly used sets. However, performing operators on a set obviously produces a different set. Making the output set a new instance of itself rather than mucking with its own internal state was an obvious win. XXX bleah.
- here's brian d foy's comments on the patternsinperl.com visitor:
$visitor->visit( $class, $self )
foreach my $class ( qw(NAME SYNOPSIS CODE) ) { no strict 'refs'; @{ "POD::${class}::ISA" } = "POD::POD"; }
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}
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, @_);}
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;}
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; }Other packages can come along and add Iterator to their @ISA list. They will need to redefine these methods. Now we have a uniform way of doing something. If a method in an object is expecting an Iterator as its argument, it has a way of checking to see if its argument really is an Iterator. It can be an Iterator and anything, else, too. This supports Type Safety.
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; } }This [untested XXX] code allows a network of objects having the getIterator method to cooperatively and transparently work together. Each object in the network may have a different way of iterating. This example represents a tree datastructure. The tree may contain other tree nodes, array objects, queues, and so forth. As long the network consists of objects with a getIterator() method that returns an object that implements the Iterator iterface, we can crawl through the whole thing. Thats composition you can take to the bank and smoke!
# 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;Returning all of the data from a get_ method fosters slurping everything into memory. This fosters programers which are limited by memory in how large of datasets they can work on. You can chuckle and say that virtual memory will take up the slack, but if I can tell you that there are a heck of a lot of multi terrabyte data warehouses kicking around the world. Dealing with data in place, where your storage is essentially at capacity at all times, or having multiple clients process a very large dataset in parallel demands efficiency. There are still a few applications for good programmers and a few applications for good programmers to write.
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; } }Compare this to Java's IO Filters, which will superimpose read of datastructures, international characters, and so forth on top of IO strems: you'll find it to be remarkably similar. It lets users mix and match IO processing facilities.
package Momento; sub new { my $type = shift; my %opts = @_; die PACKAGE__ . " requires an object passed on its constructor: new Momento object=>\$obj" unless $opts{'object'}; my $this = { object=>$opts{'object'}, checkPoint=>undef }; bless $this, $type; } sub momentoCheckPoint { my $this = shift; $this->{'checkPoint'} = $this->deepCopy($this->{'object'}); } sub momentoRestore { 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; }While this is a generic Momento package, it cannot possibly know how to correctly deal with objects contained inside the object given it. A version of this (possibly subclassed) tailored to a specific package would handle this situation correctly. Here, we replicate objects mercilessly. This code also violates the encapsulation rules of OO. Use it as a starting point for something that doesn't.
See Also: Transaction Object See also: Clone on CPAN See Also: http://hatena.dyndns.org/~jkondo/DesignPattern/Memento/
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; } }This example returns an object if we have one for that type and value. If not, it creates one, and caches it. An observant reader will note that if we cache objects, give it to two people, and one person changes it, the other will be affected. There are two solutions: pass out read-only objects, or preferably, use Immutable Objects.
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; }This is kind of like Perl's Autovivication of variables and hash and array entries: things spring into existance at the moment a user asks for them.
http://patternsinperl.com/designpatterns/factorymethod/ http://hatena.dyndns.org/~jkondo/DesignPattern/FactoryMethod/ http://magnonel.guild.net/~schwern/talks/Design_Patterns/full_slides/slide015.html - example by MichaelSchwern
# note: no package statement use DBI; use CGI; use Mail::Sendmail;Back in the main program:
use config; my $userid = CGI::param('userid'); # etc...my variables are file-global when declared outside of any code blocks, which means that we can't easily declare lexical variables in config.pm and have them show up in the main program. We can co-opt the import() method of config.pm to create local variables in the main program, though:
# 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}; } }This will atleast squelsh any warnings Perl would otherwise emit and let us return to importing configuration dependent values from a configuration file.
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);The string "color" appears ten times. Ten! In Perl, no less. If I wrote out the constructors for the other arguments, this would be repeated for each variable. Shame. If we trust the user to pass in the right things to the constructor, we can get rid of two. Still, even typing each thing eight times is begging for a typo to come rain on your parade.
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";First, the { query_name => sub { } }->{$arg}->(@_) is a sort of switch/case statement. It creates an anonymous hash of names to functions, then looks up one of the functions by name, using the first argument passed in. Once we have that code reference, we execute it and pass it our unused arguments. Then we've added a default case to it, so we don't try to execute undef as code. This could have been coded using if/elsif/else just as easily.
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;Given a code reference, MessageMethod blesses it into its own package. There are no methods aside from new() and AUTOLOAD(). AUTOLOAD handles undefined methods for Perl, and since there are no methods, it handles all of them. (There is an exception to that, where new() has to pass off requests). AUTOLOAD() merely takes the name of the function it is standing in for and sends that as the first argument to a call to the code reference, along with the rest of the arguments. We're translating $ob->foo('bar') into $ob->('foo', 'bar'). This does nothing but let us decorate our code reference with a nice OO style syntax.
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);XXX - constraint system example - IK system using X11::Protocol?
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'; }
my $context = { increment => sub { my $context = shift; $context->{sum}++; return ''; }, currentvalue => sub { my $context = shift; return $context->{sum}; } }; sub expand_macros { my $context = shift; my $text = shift; my $macro = qr{([A-Z][A-Z0-9]{2,})}; $text =~ s/$macro/$context->{lc($1)}->($context)/ge; return $text; } expand_macros($context, "INCREMENT INCREMENT The current value is: CURRENTVALUE");This is fairly strightfoward: We can pass $context and some text containing the macros "INCREMENT" and "CURRENTVALUE" to expand_macros(), and the macros will increment the current value of $context->{sum} and return the value. This is a simple template parser that finds escapes in text and replaces them with the result of a peice of code passed in through a hash. However, since we're maintaing our context in a hash reference, we can do this recursively:
$context->{doubleincrement} = sub { my $context = shift; expand_macros($context, "INCREMENT INCREMENT CURRENTVALUE"); } expand_macros($context, "The current value is: DOUBLEINCREMENT");Maintaining state in a hashref rather than the symbol table only requires us to be vigilent in passing the hash ref around. We have access to the updated state in the hashref after evaluation has finished. We can take this same context and pass it off again. In our example, we could template something else, reusing our same state and collection of macro definitions.
# defining our mini language: # format of our macro escapes. returns the name of the macro. $macro = qr{([A-Z][A-Z0-9]{2,})}; sub fetchvalue() { my $symbol = lc(shift()); my $ob = shift; return $ob->{$symbol} if defined $ob->{$symbol}; return $symbol->($ob) if defined &{$symbol}; # if its available as a function, recurse into it return $$symbol; # assume its a scalar } sub createtemplate { my $name = shift; my $text = shift; *{$name} = sub { my $ob = shift; my $text = $text; # private copy, so we don't ruin the original $text =~ s{$macro}{ fetchvalue($1, $ob); }oges; return $text; }; } sub createquery { my $name = shift; # name of function to create my $sql = shift; # query this function will execute my $inner = shift; # name of function to call with each result, optional my @queryargs; $sql =~ s{('?)$macro\1}{push @queryargs, lc($2);'?'}oges; my $sth = $dbh->prepare($sql, @queryargs); *{$name} = sub { my $ob = shift; my $row; my $ret; $sth->execute(map { fetchvalue($1, $ob); } @args); my @names = @{$sth->{'NAME'}}; while($row = $sth->fetchrow_arrayref()) { # store each item by its column name for(my $i=0;$i < @names; $i++) { $ob->{$names[$i]} = $row->[$i]; } # if we're supposed to send each record to someone, do so. $ret .= $inner->($ob) if($inner); } $sth->finish(); return $ret; }; } # writing code in our mini language: createquery('readnames', qq{ select Name as name from Users where Name is not null }); createquery('readnumberbyageinstate', qq{ select count(*) as number, Age as agearoup from Users where State = STATE group by Age }, 'drawbargraph'); createtemplate('drawbargraph', qq{ <div align="left"><img src="reddot.png" height="20" width="NUMBER"></div> }); print readnames(); print readnumberbyageinstate({state=>'MD'});Lets take a look at what we've factored out in this example:
print createquery($readnumberbystatesql, {drawpiechart => createpiechart() }, 'drawpiechart');It is traditional in languages like Lisp and Scheme to skip naming things unless actually necessary.
eval { run_query(); }; if($@) { $dbh = DBI->connect("DBI:Pg:dbname=blog;host=localhost;port=5432", 'scott', 'foo'); run_query(); }See also: TypeSafety, TypedVariables, AccessorPattern, BigBallOfMud, ObjectOriented, DaemonPattern, ErrorReporting
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; }In most cases, it is never an error to be called back by the object that you just called. Some times re-entry isn't an error at all, and you can silently refuse it. ConstraintSystem uses this idea to propogate values across a network where some nodes are willing to budge and others aren't. Usually this manifests as a list of notification recipients that receive a notification, and one needs to send yet another notice to all of them except the sender of the original message, but doesn't happen to know which originated. This situation crops up with the Gnutella protocol, where nodes replay messages to every peer except the originating one, but the mesh of connections can cause the message to be accidentally routed to the originator anyway. Simpily tracking which messages you originated yours and ignoring requests to forward them again pervents a condition where a host transmits the same message out onto the net over and over.
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(@_); } }See Also: ConstraintSystem, EventListeners
# 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> };Forgetting to do this in even one link or form causes the site to forget any and all information about a user as soon as they click it. Additionally, since the sessionid is part of the HTML, it lives on in the browser cache. For this reason, session id tokens should be expired after a period of time by the server. This means having the server simply record the date that it issued a session id number and refusing to honor it after a period of time has elapsed, forcing the user to re-login.
$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;Instead of declaring a package and using Exporter, we're merely continuing to operate in the namespace of the module that invoked us. The methods we define - validated(), validateuser(), offer_login() and is_guest() show up in their package, ready for use. As a side effect, we're using CGI.pm and DBI.pm on behalf of our caller, letting us list all of the modules we want in only one place, rather than in every .cgi script. This module could be used with:
print qq{Content-type: text/html\n\n}; use validateuser; validated() or offer_login(); # rest of the script here, for users onlyoffer_login() never returns once we call it. It handles exiting the script for us.
#!/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}; }These examples make heavy use of my TransientBaby.pm module. That module creates recursive routines that communicate using global variables - ick. I need to change that, and then this example. Then I'll put that code up. XXX.
require 'config.pl';We've all seen it a million times. It's as old as Perl itself. You make a little Perl program that does nothing but assign values to variables. Users can "easily" edit the file to change the values without having to wade through your source code. It is extremely easy to read configuration files of this format, and you can store complex datastructures in there, along with comments.
# 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;Data::Dumper.pm comes with Perl, and can even store entire objects. In fact, it can store networks of object.
# intercept death long enough to scream bloody murder $version = '$Id: ErrorReporting,v 1.1 2002/10/24 12:59:57 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; };See Also: PadWalker
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; }The main application could prompt the user for a module to load, or load all of the modules in a plug-ins directory, then make them available as menu items in an "extentions" menu. When one of the extentions are select from the menu, a reference to the application - or a FacadePattern providing an interface to it - is passed to the run_macro() method of an instance of that package.
place_cursor(0, 0) set_color(white) draw_circle(radius=1) set_color(red) draw_circle(radius=2)A few options exist: we can compile this directly to Perl bytecode using B::Generate (suitable for integrating legacy languages without performance loss), or we can munge this into Perl and eval it. Lets turn it into Perl.
# 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 }We're using the \G regex metacharacter that matches where the last global regex on that string left off. That lets us take off several small bites from the string rather than having to do it all in one big bite. The flags on the end of the regex are:
$sig{PIPE} = 'IGNORE';See perldoc perlipc for more on Inter Process Communications. Users may also try to communicate with you by sending you signals intentionally. In perticular:
$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()); }No matter which way we make the set_money() function work, we're doomed. If it enforces a ceiling, then we have to query again to see if the ceiling was enforced. If it doesn't enforce a ceiling, then we have to check each and every time we access the value and enforce it ourselves. The result is one or two of these sequences of logic will get strewn around the program. The problem is that the client needs something slightly more complex than the server is prepared to provide. We could, and perhaps should, make the object we're calling, $player, return an array, including success or failure, how much money actually changed hands, how much more they could carry. This would go with the approach of providing way more information than could ever be needed. This leads to bloated code and logic that we aren't sure whether or not is actually being used, leading to untested code going into production and becoming a time-bomb for the future, should anyone actually start using it. Less dramatically, we could modify the target object to return just one more piece of information when we realize we need it. This leads to a sort of feature envy, where the server is going out of its way to provide things in terms of a certain clients expectations, causing an API that is geared towards a particular client and incomprehensible to all else. Also, there is temptation to write something like:
package Util;Beware of Utility, Helper, Misc, etc packages. They collect orphan code. The pressure to move things out of them is very low, as they all seem to fit by virtue of not fitting anywhere else. They grow indefinitely in size because the class of things that don't seem to belong anywhere is very large. The effect snowballs as the growth of other objects is stymied while the "Utility" package booms.
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()); } }Associating methods with our client object that reasonably belong in the server object ($player, in our case), isn't always the worst solution. In fact, if you put them there and leave them until it is clear that they are needed elsewhere, you'll find that either they are globally applicable, they only apply to this client, they apply to a special case of the client, or they apply to a special case of the server.
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"; }Despite the systematic banishment of these languages *, people still find ways to write code that has this problem on a large scale:
while(1) { if(@queue) { dosomething(); } }This example applies to threaded code, but non threaded code can fall prey as well:
while(! -f $file) { } # do something with $file hereBoth of these examples attempt to use 100% CPU resources. In the best case, you make everything sluggish. Worst case, you never release the CPU so the thing you're waiting for happens. On different systems, the results are different, too. Some threads preempt. Others never take the CPU back until you call yield() or an IO function! Writing code like this is the quickest way to make things work on some systems but not others.
$fooLogic->doSomething($stuff, $morestuff);
$fooLogic->doAnotherThing($stuff->querySomeThing(), $morestuff->queryOtherThing());Hack through this overgrown jungle long enough, and paths will emerge - or you'll discover that there is no where to go and curse yourself for abandoning civilization.
package DoEverythingThenSome; my $foo; my $bar; sub nastysub1 { $foo += 300; ... } sub nastysub2 { ... } ... sub nastysub300 { ... }Okay, nastysub1 through 100 are getting the boot:
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 { ... }Functions that use package-global variables (eg, my variables declared at the outer most level, the file scope) that should be migrated to objects present one huge problem: tracking down each and every use of the variable and changing it to a hash dereference to work with Perl's object implementation. ImplicitThis lets you cheat your way out of this chore by making it look all the same to you. By creating a package with a constructor and instance data, we're opening up the possibility of one-to-many relationships against our object: several independent instances of FooBarUlator can exist at once, each with different values for $foo and $bar and any other fields it defines.
my $appointment = $sunday->query_scheduler()->schedule_appointment($sunday, '9:00am'); if(!$appointment) { warn "failed to book appointment. sorry, boss."; }
x*5 + 10 = x*2 + 32Refactored:
15 = 5 * 3When programming, the simplest thing you can break things down into is a matter of opinion. Or rather, it is a matter of opinion what programs are composed of. Instructions? Expressions? Functions? Objects? Modules? Some languages represent everything with an object (Smalltalk, for instance). This lets us abide by an executive ruling that objects are the fundamental building block, which pleasantly closes the question. Perl being pragmatic, programs are built in strata. Packages are built on objects are built on functions are built on expressions. Just like a polynomial expression, these combine in different ways to create something more complex.
print 10+32;You move on to write reusable pieces of code needed to build things just more complex than the simplest structures.
sub indent { print ' ' x $_[0], $_[1], "\n"; }Functions let you repeat a bit of logic without having to repeat it in the program. This lets you repeat it an unknown number of times, and makes it easy to run it or not run it under different variable conditions.
100 OLDA=A 110 A=50 120 GOSUB 200 130 PRINT "The result is: ";PRINT $A 140 A=OLDA ... 200 A=B*100 210 RETURNWhat seems like the simple solution, stashing data somewhere and giving it a name, turns out to be a nightmare. Subroutines couldn't safely be written that that would perform a given operation on any give piece of data. Later versions of BASIC of course changed this, but not until a few new generations of langauges came and whooped it one.
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; }Later on, we decide to add the ability to handle all of the subdirectories of the given directory, a change of heart brought on by an interaction with an individual who expects you to code things he can't even remember, much less communicate.
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/');If we hadn't changed the call to handle_delete() to pass arguments, and modified the subroutine handle_delete to use local variables instead of global variables, $processedflag could hold left over data, altered by a call made from process_directory() to process_directory() that returned. It used to be that each instance of a running programmer had one main loop that used these variables. Now, this is a function that could be called several times, and even have several copies running at the same time, as it calls itself. Data that was specific to the program is now specific to an individual function call. Our variable definitions reflect this change.
# Before: use vars qw/$foo/; sub bar { do_something_with($foo); } sub baz { print $foo, "\n"; } # After: do { my $foo; *bar = sub { do_something_with($foo); }; *baz = sub { print $foo, "\n"; }; };The syntax changes on the function definitions. Thats annoying. This syntax is needed so that the functions are generated then and there, which ties them to their surrounding context - including the lexical variables - but in a fast, efficient way. Only bar() and baz() can see $foo now. You could say that they are the only things in $foo's scope. The reduced scope makes the grouping visible, which makes the association obvious.
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 ); ... } ... }Credits: Michael G. Schwern
my $a = new MapDaemon($mapob); my $i = shift(); $a->send_region($i, 10, 15, $x2, $y2);...would become...
my $a = new MapDaemon($mapob); my $i = shift(); my $send_region = sub { $a->send_region($i, 10, 15, shift(), shift()); }; $send_region->($x2, $y2);In this example, $i and $a are lexically bound to the variables of the same name created just before it. If you change the value of these variables, it affects the code reference you've created in $send_region. If you pass $send_region off, or if you return it, $i and $a will continue to hold their values. 10 and 15 will be hardcoded in and cannot be changed. The two argument positions that contain the keyword shift() will take their arguments from what is passed to the reference that is created. This illustrates three different ways of getting values into the code reference. Each has its purpose and its place.
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 } }The advantage of the approach that uses $send_region->() is that we could set values for $x1 and $x2, and pass $send_region out to another routine that could supply more arguments, without actually having to explicitly pass $x1 and $x2 along with $send_region.
#!/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; }Lets fancy for a moment that we have a whole bunch of code that looks like this. We don't want to have to keep looking up which fields represent what, but we don't have time right now to change all of the code for the privilege of using symbolic names. In fact, if we had to change the existing code in order to get symbol names for the fields, we wouldn't bother. It would be more work than continuing on this path. If we did convert it, our first intuition would be to turn the arrays into hashes. Here is another approach:
# 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; }With just a few short lines of code, we've written an object oriented wrapper for our data structure that doesn't get in the way of using our data structure normally. The old functions continue to work, and we can write new functions in the new style, or the old style, or a mixture of styles. Of course, when we have time, we may want to go clean up the old code. Perhaps we've been meaning to rewrite it all anyway. Who has ever heard of object oriented programming where introducing a new object type doesn't require changes to all of your data reference?
$treasure->bot() = $bot;...which looks highly unnatural. We were assigning to a function before, but it didn't look like it because the function call didn't have parenthesis on the end. How can you possibly assign to a function? :lvalue functions never return a string constant or the result of an arithmetic expression. They do give as their result a variable, or an expression that references a primitive variable. It is this variable that is assigned to. The lvalue function can pick which variable is assigned to, or even let the user assign to the result of another function if that function is also lvalue. substr(), for instance, is lvalue. That means both of these are legal:
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";Note that we don't use return. Return makes a copy, and that would damage out intentions. In other words, return() isn't lvalue. What is assigned to is the last expression in the block.
$treasure->{'wegiht'} = 30; # this would go unnoticed by the compiler $treasure->wegiht = 30; # this would be caught the first time it ranCatching the error right away helps us quickly track down the problem. Using a hash index, we might be confounded why the weight wasn't updating correctly, and search all over the program, not knowing which part of the code that accesses it to suspect. Some typos are hard to notice, especially after you've been staring at code all day. I've spent hours trying to find a logic error only to discover a subtle typo. Its annoying. Another advantage of using the OO accessor approach is that we can do value checking, to make sure the new value itself isn't bogus or empty. We can also trigger side effects, and update other global state of the object, or notify observer objects of the state change, or countless other behaviors.
if($treasure->bot) { $x = $treasure->bot->x; $y = $treasure->bot->y; } else { $x = $treasure->x; $y = $treasure->y; }This is error prone, and tedious. It doesn't fit at all with our laziness. If we change the definition of the x() and y() methods in Treasure.pm, we can write this OnceAndOnlyOnce:
sub x :lvalue { $_[0]->bot ? $_[0]->bot->x : $_[0]->[0]; } sub y :lvalue { $_[1]->bot ? $_[0]->bot->y : $_[0]->[1]; }In the future, asking for $treasure->x or $treasure->y gives the correct, expected value. Since :lvalue methods behave just like variables, we can do things like this:
$treasure->y-- if $dir eq 'north'; $treasure->y++ if $dir eq 'south'; $treasure->x++ if $dir eq 'east'; $treasure->x-- if $dir eq 'west';Even though x() and y() are methods, the ++, --, and all other operators work on them as if they were a variable. Perl actually performs those operations on the last variable mentioned in the expression, before the method returns. An :lvalue function can itself be the last thing mentioned in an :lvalue function: these rules are recursive. See AccessorsPattern for more examples of this technique.
($angle, $distance) = Converter::cartesian_to_polar($treasure->x, $treasure->y);... if instead we could write:
($angle, $distance) = $treasure->to_polar();The arguments are built in to the function!
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]; }query_x() is almost exactly like our old x(), except it isn't an :lvalue function. To change our X location, someone needs to first check bot(), and if there isn't a value there, then set it using set_x(). This is our procedure and we're enforcing it. A rogue programmer could always meddle around inside of our datastructure and ignore the OO interface, but we can only assume he knows what he is doing if he does that. There is a technique for hiding your data using lexically scoped variables that prevents this trick from working: see LexicalsMakeSense for some examples. Even that isn't secure: using PadWalker module, people can investigate and alter lexicals that would otherwise be hidden from them. If you truly want to enforce a strict policy for using your code from untrusted code, use the Safe module. This locks them into a sandbox and lets you define what they can do there.
OnceAndOnlyOnce WhereItBelongs PublicProtection PrivateProtection [from other classes and subclasses] ProtectedProtection [from other classes] FactorOut / ReFactor DeComposition AboutInheritance LooseTyping LooseCoupling Interface Override Overload TypeSafety LambdaClosure CallBack [object, anonymous sub reference, ...] Memoization Currying DesignContract ParrallelInheritanceHeirachies LateBinding (linking) TailCall (turns into goto) DelegationConcept LateBinding GoalDirectedEvaluation AttributeInheritance, ImplementationInheritance, InterfaceInheritance MiddleWare StovepipeSystems Delegate WeaklyTyped DynamicLanguage PolicyVsImplementation ComputedReferencesquotes:
aesop cyberiad
"...a brief outline or explanation of the order to be pursued...". The strong analogy between the sequences of instructions given to computers and the planned ordering of events in a musical or theatrical performance lead early British coders to coin the phrase.
# 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";The Haskell can reportedly be read as: define the result of qsort'ing the empty set as the empty set itself. qsort'ing one or more elements puts the first element in x and the rest in xs. qsort is defined recursively. Each pass, it divides up the work. When it has been broken down as far as it can be, all of the parts are reassembled, in order. The basis for breaking it down at each stage is dividing xs into things less than x and things greater than or equal to x. Each of these subsets are themselves run through qsort, with x itself stuck in the middle.
!@_ ? () : ...This is a matter of explicit test placed before the recursive calls. I said it was similar, not identical. The Haskell version shuns anything explicitly sequential. We don't built any local definitions for elts_lt_x or elts_greq_x, though we could, using anonymous subroutines. Instead, we just use a couple of grep calls inline to filter our argument list, first for everything less than the first argument, then everything greater than or equal to the first argument. The first argument, $_[0], is sandwiched in the middle. @_[1..$#_] is an array slice. It returns a new array created from @_ with specified elements. Here, we're listing elements 1 through the number of elements in the array. $#_ contains the number of elements in @_, and the .. operator returns all of the integers between 1 and that. This just lets us skip the first element, since we're explicitly using it as a middle value and sandwiching it in the middle.
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);In this example, we're using data to pick a code pointer. $save_filter->() executes whatevercode $save_filter refers to. Calling a polymorphic object method and using Perl's eval on a string also have the same effect, and the code that gets executed may not find all of the data it wants in a suitable state, and we may not have realized the possibility of the sequence of events that could lead to the situation.
$dispatch_table->{$request}->();...and...
GOTO SUBROUTINE*1000In both cases, two things are clear. How we arrive at the actual code we're shooting for depends on only one variable, not every variable involved in the computation, and it isn't clear which variables will be used, and what their acceptable ranges are, once we arrive. Our data dictates the direction of the program, but our data and our program keep each other at quite a distance.
5 relational principles ... XXX full-life cycle development ... XXX OSI layers ... XXX CVS FORK & MERGEDivirging copies happen. Refactoring, taken to an extreme, says to refactor the shared module into existance. Is what is good for one program good for another? We don't know, not before hand. A top-down approach fails here.
BACKING OUT CHANGES AND THE LOGXXX
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 queueB
B::Xref - Generates cross reference reports for Perl programs perl ::MO=Xref[,OPTIONS] foo.plSYSTEM
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 filehandleBUSINESS
Barcode::Code128 Business::UPSWEB
CGI_Lite CGIDEBUGGING
Carp::Assert traceFunc Test::MockObject Test::ClassMATH
Math::LP::Solve Math::LinearCombination Math::SimpleVariable PDL::R::math Routines from the "R" statistical language. "R" is like "S". Statistics::RegressionNATURAL LANGUAGE
Text::Metaphone Text::English Porter's stemming algorithm Text::NLP Festival::ClientLANGUAGE & SYNTAX
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::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;GRAPHICS
perl::vgalib OpenGL SDL::sdlpl GDGraph3d ANSIColor Curses GD X11::ProtocolIO
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"; }NET
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::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 NNTPClient SNMP::Util Socket6 X11::Protocol Math::ematica POP3Client Geo::WeatherNOAA IPTablesDATABASE
DBD::JDBC DBIDATA
SOAP cmpO? SOAP/Perl language mapping SWF::File Archive::Any Archive::Tar Pod::DocBook Roman ArrayHashMonster DateManip Mail::MboxParser Tie::CArrayCLASS/OO
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::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 ProtectPERSISTANCE
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 OMKELLOGGJUST PLAIN FUNNY
Bone::Easy Sex$Id: SelectCPANModules,v 1.7 2002/11/08 12:08:34 phaedrus Exp $
$color = $obj->getColor();Fetching data from a reference to a subroutine:
$color = $colorSubroutine->();Fetching data from a reference to a hash:
$color = $stuff->{'color'};Fetching data from an array reference:
$color = $colors->[37];Fetching data from a sca lar reference:
$color = $$colorPointer;Fetching data from a reference to a filehandle:
$color = <$colorFile>;It's up to you to use a reference the correct way. It may help to use paper to make a graph of what contains what. If you find things empty that you know you stored data in, or perl is telling you you can't use one reference type as another, you've gotten confused at some point. Perl 5 references are second only to regular expressions in creating "line noise" code. It's possible to have an array reference which contains hash references which contain object references. The secret is to remember which contains what, and request them in the correct order:
$color = $anArray->[42]->{'thatOne'}->getColor();Often, calling a method in an object will return a new object. Sometimes you'll find yourself using, but not saving, intermediate objects:
$color = $outside->getSky()->getColor();"Programming Perl", O'Reilly Press, offers a complete rundown on using references, creating them, creating objects, and more. It is a thourogh tour of the how and why of Perl. That knowledge isn't critical to understand this book, but on the other hand, we don't replicate that information here, either.
package Man; sub new { my $type = shift; my $me = { }; bless $me, $type; } return 1;An object is an instance of a class. If you're a biology major, an object is a phenotype and a class is a genotype. A class is a prototype, and an object came off of an assembly line. For Perl purposes, "class", "package", and "type" are interchangeable. A package is the prototype for making objects. It gives the instructions on how to make a new object, and it defines how it will work once its made. While the package is the form a class takes, the variable that you bless is the core of the object. Two things happen: bless() mucks with the variable, recording the name of the package that it is now part of, so attempts to call methods in it in the future will be routed back to the package it was blessed in. Also, it contains all of the information specific to particular instance of the class. "Instance" is OO jargon that translates to "an object made from a certain package". $me is assigned to { }, which when used as a value creates a reference to a hash. Thus, $me becomes a hash reference. The basic datatype our object will store data in is going to be a hash, in this case. My variables are intimately tied to objects in Perl, since the package that implements the objects has to handle each and every object it creates, and not confuse their data with each other. My variables are not only private to particular method they are defined in, but they aren't even visible from outside that method. We'll encounter more useful magic of the "my" variable later. In OO lingo, the function in a package that sets up a new object, typically named new(), is called the "constructor".
use Man; $obj = Man->new();This fragment calls the new() method in the Man (if it isn't defined, inheritance kicks in and new() is searched for). Note that 'Man' isn't actually an object reference. Its just a bareword. Perl takes it as a class name when used like this. Another way to say the same thing, which resembles other OO languages more closely, is:
use Man; $obj = new Man;In either case, the string literal 'Man' is passed to the new() method. This is important, since the new() method doesn't always know what kind of object its making. This happens when one package inherits another. If the new() made assumptions about what kind of objects it was making, it couldn't be trusted to help make objects for a subtype of itself. The creating of the object is done by the perl built-in bless. The "use" statement tells Perl to seek out the module and load it in. In order to call new() in it, we're going to need to have it already loaded.
package InvestmentBanker; @ISA = ('Man'); sub getTimeOfDay { my $me = shift; unless(caller->isa(__PACKAGE__)) { die "Not for you, buddy!"; } return scalar localtime(time()); } return 1;When we create an InvestmentBanker, The "$me" that we get was actually created in Man. Since InvestmentBanker doesn't define a new() method, Perl examines the @ISA array to decide what else we are. Our more primitive being may know how to cope with this situation. In this case, new() is called in Man with the argument 'InvestmentBanker'. It happily returns one. When parents give birth to investment bankers, they usually don't know right away. They do know that they are giving birth to a person. PACKAGE__ can always be used to retrieve the name of the current package, which is "main" by default, or whatever you've set it to using the "package" statement. You could use a string here that is set to the same thing that you set the package to, but this lets you set it one place and never have to spell it correctly again. The caller() method examines the caller stack. The caller stack keeps track of where we are in the program, especially where we need to return to as each function or method finishes. In this case, we're concerned with the object that called our method. In scalar context, caller() returns a package name. We're using that package name as if it were an object, just like we did above with Man->new(). This doesn't invoke a specific instance of the package, but rather goes directly to the package. isa() is a method defined in the UNIVERSAL package that searches through the inheritance tree for you, as defined by which classes list which other classes in their @ISA arrays. In this example, we want to know if the class that called us has an "is a" relationship (that is, either actually is, or inherits from) our class, InvestmentBanker.
use InvestmentBanker; my $banker = new InvestmentBanker; print $banker->getTimeOfDay();If you run this code from a separate file, you'll get a message similar to:
use InvestmentBanker; package WallStreetTrader; @ISA = ('InvestmentBanker'); my $banker = new InvestmentBanker; print $banker->getTimeOfDay();Then, we get a more friendly answer. Investment Bankers aren't bad people, they're just very, very busy. Sometimes you have to be careful with whom you speak, for reasons of security. This behavior, where we consider the package of the code calling us, is similar to the behavior of the Java "protected" keyword. This is part of the idea of "encapsulation", and becomes extremely useful when you want your own packages to have special access to other instances of themselves. This happens when you need to make your packages work closely together in ways aren't safe for other people to assume they can, such as in ways that you might change in the future, or ways that would by-pass the OO nature of your object if just anyone could use it. It should be noted that some languages check your program at compile time, before it runs, to make sure you aren't trying to access something protected in another class. Perl 5 doesn't.
package TradingFloor; sub new { my $type = shift; my $me = {}; bless $me, $type; } 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}; } package Stock; sub new { my $type = shift; my $me = {@_}; bless $me, type; } 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; }; }Put Stock in a file named Stock.pm and TradingFloor in a file named TradingFloor.pm. Then, in a separate file, run this code:
use WallStreetTrader; use TradingFloor; use Stock; $trader = new WallStreetTrader; $stock = new Stock(name=>'ILL', price=>5.45); $wallstreet = new TradingFloor; $wallstreet->play($trader, $stock, 10000);The play() method in TradingFloor.pm accepts a reference to an object made from itself, as its first argument. This is typical of methods. The package has the code, but the object has the data. We have to look inside of the object ($me) to get at the data of the object. Other OO languages implicitly take this first argument, often called "this". Perl 5 requires you to manually accept this argument. That isn't all, though. The method is looking for two more arguments: an InvestmentBanker object, and a Stock object. We ask the values we receive if they are of the type we expect (or if they inherit from those types). This is called "type safety" in OO lingo. In Perl, we process our arguments manually, and we enforce type safety manually. Thankfully, its rather painless. Should we receive something other than an InvestmentBanker or a Stock, we complain immediately and loudly. Some languages check this when the code is compiled, before the program is ever run. Perl 5 does so at runtime.
sub get_name { my $me = shift; return $me->{'name'}; }; sub set_name { my $me = shift; @_ or die "not enough arguments to set_name, stopped"; $me->{'name'} = shift; return 1; };Stock.pm is an example of data encapsulation, and acts as nothing more than a simple container for information. Future version of Stock.pm could guard data closely, or perform other operations on it. Because the accessors are code, instead of just variables, it gives us the precious chance to do some fudging: for instance, if the name of the Stock were removed, to be replaced with 'companyName' and 'tickerSymbol', we could redefine get_name() to return the tickerSymbol and companyName, combined into one string. set_name() could perhaps change companyName, but call warn() to warn the programmer that a legacy method was being called, and that she needs to use an updated accessor now.
use base 'Person';This uses a "pragma" module to do the same thing as assign to @ISA, but with a cleaner syntax.
::::, at its most basic level, tells Perl where to look for a module:
=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. BSee Also: DocBookBold - 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 S Non-breaking string - will not linewrap on spaces X Index entry.
# 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
$a = wussup;Bare words are unqouted things that appear in the text that aren't function names. They get treated literally for lack of anything else to do with them. That makes that expression the same as:
$a = "wussup";This is considered bad style in all but one case (hash table indices), but it also serves to prevent variables from not having to have funny symbols in front of them.
# CGI.pm does this to learn about local linefeed insanity: $OS = $Config::Config{'osname'};
my @files = grep { $_ !~ m/^\./ } sort readdir $fh;This might lead one to believe that parenthesis aren't used for function arguments and curley braces some how take their place. This might be partially true. Many functions expect a list of things, and many functions return lists of things. In this example, readdir() is returning a list to sort(); sort() is sorting that and sending it through grep(); grep has a strange little block after it. This is a block of code that will be run each item in the list as a test for inclusion. sort() and map() are two other functions that accept such an code block. The block is purely optional. Since all of our lists are implicitly created and implicitly passed around, we don't ever really need to group things using parenthesis. That doesn't mean we can't:
my @files = get_file_list($ENV{'HOME'}, '.', `pwd`);Having optional parenthesis does create a certain amount of confusion. People are often tempted to write expressions like:
print (32/8)+10; # this prints "4"The space after print() means nothing. It still attaches itself to the single argument, 32/8. What probably meant is:
print((32/8)+10); # this prints "14"The && operator also causes problems when parenthesis aren't used on lists of numbers. The && operating will work on the last thing in the list, rather than the return value of the function:
sprintf "The number is: %d\n", 0 && return; # this won't returnThe obvious thing to do is introduce parenthesis, but you don't have to - Perl provides the and and or operators, which have very low precidence:
sprintf "The number is: %d\n", 0 and return; # this will returnReadability can suffer, but not having to match up parenthesis all of the time saves a lot of bouncing around in the code. In case of doubt, use the parenthesis.
substr($foo, $i, 1);This well Perl that we want a string of 1 element start at $ith element of $foo. Since strings aren't arrays of characters, this returns a string of one character. Use ord() and chr() to convert between ASCII values and very small strings.
my $pi = \3.14159; # I'm not a math geekYou can also read in Perl code that defines variables using the require statement.
@array = (1, 2, 3, 'hi');However, arrays that aren't passed by reference get copied. That means:
function(9, 10, @array);...//function()// shouldn't expect to get a reference to @array. Instead, everything inside of array will be copied onto the end of function()'s argument list, making it equivilent to saying:
function(9, 10, 1, 2, 3, 'hi');Since so many of Perl's built in functions work on plain old flat lists, and it is easy to compose lists from many sources to feed to a function, this is officially considered a feature.
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 messageThe text of the error was "Use of uninitialized value in concatenation (.) or string at - line 9.".
if(undef == 0) { print "True\n"; } my $a = undef; if($a == 0) { print "True\n"; }Logically, undef == 0. Many built in functions return a number on success and undef on failure: 0 is a possible success return value. So is the null string, ''. Rather than testing for truth, you must test for definidness:
if(defined my $line = <>) { # deal with more frivelous user demands } # user has shut up now and hit Control-D or closed the connectiondefined() returns true if its argument is defined and false if its argument is in fact not.
do { my $a = [1, 2, 3]; my $b = [4, 5, 6]; $a->[4] = $b; $b->[4] = $a; # uh oh! } # $a and $b still live on, even though they are out of scopeYou might not notice if you accidently do a few of these babies in code that runs only briefly then exits, like a CGI script. This can leak memory (allocate memory never to be freed) and ultimately expend all of the available resources on a long-running application, like a daemon. See DaemonProcess.
int stuff[] = {1, 2, 3, 4}; /* an array in C, by reference */ int $stuff = [1, 2, 3, 4]; # an array in Perl, by reference my @stuff = (1, 2, 3, 4); # an array in Perl, by valueIf minipulated by reference, only information about where to find the array is passed around, and only one copy of the actual array exists that is shared by everyone who knows where to find it. By value, the entire array is duplicated every time it is passed anywhere, giving each function (internal or external) its own private copy to play with. One exception to that rule is the foreach() operator.
@ar = map { $_++} @ar; foreach my $i (@ar) { $i++ }For performance, Perl programmers sometimes tell Perl to pre-grow arrays, instead of letting Perl do it on demand:
@ar = 1000; # allocate 1000 slotsArrays can be multidimentional. C arrays allocated thus:
char message[10][255]; /* 10 messages of 255 characters each */...are entirely preallocated, and have no lookup table: since each message is of fixed size, C need only look for the first one at offset 0, the next one at offset 255, the next at offset 510, and so on. This is not how Perl arrays work. Arrays allocated like:
char *message[]; /* I don't know how many messages or how long it might be */...is a much a much closer faximile. A pointer holds the address that points to a row of characters in memory. In the same way, a Perl array can list references to other arrays. The -> operator dereferences reference types of various type. This example creates a reference (pointer) to an array, and starts populating it with references to other arrays:
my $arrayRef = []; $arrayRef->[0] = [1, 2, 3]; $arrayRef->[1] = [4, 5, 6]; $arrayRef->[2] = [7, 8, 9]; print $arrayRef->[1]->[1], "\n"; # prints 5, right in the middle, just like Hollywood SquaresBecause it is unambigious, Perl accepts as a short hand this syntax for indicing multidimentional arrays:
print $arrayRef->[1][1], "\n"; # like aboveNote that the first -> is still required to distinguish between the reference $arrayRef and the array @arrayRef. In some languages, arrays are objects. Perl is not one of them. In other languages, arrays are never objects. Perl is not one of them either. In Perl, arrays are sometimes objects. When they are objects, they do not a provide a standard, generic API for minipulating arrays, but rather provide an API cooked up off the cuff by the creator of the object. This means that the API is more likely to be useful but less likely to be consistent.
gt lt eq ne cmp # like >, <, ==, !=, <=>, but for strings: compares lexically or literally # this prints true - you probably want the "eq" operator: if("hello" == "world") { print "true\n"; } -> # dereference any reference type. the exact syntax depends on the reference: $a->[0] # dereference an array ref $a->{'hi'} # dereference a hash ref $a->blurgh() # dereference an object referenceIt is not uncommon to mix and match them in one statement, if you know the datatypes of everything:
$a->[0]->{'hi'}->blurgh();If you have trouble with this, rethink what returns what reference types. This assumes that you have a scalar, $a, that is an array reference. That array holds a list of references to hashes (hash references). Those hashes each contain references to objects. Actually, that is too broad of a statement - Perl is dynamically typed, but this paragraph assumes that you've been consistent with your datastructure.
if($foo == 1) { # do something } elsif($foo == 2) { # do something else } else { # complain and do nothing }
Copyright (C) 2000 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed.0. PREAMBLE
from that of the Document, and from those of previous versions (which should, if there were any, be listed in the History section of the Document). You may use the same title as a previous version if the original publisher of that version gives permission.B. List on the Title Page, as authors, one or more persons or entities
responsible for authorship of the modifications in the Modified Version, together with at least five of the principal authors of the Document (all of its principal authors, if it has less than five).C. State on the Title page the name of the publisher of the
Modified Version, as the publisher.D. Preserve all the copyright notices of the Document. E. Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.F. Include, immediately after the copyright notices, a license notice
giving the public permission to use the Modified Version under the terms of this License, in the form shown in the Addendum below.G. Preserve in that license notice the full lists of Invariant Sections
and required Cover Texts given in the Document's license notice.H. Include an unaltered copy of this License. I. Preserve the section entitled "History", and its title, and add to
it an item stating at least the title, year, new authors, and publisher of the Modified Version as given on the Title Page. If there is no section entitled "History" in the Document, create one stating the title, year, authors, and publisher of the Document as given on its Title Page, then add an item describing the Modified Version as stated in the previous sentence.J. Preserve the network location, if any, given in the Document for
public access to a Transparent copy of the Document, and likewise the network locations given in the Document for previous versions it was based on. These may be placed in the "History" section. You may omit a network location for a work that was published at least four years before the Document itself, or if the original publisher of the version it refers to gives permission.K. In any section entitled "Acknowledgements" or "Dedications",
preserve the section's title, and preserve in the section all the substance and tone of each of the contributor acknowledgements and/or dedications given therein.L. Preserve all the Invariant Sections of the Document,
unaltered in their text and in their titles. Section numbers or the equivalent are not considered part of the section titles.M. Delete any section entitled "Endorsements". Such a section
may not be included in the Modified Version.N. Do not retitle any existing section as "Endorsements"
or to conflict in title with any Invariant Section.If the Modified Version includes new front-matter sections or appendices that qualify as Secondary Sections and contain no material copied from the Document, you may at your option designate some or all of these sections as invariant. To do this, add their titles to the list of Invariant Sections in the Modified Version's license notice. These titles must be distinct from any other section titles.
Copyright (c) YEAR YOUR NAME. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with the Invariant Sections being LIST THEIR TITLES, with the Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. A copy of the license is included in the section entitled "GNU Free Documentation License".If you have no Invariant Sections, write "with no Invariant Sections" instead of saying which ones are invariant. If you have no Front-Cover Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being LIST"; likewise for Back-Cover Texts.