I am fairly new to Perl, and after writing just a few applications and utilities I became a bit frustrated. I made plenty of Dumb Mistakes when constructing and using the Hash variables that served as my blessed data structures. The following code was an attempt to advance my knowledge of Perl by writing a module to allow Perl to perform some basic type checking on my behalf.
I was surprised that I couldn't find an existing CPAN module to do this, and I'm not sure why. So any constructive criticism on the usefulness or coding of the following is requested.
Is it something I should consider placing on CPAN?
# Run: "pod2man filename.pm | nroff -man | more" to see the documentat +ion for this package file. # Don't forget to replace "filename.pm" with the name of _this_ file. ############## POD Documentation ############## =head1 NAME Tie::Record - Provide Pascal-like typed "Records" on Perl Hashes, for +clear code documentation and run-time error-checking of Hash usage. Error-checking compiles out for production code. =head1 VERSION This document describes version 0.2 of Tie::Record, released on 23 Dec 2002. =head1 SYNOPSIS use Tie::Record; my %rec1; my $rec2; $rec2 = {}; Record testrec => a_scalar => recScalar, a_scalar_ptr => recScalarPtr, a_hash_ptr => recHashPtr, an_array_ptr => recArrayPtr, an_object => "Foo::Bar", a_testrec2 => "testrec2", anon_list_scalars => recListScalar, anon_list_hash => recListHash, anon_list_array => recListArray, anon_list_testrec2 => recList."testrec2", anon_list_objects => recList."Foo::Bar", an_any => recAny, ; Associate %rec1 => "testrec"; Record testrec2 => field1 => recScalar, field2 => recScalar, ; Associate %$rec2 => "testrec2"; # In the rest of this module %rec1 and $rec2 are accessed as # standard Perl hashes $rec2->{field1} = "some data"; $rec2->{field2} = 123; $rec1{a_scalar} = "here's my data"; $rec1{an_object} = new Foo::Bar; $rec1{a_testrec2} = $rec2; To disable the run-time type checking that Tie::Record performs, chang +e the C<use Tie::Record> statement to: no Tie::Record; =head1 BACKGROUND =head2 Problem Addressed Tie::Record module provides the following capabilities: =over 4 =item 1) The ability to document in a single place within the module the comple +te structure of the object's hash as well as the structure of any sub +-hashes. =item 2) The ability for Perl to perform run-time checks to ensure that a hash +is assigned-to properly. This includes not only that proper hash keys are used, but also that t +he values assigned to a given hash field match those intended for tha +t particular field. =item 3) The ability to turn off the run-time checking at compile time, such th +at zero Tie::Record type checking is executed at run-time. This is essentially the equivalent of having coded your module without + the use of Tie::Record at all. =back For example, suppose that you are creating a Perl OO-style module that + provides the functionality of a Blackjack table. As with most modules, Blackjack::Table stores it's underlying data in +a bless'ed Hash. That Hash might be created in the BJ Table's "new" method similarly to + the following: my $data = { tableName => $xyz, # A Scalar for BJ Table's name dealer => { # A BJ Dealer hash for the tabl +e obj => new Blackjack::Dealer, # One BJ Dealer object for tabl +e cardsFaceUp => [], # [] of dealer's face-up cards cardsFaceDown => [] # [] of dealer's face-down card }, players => [], # [] for TBD Player Hashes cardShoe => new Cards::Shoe # Card Shoe object for the tabl +e }; ... bless $data, $class; What is not defined in the above code is what data structures will be +pointed to in the "players" field anonymous list or "cardsFaceUp" & " +cardsFaceDown" anonomous lists. Presumably this Blackjack::Table module has additional methods such as + "->acquire_player" and "->deal_hand" that fill in the above hash ent +ries as a game is played. Tie::Record provides a convenient way of defining the underlying data +structures once, at the top of the Blackjack::Table module. Further, as the module's methods operate on the underlying Blackjack:: +Table hash, Tie::Record will validate that the object's data structur +e is being assigned-to as intended (at least within the limits of the + Record data-type specifiers). It is not intended that this type-checking (necessarily) continue afte +r debug of your application; a C<no Tie::Record> will eliminate type +checking and any associated performance impact. =head2 Solution Provided The above Blackjack Table object could make use of Tie::Record by incl +uding the following code: use Tie::Record; # Define the structure of the Blackjack Table's bless'ed hash Record BJ_Table => tableName => recScalar, # Field tableName is to hold a Sca +lar dealer => "Dealer", # Will hold pointer to hash descri +bed # in Record structure "Dealer" players => recList."Player", # [] of "Player" hash structures cardShoe => "Cards::Shoe"; # Will hold one Cards::Shoe object # Define the structure for a Dealer hash. A pointer to a hash with t +his # structure will be used in the above BJ_Table "dealer" key entry Record Dealer => obj => "Blackjack::Dealer", # A Blackjack::Dealer obj +ect cardsFaceUp => recList."Cards::Card", # [] of Cards::Card objec +ts cardsFaceDown => recList."Cards::Card"; # [] of Cards::Card objec +ts # Define the structure for a Player hash. A list of these hashes wil +l # be stored in the above BJ_Table hash, under the "players" key. Record Player => obj => "Blackjack::Player", # A Blackjack::Player obj +ect cardsFaceUp => recList."Cards::Card", # [] of Cards::Card objec +ts bet => recScalar, # A Scalar kitty => recScalar, # A Scalar Using the above code Tie::Record will remember the defined structures +for a BJ_Table, a Dealer and a Player for our Blackjack::Table module +. The various methods in Blackjack::Table (and possibly the class itself +) will make use of C<my> (or C<our>) Hash variables that are each ass +ociated with one of the above records. For example: The ->new method for Blackjack::Table might replace the code shown ear +lier with the following: my $data = {}; # To-be bless'ed hash for BJ Table Associate %$data => "BJ_Table";# Associate underlying Hash (not th +e # ptr) with BJ_Table Record structu +re my %dealer = (); # Dealer Hash to be filled in and t +hen # saved in $data->{dealer} as a poi +nter Associate %dealer => "Dealer"; # Associate this Hash with Dealer R +ecord # Initialize the %dealer Hash. Note that this code looks like (an +d is) # the same standard Perl you would code without the Tie::Record mo +dule. # This fact is important, because it is what allows you to turn of +f # the Tie::Record module in production use of your code. $dealer{obj} = new Blackjack::Dealer; $dealer{cardsFaceUp} = []; $dealer{cardsFaceDown} = []; # Now, initialize the Blackjack Table's underlying Hash $data->{dealer} = \%dealer; $data->{players} = []; $data->{cardShoe} = new Cards::Shoe; bless $data, $class; # Standard Perl OO-module pt +r The ->acquire_player(...) method for our Table object might include co +de like the following: shift $table; # Passed in Blackjack::Table obj shift $player; # SUPPOSEDLY a pointer to a # Blackjack::Player object my %playerRec; # Local Hash for new player Associate %playerRec => "Player";# Tell Tie::Record it's a Player +Rec. # Fill in the new player structure $playerRec{obj} = $playerObj; # Under the covers Tie::Record en +sures # $playerObj IS a pointer to a # Blackjack::Player object $playerRec{cardsFaceUp} = []; # Tie::Record checks here too, # but an empty anonymous list is +OK $playerRec{bet} = 0; $playerRec{kitty} = 100; # Add the playerRec hash (that is, a ptr to it) to the list of pla +yers push @{$table->{"players"}}, (\%playerRec); # Tie::Record ensures that what i +s # placed under the "players" key +is an # anonymous list of pointers to P +layer # Hashes If ->acquire_player(...) tries any of the following, a run-time Carp e +rror will be generated by Tie::Record: # Tie::Record would notice that this isn't a Blackjack::Player obj +ect $playerRec{obj} = new Blackjack::Dealer; # Tie::Record would notice this isn't a pointer to an anonymous ar +ray $playerRec{cardsFaceUp} = (); # Tie::Record notices this isn't an ANONYMOUS LIST of Player Hashe +s $table->{"players"} = \%playerRec; # Tie::Record would notice this isn't a push of a Player hash POIN +TER push @{$table->{"players"}}, (%playerRec); The ->play_hand(...) method for our table might include code like the +following: shift $table # Passed in Blackjack::Table object push @{$table->{"dealer"}{"cardsFaceUp"}}, ($table->{"cardShoe"}->de +al); # Tie::Record will compain if, for any # reason, the CardShoe object doesn't # return a Cards::Card object If the developer had accidentally included a line like the following: $table->{"dealer"}{"cardsFaceUp"} = $table->{"cardShoe"}->deal # Tie::Record would complain that "cardsFaceUp" was being assigned + an # object (Cards::Card) and not the correct [] of Cards::Card objec +ts Similarly, if the developer had accidentally included a line like the +following: $table->{"dealer"}{"cardsfaceup"} = ... # Tie::Record would Carp that an undefined key was being used =head1 DESCRIPTION The Tie::Record module exports two procedures: B<Record()>: To define the structure of a Hash, called a Record. This procedure expects the name of the Record being defined followed b +y the field names to be used in the Hash and the associated data type + to be assigned to each field. The allowed data-type descriptions are listed below. B<Associate()>: To associate a Perl Hash with a Record template define +d earlier. This procedure expects a Perl Hash variable and the Record name to whi +ch it is to be associated. The expected Perl syntax to be used to call each is as follows: Record testrec => field1 => recScalar, field2 => recScalar, ; Associate %rec => "testrec2"; Where: C<testrec> is the name for the Record. C<field1> and C<field2> are the fields (keys) to be used in an associa +ted Hash. By using the C<< => >> syntax it is only necessary to use quotes in th +e C<Associate()> call, and then only around the record-name string (a +s shown above). The following are the supported data types for Record fields: =over 4 =item B<C<recScalar>> A Perl Scalar can be assigned. This means strings or numbers, not poi +nters to things. =item B<C<recAny>> Any value can be assigned, no checking is done against what is stored +in a field specified as this data type. =item B<C<recScalarPtr>> A pointer to a Scalar value. For example: C<\"a string"> or C<\$a> =item B<C<recHashPtr>> A pointer to a Hash. For example: C<\%abc> or C<< {a=>1} >> =item B<C<recArrayPtr>> A pointer to an Array (more commonly known as an anonymous list). For + example: C<\@abc> or C<[1, 2, 3]> =item B<C<"Foo::Bar">> An object of type "Foo::Bar". For example: C<< Foo::Bar->new >> or si +mply C<$foobar>, if a previous assignment said C<$foobar = new Foo::B +ar>. =item B<C<"record_abc">> A pointer to a Hash that was B<Associate>d with a Record named "record +_abc". This is basically a Hash within a Hash where the sub-Hash has a define +d Record structure (see the examples above.) For example: C<\%a>, assuming that previously you said C<< Associate % +a => "record_abc" >>. =item B<C<recListScalar>> An anonymous list of Scalars. For example: C<[1, "two", 1+2]>. Attempting to Push an item onto this list that is not a Scalar will be + detected. For example: C<push($rec{field}, 123)> is OK. C<push($rec{field}, \@abc)> is Not OK. =item B<C<recListHash>> An anonymous list of Hashes (Hash pointers, that is). For example C<[\%hash1, \%hash2]> Attempting to Push an item onto this list that is not a Hash pointer w +ill be detected. For example: C<push(@{$rec{field}}, \%hash1)> is OK. C<push(@{$rec{field}}, \123)> is Not OK. =item B<C<recListArray>> An anonymous list of Arrays (Array pointers, that is). For example: C<[\@array1, \@array2]> Attempting to Push an item onto this list that is not an Array will be + detected. For example: C<push(@{$rec{field}}, \@array1)> is OK. C<push(@{$rec{field}}, \123)> is Not OK. =item B<C<recList."Foo::Bar">> An anonymous list of Foo::Bar objects For example: C<[new Foo::Bar, new Foo::Bar]> Attempting to Push an item onto this list that is not a Foo::Bar objec +t will be detected. For example: C<< push(@{$rec{field}}, Foo::Bar->new) >> is OK. C<< push(@{$rec{field}}, Foo::Bear->new) >> is Not OK. =item B<C<recList."record_abc">> An anonymous list of "record_abc" records (pointers to "record_abc" Ha +shes, that is). For example: C<[\%hash1]>, assuming that previously you said C<< Assoc +iate %hash1 => "record_abc" >> Attempting to Push an item onto this list that is not a hash associate +d with "record_abc" will be detected. For example: Assuming %hash1 was B<Associate>d with "record_abc" and %hash2 was not +. C<push(@{$rec{field}}, \%hash1)> is OK. C<push(@{$rec{field}}, \%hash2)> is Not OK. =back =head2 Nullifying Tie::Record behavior The run-time checking that Tie::Record performs may not be something y +ou want to incur when your code is run in a production mode. Just commenting out the C<use Tie::Record> statement would not be suff +icient to remove Tie::Record module's behavior, because you'd then ge +t syntax errors for all the B<C<Record>> and B<C<Associate>> statemen +ts in your program/module. In your main program change the statement: use Tie::Record; To: no Tie::Record; Or, if you have no such C<use> statement in your main module, then jus +t add the C<no> statement. A C<no Tie::Record> in the main module nullifies the behavior of Tie:: +Record across your main program and all modules that it includes (or +modules they include, etc.) By changing the C<use Tie::Record> statement to be a B<C<no Tie::Recor +d>>, you cause the Tie::Record module to immediately return when its +Record and Associate subroutines are called. This prevents any of your Hash variables from being C<B<Tie>>d to this + module, and therefore they will operate with no impact from Tie::Rec +ord. =head1 AUTHOR Andy Schwartz <andy-source@schegg.org> =head1 BUGS =over =item * I'll get back to you on this... =back =head1 FUTURES =over =item * Possibly provide support for anonymous lists of other generic types, s +uch as recListGlob. =back =head1 COPYRIGHT Copyright (C) 2002, Andrew Schwartz This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, + USA. =head1 HISTORY =over =item '02 Dec 15 Development started. =item '02 Dec 23 First version completed. =back =cut ############## Start of package ############## package Tie::Record; use warnings; use strict; use Carp; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(Record Associate recScalar recAny recScalarPtr recHashPtr recArrayPtr recList recListScalar recListHash recListArray ); our $VERSION = 0.2; our $production_code = 0; # Set to true i +f user's code executes "no Tie::Record" # %records_table holds the complete list of Record names and their ass +ociated structure layouts # %tied_records_table holds a "reverse list" whose keys are the addres +ses of tied Hashes and whose values are # the Record name to which that hash is tied our (%records_table, %tied_records_table) = (); # Exported subroutines allowing the user to use the following terms as + barewords in their code sub recScalar { "recScalar" }; sub recScalarPtr { "recScalarPtr" }; sub recAny { "recAny" }; sub recHashPtr { "recHashPtr" }; sub recArrayPtr { "recArrayPtr" }; sub recList { "recList" }; sub recListScalar { "recListScalar" }; sub recListHash { "recListHash" }; sub recListArray { "recListArray" }; # Set module's global variable saying that Record() and Associate() ar +e not to perform any Tie functions, # effectively turning them into no-ops. (Intended for production code + that no longer needs run-time type checking.) # The "no" statement in the user's code causes this unimport module to + be called. sub unimport { our $production_code = 1; Tie::Record->export_to_level(1, @_); # Force @EXPORT + to be exported, since unlike "use", "no" doesn't }; # Process the Record statement by the user. This procedure name is ex +ported automatically. sub Record ($@) { return if $production_code; my ($field, $datatype, $recList_entity); # Automatically pre-pend caller's package name to the Record struc +ture's name my ($callers_package) = caller; my $record_name = $callers_package . "::" . shift; my %record_structure = @_; # Record struct +ure is specified in a basic Perl Hash format # Because we automatically pre-pend a package name to Record names +, we must also replace field references to # record structures with the package-name-added version. For exam +ple: # "MyRecord" becomes "CallingPackage::MyRecord" # and # recList."MyRecord" becomes reclist."CallingPackage::MyRecord". # Note that a Record name that already has a package name in it is + left untouched and will automatically reference # that named-packages Record structure. For example: # reclist."OtherPackage::TheirRecord" will be left alone and will +reference the "TheirRecord" Record in OtherPackage:: while (($field, $datatype) = each %record_structure) { # Validating the syntax of $field would be a nice thing to add + here. # Parse data type field. If it is a plain Record name or a re +cList of Record names, then # prepend the calling package's name to the Record name specif +ied. next if $datatype =~ /^recScalar$ | ^recAny$ | ^recScalarPtr$ | ^recHashPtr$ | ^recA +rrayPtr$ | ^recListScalar$ | ^recListArray$ | ^recL +istHash /x; # No pre-pendin +g action necessary, move on # If the data type is a recList... if ( ($recList_entity) = $datatype =~ /recList(.*)/ ) { $record_structure{$field} = "recList" . $callers_package . + "::" . $recList_entity unless $recList_entity =~ /::/; # Pre-pend call +er's package name unless a package name is already there next; }; # Data type must be a plain Record name or Object name $record_structure{$field} = $callers_package . "::" . $datatyp +e unless $datatype =~ /::/; # Pre-pend call +er's package name unless a package name is already there }; $records_table{$record_name} = \%record_structure; # Store Record +structure by Record name in master table return 1; }; # Associate a particular Hash variable with a particular Record struct +ure. Remember that assoication by Tie'ing # the Hash to this Tie::Record module. sub Associate (\%$) { return if $production_code; my $variable_to_tie_ptr = shift; my $record_to_associate = shift; # If Associate's passed Record name does not explicitly include a +package name, then pre-pend the caller's package name. # In other words, assume that references to Records are by default + Records in the current Package's scope $record_to_associate = (caller)[0] . "::" . $record_to_associate unless $record_to_associate =~ /::/; croak "Tie::Record: Attempt to Associate $variable_to_tie_ptr with + undefined Record \"$record_to_associate\"" if !defined($records_table{$record_to_associate}); $tied_records_table{$variable_to_tie_ptr} = $record_to_associate; # Save reverse +assoc. of variable to Record name # Key is "HASH( +xxxxxx)" tie %$variable_to_tie_ptr, "Tie::Record", $record_to_associate; # Cause TIEHASH +, below, to be called return 1; }; # Called through Associate subroutine. Ties specified Hash by creatin +g and tie'ing with an underlying array. # First element is anonyoums Hash that will hold user's keys and value +s. Second element is the name of the # Record to which this Hash is tied. sub TIEHASH { my $self = shift; my $record_name = shift; my @tie_data; $tie_data[0] = {}; $tie_data[1] = $record_name; return bless \@tie_data, $self; }; # Called when user accesses their hash to store a key/value pair. sub STORE { my $self = shift; my $field_name = shift; my $value = shift; # A couple of convenient subroutines to print out error messages when +user's Store request is illegal sub failmsg1 { carp "\nTie::Record.pm: Attempt to set Record field \"$_[0]\" to a + value that is not a" . ($_[1]=~/^[aeiou]/i ? 'n ' : ' ') . "$_[1]," +; }; sub failmsg2 { carp "\nTie::Record: Attempt to set Record field \"$_[0]\" to a li +st whose element #".$_[1] . " is not a pointer to a" . ($_[2]=~/^[aeiou]/i ? 'n ' : ' ') +. "$_[2],"; }; # Extract the underlying Record name and it's associated structure + for this Hash that the user is attempting to store into my $record_name = $self->[1]; my %record_structure = %{$records_table{$record_name}}; if (not defined $record_structure{$field_name}) { carp "\nTie::Record: Attempt to set unknown Record field \"$field_ +name\" in a hash assigned to Record \"$record_name\""; return; }; # User specifie +d a field name that doesn't exist in the Record structure my $allowed_field_type = $record_structure{$field_name}; # Extract field + type (recScalar, etc) for this particular field # Based on the allowed field type, determine if the to-be-stored value + is a match. # The logic of this 'for' statement is: # If not a match, print error and return from STORE immediately (the +reby not storing value) # If is a match, then jump to the bottom of the 'for' and continue w +ith STORE for ($allowed_field_type) { /^recScalar$/ && do {if (not( ref(\$value) eq "SCALAR" )) {fail +msg1($field_name, $allowed_field_type); return} else {last}}; /^recScalarPtr$/ && do {if (not( ref($value) eq "SCALAR" )) {fail +msg1($field_name, $allowed_field_type); return} else {last}}; /^recHashPtr$/ && do {if (not( ref($value) eq "HASH" )) {fail +msg1($field_name, $allowed_field_type); return} else {last}}; /^recArrayPtr$/ && do {if (not( ref($value) eq "ARRAY" )) {fail +msg1($field_name, $allowed_field_type); return} else {last}}; /^recAny$/ && do {last}; # First make sure user is storing an Array, then make sure eac +h element of array is a Scalar /^recListScalar$/ && do { if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $al +lowed_field_type); return}; for (my $i=0; $i <= $#{$value}; $i++) { if (not ref(\$value->[$i]) eq "SCALAR" ) {failmsg2($field_name +, $i, "Scalar"); return}; }; last; }; # First make sure user is storing an Array, then make sure eac +h element of array is a Hash /^recListHash$/ && do { if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $al +lowed_field_type); return}; for (my $i=0; $i <= $#{$value}; $i++) { if (not ref($value->[$i]) eq "HASH" ) {failmsg2($field_name, $ +i, "Hash"); return}; }; last; }; # First make sure user is storing an Array, then make sure eac +h element of array is an Array /^recListArray$/ && do { if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $al +lowed_field_type); return}; for (my $i=0; $i <= $#{$value}; $i++) { if (not ref($value->[$i]) eq "ARRAY" ) {failmsg2($field_name, +$i, "Array"); return}; }; last; }; # Determine if user is storing a "recList.xxxx" of something my $recList_of; ( ($recList_of) = /^recList(.*)$/ ) && do { # Then make sure they are storing an Array if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, "an +onymous list of $recList_of pointers"); return}; # Then make sure each element is of the type (xxxx) that t +he Record specifies for (my $i=0; $i <= $#{$value}; $i++) { # Compare type of element user is trying to STORE agai +nst type of element specified in Record if ( $value->[$i] =~ /.+=.+\(/ ) { # Then user h +as assigned a pointer to some Object at this element if ( not $value->[$i] =~ /^$recList_of=/ ) { # Then that p +ointed-to Object is not the type specified in the Record failmsg2($field_name, $i, $recList_of); return; }; } elsif ( ref($value->[$i]) eq "HASH" ) { # Then user h +as assigned a pointer to some Record at this element if (not $tied_records_table{$value->[$i]} eq $recList_of) +{ failmsg2($field_name, $i, $recList_of); return; }; } else { # Then user h +as neither pointed to an Object nor a Record failmsg2($field_name, $i, $recList_of); return; }; }; last; }; # If we've gotten here, then the Record must specify simply th +e name of another Record or the name of a single Object # Determine if what the user is storing is an Object if ( $value =~ /.+=.+/ ) { # Then user is atte +mpting to assign an Object to this field if ( $value =~ /^$_=/ ) { # Then Object being + assigned DOES match type specified in Record do {last}; } else { # Assigning an obje +ct, but it's not the type specified in the Record failmsg1($field_name, $allowed_field_type); return; }; }; # If we make it this far then we know the user is not attempting t +o assign an Object to this field. # They're either assigning a pointer to a Record or (mistakenly) t +he intended hash itself (not a pointer to it). # Hash fields that are other Records must hold a pointer to the ot +her record (ie a Hash pointer). if ( ref($value) eq "HASH" ) { # Then they're tryi +ng to assign a pointer to some Record/hash if ($tied_records_table{$value} eq $_) { # By reverse-table +lookup determine that they are assiging the # correct Recor +d pointer to this field last; } else { # They're assigning + a pointer to the wrong Record failmsg1($field_name, $allowed_field_type); return; }; } else # They are trying t +o assign something that isn't a Record (hash) pointer { failmsg1($field_name, "POINTER to Record $allowed_field_type") +; return; }; }; # End of 'for' +loop # If we make it this far, then the user is attempting to STORE a value + that _does_ match what the Record specifies # If the user is storing to a recList type of field, then we must +monitor that array to ensure that any elements later # push'ed or shift'ed or otherwise stored into it are also of the +type specified. To ensure this we Tie this to-be-stored # array to a special private package of Tie::Store that ongoingly +monitors what is STOREd into this array. if ($allowed_field_type =~ /^recList/) { my @contents = @$value; tie @{$value}, "Tie::Record::_anonlst", $allowed_field_type, $reco +rd_name, $field_name; @$value = @contents; }; $self->[0]->{$field_name} = $value; # FINALLY, stor +e the desired Value at the specified field Key }; # Called when user accesses their hash to retrieve a key/value pair sub FETCH { my $self = shift; my $field_name = shift; # Extract the underlying Record name and it's associated structure + for this Hash that the user is attempting to retrieve from my $record_name = $self->[1]; my %record_structure = %{$records_table{$record_name}}; if (not defined $record_structure{$field_name}) { carp "\nTie::Record: Attempt to retrieve unknown Record field \"$f +ield_name\" in a hash assigned to Record \"$record_name\""; return undef; }; # User specifie +d a field name that doesn't exist in the Record structure return $self->[0]->{$field_name}; # Valid name sp +ecified, retrieve and return it's value }; # User can perform a number of operations against their Record hash. # Most are legal and are performed as requested against the underlying + Hash that holds their key/value pairs. # The operations that remove keys from their hash are disallowed, this + is because the basic concept of a Record structure # is a pre-defined list of fields that are type-checked at runtime, dy +namic deletion or addition of fields isn't part of # the Record concept (for better or worse). It is assumed that if the +re is dynamic data that the user wants to add and delete # it will instead be stored as a Hash (or Array) in the Value componen +t of a particular, named Record field. sub FIRSTKEY { my $a = scalar keys %{$_[0]->[0]}; each %{$_[0]->[0]} } sub NEXTKEY { each %{$_[0]->[0]} } sub EXISTS { exists $_[0]->[0]->{$_[1]} } sub DELETE { carp "Tie::Record: Disallowed attempt to delete field \ +"$_[1]\" in Record" } sub CLEAR { carp "Tie::Record: Disallowed attempt to clear Record" +} 1; # This package is a private package used only by the Tie::Record code. + It's purpose is to monitor Record fields that are # defined as anonymous lists of something -- that is, record fields of + type "recList...". When a user user push'es or shift's # or otherwise stores into these lists, Perl directly modifies the arr +ay as requested, the STORE routine above in Tie::Record # never gets called to validate what has been stored. So to ensure th +e user is always storing an allowed data type the # following package is tie'd to the recList array. It is then able to + monitor every push, shift and other STORE into the array # and ensure the value being stored matches the type of element demand +ed by the Record's definition. package Tie::Record::_anonlst; use warnings; use strict; use Tie::Array; use Carp; our @ISA = qw(Tie::Array); our $error_msg = "*** Tie\::Record caught error ***"; # Datum stored +into array field in place of an illegal element user is # attempting to + store. Maybe this should be ""? # Called when Tie::Record performs under-the-covers tie against stored + recList array sub TIEARRAY { my $self = shift; # Array being s +tored into user's recList-type field of Record my $allowed_data_type = shift; # Type of recLi +st elements (recListScalar, recListHash, recList."xxxx", etc.) my $assoc_record_name = shift; # Along with ti +e'd array's data save the Record name with which it's associated my $assoc_field_name = shift; # Along with ti +e'd array's data save the Record's field name in which it's stored my %tie_data; # The underlying data that is tie'd with this array is a Hash. Th +e user's array data will be stored in the hash field with # key "DATA". # At the point of this TIEARRAY call the array will be empty. The + STORE function will likely be called immediately after. $tie_data{allowed_data_type} = $allowed_data_type; $tie_data{assoc_record_name} = $assoc_record_name; $tie_data{assoc_field_name} = $assoc_field_name; $tie_data{DATA} = []; return bless \%tie_data, $self; }; # Called by Perl when the user attempts to store a piece of data in th +eir recList array, such as via a push or shift sub STORE { my ($self, $index, $value) = @_; # Convenient error message subroutine for when user attempts to st +ore an illegal value into recList sub failmsg1 { carp "\nTie::Record: Attempt to set an element of the anonymous li +st in field \"$_[0]\" to the value \"$_[1]\", which is not a" . ($_[2]=~/^[aeiou]/i ? 'n ' : ' ') . "$_[2],"; }; # Similar, yet different, code to Tie::Record::STORE above. # Based on the allowed field type, determine if the to-be-stored value + is a match. # The logic of this 'for' statement is: # If not a match, print error, but then allow STORE to happen with a + substitute value that is, basically, an error message # If is a match, then just jump to the bottom of the 'for' and conti +nue with STORE for ($self->{allowed_data_type}) { # Ensure what's being stored is a Scalar. If not, substitute +our error message. /^recListScalar$/ && do { if ( not ref(\$value) eq "SCALAR" ) { failmsg1($self->{assoc_field_name}, $value, "Scalar"); $value=$error_msg; last} else {last} }; # Ensure what's being stored is a Hash pointer. If not, subst +itute our error message. /^recListHash$/ && do { if ( not ref($value) eq "HASH" ) { failmsg1($self->{assoc_field_name}, $value, "Hash"); $value=$error_msg; last} else {last} }; # Ensure what's being stored is an Array pointer. If not, sub +stitute our error message. /^recListArray$/ && do { if ( not ref($value) eq "ARRAY" ) { failmsg1($self->{assoc_field_name}, $value, "Array"); $value=$error_msg; last} else {last} }; # Ensure what's being stored is a pointer to an Object or anot +her Record, as appropriate; # if not, substitute our error message. my $recList_of; ( ($recList_of) = /^recList(.*)$/ ) && do { if ( $value =~ /.+=.+\(/ ) { # Then user has as +signed a pointer to some Object at this element if ( not $value =~ /^$recList_of=/ ) { # Then that pointe +d-to Object is not the type specified in the Record failmsg1($self->{assoc_field_name}, $value, $recList_of); $value=$error_msg; last; }; } elsif ( ref($value) eq "HASH" ) { # Then user has as +signed a pointer to some Record at this element if (not $Tie::Record::tied_records_table{$value} eq $recLi +st_of) { # Then tha +t pointed-to Record is not the type specified in the Record failmsg1($self->{assoc_field_name}, $value, $recList_of); $value=$error_msg; last; }; } else { # Then user has ne +ither pointed to an Object nor a Record failmsg1($self->{assoc_field_name}, $value, $recList_of); $value=$error_msg; last; }; last; }; }; return $self->{DATA}[$index] = $value; # Store th +e user's desired value, or our replacement error message, # into the + recList array at the requested position }; # Called when user accesses a particular element of a recList... array sub FETCH { my ($self, $index) = @_; return $self->{DATA}[$index]; }; # User can perform a number of operations against their recList array. # All are legal and are performed as requested against the underlying +Hash {DATA} field that contains the recList contents. # Many of the more complex array manipulation functions take advantage + of the Tie::Array methods, which this package # specifies as a parent package. sub FETCHSIZE { my $self = shift; return scalar @{$self->{DATA} +} }; sub STORESIZE { my ($self, $count) = @_; $#{$self->{DATA}} = $count-1; + }; sub EXISTS { my ($self, $index) = @_; exists $self->{DATA}[$index] +}; sub DELETE { my ($self, $index) = @_; delete $self->{DATA}[$index] +}; sub CLEAR { my $self = shift; $self->{DATA} = [] }; sub PUSH { my $self = shift; $self->SUPER::PUSH(@_) }; sub UNSHIFT { my $self = shift; $self->SUPER::UNSHIFT(@_) }; sub POP { my $self = shift; $self->SUPER::POP }; sub SHIFT { my $self = shift; $self->SUPER::SHIFT }; sub SPLICE { my $self = shift; $self->SUPER::SPLICE(@_) }; __END__
Edit by tye
Back to
Meditations