view release on metacpan or  search on metacpan

local/lib/perl5/Struct/Dumb.pm  view on Meta::CPAN

   if( keys %syms ) {
      croak "Unrecognised export symbols " . join( ", ", keys %syms );
   }

   no strict 'refs';
   *{"${caller}::$_"} = $export{$_} for keys %export;
}

=head1 FUNCTIONS

=cut

sub _struct
{
   my ( $name, $fields, $caller, %opts ) = @_;

   my $lvalue = !!$opts{lvalue};
   my $named  = !!$opts{named_constructor};

   my $pkg = "${caller}::$name";

   my %subs;
   foreach ( 0 .. $#$fields ) {
      my $idx = $_;
      my $field = $fields->[$idx];

      BEGIN {
         overloading->unimport if HAVE_OVERLOADING;
      }

      $subs{$field} = $lvalue
         ? sub :lvalue { @_ > 1 and croak "$pkg->$field invoked with arguments";
                         shift->[$idx] }
         : sub         { @_ > 1 and croak "$pkg->$field invoked with arguments";
                         shift->[$idx] };
   }
   $subs{DESTROY} = sub {};
   $subs{AUTOLOAD} = sub :lvalue {
      my ( $field ) = our $AUTOLOAD =~ m/::([^:]+)$/;
      croak "$pkg does not have a '$field' field";
      my $dummy; ## croak can't be last because it isn't lvalue, so this line is required
   };

   my $constructor;
   if( $named ) {
      $constructor = sub {
         my %values = @_;
         my @values;
         foreach ( @$fields ) {
            exists $values{$_} or croak "usage: $pkg requires '$_'";
            push @values, delete $values{$_};
         }
         if( my ( $extrakey ) = keys %values ) {
            croak "usage: $pkg does not recognise '$extrakey'";
         }
         bless \@values, $pkg;
      };
   }
   else {
      my $fieldcount = @$fields;
      my $argnames = join ", ", map "\$$_", @$fields;
      $constructor = sub {
         @_ == $fieldcount or croak "usage: $pkg($argnames)";
         bless [ @_ ], $pkg;
      };
   }

   no strict 'refs';
   *{"${pkg}::$_"} = $subs{$_} for keys %subs;
   *{"${caller}::$name"} = $constructor;

   if( my $predicate = $opts{predicate} ) {
      *{"${caller}::$predicate"} = sub { ( ref($_[0]) || "" ) eq $pkg };
   }

   *{"${pkg}::_forbid_arrayification"} = sub {
      return if !HAVE_OVERLOADING and caller eq __PACKAGE__;
      croak "Cannot use $pkg as an ARRAY reference"
   };

   require overload;
   $pkg->overload::OVERLOAD(
      '@{}'  => sub { $_[0]->_forbid_arrayification; return $_[0] },
      '0+'   => sub { refaddr $_[0] },
      '""'   => sub { sprintf "%s=Struct::Dumb(%#x)", $pkg, refaddr $_[0] },
      'bool' => sub { 1 },
      fallback => 1,
   );
}

=head2 struct

   struct $name => [ @fieldnames ],
      named_constructor => (1|0),
      predicate         => "is_$name";

Creates a new structure type. This exports a new function of the type's name
into the caller's namespace. Invoking this function returns a new instance of
a type that implements those field names, as accessors and mutators for the
fields.

Takes the following options:

=over 4

=item named_constructor => BOOL

Determines whether the structure will take positional or named arguments.

=item predicate => STR

If defined, gives the name of a second function to export to the caller's
namespace. This function will be a type test predicate; that is, a function
that takes a single argmuent, and returns true if-and-only-if that argument is
an instance of this structure type.

=back

=cut

=head2 readonly_struct