view release on metacpan or  search on metacpan

lib/Attribute/Storage.pm  view on Meta::CPAN

Normally it is an error to attempt to apply the same attribute more than once
to the same target. Sometimes however, it would make sense for an attribute
to be applied many times. If the C<ATTR()> list is given the C<MULTI> flag,
then applying it more than once will be allowed. Each invocation of the
handling code will be given the previous value that was returned, or C<undef>
for the first time. It is up to the code to perform whatever merging logic is
required.

   sub Description :ATTR(CODE,MULTI,RAWDATA)
   {
      my $package = shift;
      my ( $olddesc, $more ) = @_;

      return defined $olddesc ? "$olddesc$more\n" : "$more\n";
   }

   sub Argument :ATTR(CODE,MULTI)
   {
      my $package = shift;
      my ( $args, $argname ) = @_;

      push @$args, $argname;
      return $args;
   }

   sub Option :ATTR(CODE,MULTI)
   {
      my $package = shift;
      my ( $opts, $optname ) = @_;

      $opts and exists $opts->{$optname} and
         croak "Already have the $optname option";

      $opts->{$optname}++;
      return $opts;
   }

   ...

   sub do_copy
      :Description(Copy from SOURCE to DESTINATION)
      :Description(Optionally preserves attributes)
      :Argument("SOURCE")
      :Argument("DESTINATION")
      :Option("attrs")
      :Option("verbose")
   {
      ...
   }

=cut

sub handle_attr_ATTR
{
   my ( $pkg, $ref, undef, $opts ) = @_;

   my $attrs = _get_attr_hash( $ref, 1 );

   my %type;
   foreach ( split m/\s*,\s*/, $opts ) {
      m/^(?:CODE|SCALAR|ARRAY|HASH)$/ and 
         ( $type{lc $_} = 1 ), next;

      m/^RAWDATA$/ and
         ( $type{raw} = 1 ), next;

      m/^MULTI$/ and
         ( $type{multi} = 1 ), next;

      m/^NAME$/ and
         ( $type{name} = 1 ), next;

      croak "Unrecognised attribute option $_";
   }

   if( $type{name} ) {
      # TODO: maybe this could be made to work but it seems to require a lot
      # of hunting around in the symbol table or lexical pad to work out the
      # name when given only a reference. Probably not worth it?
      $type{lc $_} and croak "Cannot apply NAME to :ATTR($_)" for qw( SCALAR ARRAY HASH );
   }

   $attrs->{ATTR} = \%type;

   return 0;
}

sub handle_attr
{
   my ( $pkg, $ref, $attrname, $opts ) = @_;

   my $cv = $pkg->can( $attrname ) or return 1;
   my $cvattrs = _get_attr_hash( $cv, 0 ) or return 1;
   my $type = $cvattrs->{ATTR} or return 1;

   my $reftype = ref $ref;

   $reftype =~ m/^(?:CODE|SCALAR|ARRAY|HASH)$/ && $type->{lc $reftype} or
      croak "Cannot apply :$attrname to $reftype reference";

   my @opts;
   if( $type->{raw} ) {
      @opts = ( $opts );
   }
   else {
      @opts = do {
         no strict;
         defined $opts ? eval $opts : ();
      };

      if( $@ ) {
         my ( $msg ) = $@ =~ m/^(.*) at \(eval \d+\) line \d+\.$/;
         croak "Unable to parse $attrname - $msg";
      }
   }

   my $attrs = _get_attr_hash( $ref, 1 );

   if( $type->{name} ) {
      unshift @opts, svref_2object( $ref )->GV->NAME;