# Run: "pod2man filename.pm | nroff -man | more" to see the documentation 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, change the C 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 complete 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 the values assigned to a given hash field match those intended for that particular field. =item 3) The ability to turn off the run-time checking at compile time, such that 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 table obj => new Blackjack::Dealer, # One BJ Dealer object for table 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 table }; ... 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 entries 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 structure 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 after debug of your application; a C will eliminate type checking and any associated performance impact. =head2 Solution Provided The above Blackjack Table object could make use of Tie::Record by including 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 Scalar dealer => "Dealer", # Will hold pointer to hash described # 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 this # structure will be used in the above BJ_Table "dealer" key entry Record Dealer => obj => "Blackjack::Dealer", # A Blackjack::Dealer object cardsFaceUp => recList."Cards::Card", # [] of Cards::Card objects cardsFaceDown => recList."Cards::Card"; # [] of Cards::Card objects # Define the structure for a Player hash. A list of these hashes will # be stored in the above BJ_Table hash, under the "players" key. Record Player => obj => "Blackjack::Player", # A Blackjack::Player object cardsFaceUp => recList."Cards::Card", # [] of Cards::Card objects 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 (or C) Hash variables that are each associated with one of the above records. For example: The ->new method for Blackjack::Table might replace the code shown earlier with the following: my $data = {}; # To-be bless'ed hash for BJ Table Associate %$data => "BJ_Table";# Associate underlying Hash (not the # ptr) with BJ_Table Record structure my %dealer = (); # Dealer Hash to be filled in and then # saved in $data->{dealer} as a pointer Associate %dealer => "Dealer"; # Associate this Hash with Dealer Record # Initialize the %dealer Hash. Note that this code looks like (and is) # the same standard Perl you would code without the Tie::Record module. # This fact is important, because it is what allows you to turn off # 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 ptr The ->acquire_player(...) method for our Table object might include code 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 ensures # $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 players push @{$table->{"players"}}, (\%playerRec); # Tie::Record ensures that what is # placed under the "players" key is an # anonymous list of pointers to Player # Hashes If ->acquire_player(...) tries any of the following, a run-time Carp error will be generated by Tie::Record: # Tie::Record would notice that this isn't a Blackjack::Player object $playerRec{obj} = new Blackjack::Dealer; # Tie::Record would notice this isn't a pointer to an anonymous array $playerRec{cardsFaceUp} = (); # Tie::Record notices this isn't an ANONYMOUS LIST of Player Hashes $table->{"players"} = \%playerRec; # Tie::Record would notice this isn't a push of a Player hash POINTER 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"}->deal); # 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 objects 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: To define the structure of a Hash, called a Record. This procedure expects the name of the Record being defined followed by 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: To associate a Perl Hash with a Record template defined earlier. This procedure expects a Perl Hash variable and the Record name to which 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 is the name for the Record. C and C are the fields (keys) to be used in an associated Hash. By using the C<< => >> syntax it is only necessary to use quotes in the C call, and then only around the record-name string (as shown above). The following are the supported data types for Record fields: =over 4 =item B> A Perl Scalar can be assigned. This means strings or numbers, not pointers to things. =item B> Any value can be assigned, no checking is done against what is stored in a field specified as this data type. =item B> A pointer to a Scalar value. For example: C<\"a string"> or C<\$a> =item B> A pointer to a Hash. For example: C<\%abc> or C<< {a=>1} >> =item B> A pointer to an Array (more commonly known as an anonymous list). For example: C<\@abc> or C<[1, 2, 3]> =item B> An object of type "Foo::Bar". For example: C<< Foo::Bar->new >> or simply C<$foobar>, if a previous assignment said C<$foobar = new Foo::Bar>. =item B> A pointer to a Hash that was Bd with a Record named "record_abc". This is basically a Hash within a Hash where the sub-Hash has a defined Record structure (see the examples above.) For example: C<\%a>, assuming that previously you said C<< Associate %a => "record_abc" >>. =item B> 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 is OK. C is Not OK. =item B> 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 will be detected. For example: C is OK. C is Not OK. =item B> 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 is OK. C is Not OK. =item B> 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 object 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> An anonymous list of "record_abc" records (pointers to "record_abc" Hashes, that is). For example: C<[\%hash1]>, assuming that previously you said C<< Associate %hash1 => "record_abc" >> Attempting to Push an item onto this list that is not a hash associated with "record_abc" will be detected. For example: Assuming %hash1 was Bd with "record_abc" and %hash2 was not. C is OK. C is Not OK. =back =head2 Nullifying Tie::Record behavior The run-time checking that Tie::Record performs may not be something you want to incur when your code is run in a production mode. Just commenting out the C statement would not be sufficient to remove Tie::Record module's behavior, because you'd then get syntax errors for all the B> and B> statements 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 statement in your main module, then just add the C statement. A C 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 statement to be a B>, 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>d to this module, and therefore they will operate with no impact from Tie::Record. =head1 AUTHOR Andy Schwartz =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, such 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 if user's code executes "no Tie::Record" # %records_table holds the complete list of Record names and their associated structure layouts # %tied_records_table holds a "reverse list" whose keys are the addresses 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() are 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 exported automatically. sub Record ($@) { return if $production_code; my ($field, $datatype, $recList_entity); # Automatically pre-pend caller's package name to the Record structure's name my ($callers_package) = caller; my $record_name = $callers_package . "::" . shift; my %record_structure = @_; # Record structure 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 example: # "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 recList of Record names, then # prepend the calling package's name to the Record name specified. next if $datatype =~ /^recScalar$ | ^recAny$ | ^recScalarPtr$ | ^recHashPtr$ | ^recArrayPtr$ | ^recListScalar$ | ^recListArray$ | ^recListHash /x; # No pre-pending 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 caller'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 . "::" . $datatype unless $datatype =~ /::/; # Pre-pend caller'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 structure. 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 creating and tie'ing with an underlying array. # First element is anonyoums Hash that will hold user's keys and values. 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 list 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 specified 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 (thereby not storing value) # If is a match, then jump to the bottom of the 'for' and continue with STORE for ($allowed_field_type) { /^recScalar$/ && do {if (not( ref(\$value) eq "SCALAR" )) {failmsg1($field_name, $allowed_field_type); return} else {last}}; /^recScalarPtr$/ && do {if (not( ref($value) eq "SCALAR" )) {failmsg1($field_name, $allowed_field_type); return} else {last}}; /^recHashPtr$/ && do {if (not( ref($value) eq "HASH" )) {failmsg1($field_name, $allowed_field_type); return} else {last}}; /^recArrayPtr$/ && do {if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $allowed_field_type); return} else {last}}; /^recAny$/ && do {last}; # First make sure user is storing an Array, then make sure each element of array is a Scalar /^recListScalar$/ && do { if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $allowed_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 each element of array is a Hash /^recListHash$/ && do { if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $allowed_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 each element of array is an Array /^recListArray$/ && do { if (not( ref($value) eq "ARRAY" )) {failmsg1($field_name, $allowed_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, "anonymous list of $recList_of pointers"); return}; # Then make sure each element is of the type (xxxx) that the Record specifies for (my $i=0; $i <= $#{$value}; $i++) { # Compare type of element user is trying to STORE against type of element specified in Record if ( $value->[$i] =~ /.+=.+\(/ ) { # Then user has assigned a pointer to some Object at this element if ( not $value->[$i] =~ /^$recList_of=/ ) { # Then that pointed-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 has 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 has 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 the 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 attempting to assign an Object to this field if ( $value =~ /^$_=/ ) { # Then Object being assigned DOES match type specified in Record do {last}; } else { # Assigning an object, 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 to assign an Object to this field. # They're either assigning a pointer to a Record or (mistakenly) the intended hash itself (not a pointer to it). # Hash fields that are other Records must hold a pointer to the other record (ie a Hash pointer). if ( ref($value) eq "HASH" ) { # Then they're trying 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 Record 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 to 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, $record_name, $field_name; @$value = @contents; }; $self->[0]->{$field_name} = $value; # FINALLY, store 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 \"$field_name\" in a hash assigned to Record \"$record_name\""; return undef; }; # User specified a field name that doesn't exist in the Record structure return $self->[0]->{$field_name}; # Valid name specified, 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, dynamic deletion or addition of fields isn't part of # the Record concept (for better or worse). It is assumed that if there is dynamic data that the user wants to add and delete # it will instead be stored as a Hash (or Array) in the Value component 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 array as requested, the STORE routine above in Tie::Record # never gets called to validate what has been stored. So to ensure the 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 demanded 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 stored into user's recList-type field of Record my $allowed_data_type = shift; # Type of recList elements (recListScalar, recListHash, recList."xxxx", etc.) my $assoc_record_name = shift; # Along with tie'd array's data save the Record name with which it's associated my $assoc_field_name = shift; # Along with tie'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. The 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 their recList array, such as via a push or shift sub STORE { my ($self, $index, $value) = @_; # Convenient error message subroutine for when user attempts to store an illegal value into recList sub failmsg1 { carp "\nTie::Record: Attempt to set an element of the anonymous list 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 continue 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, substitute 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, substitute 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 another Record, as appropriate; # if not, substitute our error message. my $recList_of; ( ($recList_of) = /^recList(.*)$/ ) && do { if ( $value =~ /.+=.+\(/ ) { # Then user has assigned a pointer to some Object at this element if ( not $value =~ /^$recList_of=/ ) { # Then that pointed-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 assigned a pointer to some Record at this element if (not $Tie::Record::tied_records_table{$value} eq $recList_of) { # Then that 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 neither 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 the 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__