libclass-methodmaker-perl 2.18-1build2 / usr / lib / perl5 / Class / MethodMaker / OptExt.pm

# (X)Emacs mode: -*- cperl -*-

package Class::MethodMaker::OptExt;

=head1 NAME

Class::MethodMaker::OptExt - Constants for C::MM's option extension mechanism

=head1 SYNOPSIS

This class is internal to Class::MethodMaker and should not be used by any
clients.  It is B<not> part of the public API.

=head1 DESCRIPTION

This class contains the constants used by Class::MethodMaker to determine the
names of its methods dependent upon options invoked.

=cut

# ----------------------------------------------------------------------------

# Pragmas -----------------------------

require 5.006;
use strict;
use warnings;

# Inheritance -------------------------

use base qw( Exporter );
our @EXPORT_OK = qw( OPTEXT );

# Utility -----------------------------

use Carp qw( carp croak );

# ----------------------------------------------------------------------------

# CLASS METHODS --------------------------------------------------------------

# -------------------------------------
# CLASS CONSTANTS
# -------------------------------------

=head1 CLASS CONSTANTS

Z<>

=cut

use constant COMPONENT_TYPES => qw( scalar array hash );

# Max 8 codepoints else fix dereferencing in encode, below
use constant codepoints => [qw( refer decl
                                postac asgnchk
                                predefchk defchk
                                reset
                                read store )];
# codepoint_value is a map from codepoint to a unique power of two, used to
# check for illegal combinations of options
use constant codepoint_value => +{ map({codepoints->[$_]=>2**$_}
                                       0..$#{codepoints()})
                                 };
use constant cv_reverse      => +{ reverse %{codepoint_value()} };

=head2 OPTEXT

OPTEXT is a map from options that are implemented as method extensions to
the option parameters.

Parameter keys are:

=over 4

=item encode

code number (to allow the option combination to be encoded whilst keeping the
length of the subr name no more than 8 chars).  encode is required for all
opts (for determining method extension), and must be a power of two.

=item refer

Code for referring to storage (default: '$_[0]->{$name}').

=item decl

Code for declaring storage.

=item postac

Code to execute immediately after any assignment check --- for example, to
initialize storage if necessary

=item asgnchk

Code for checking assignments.

=item defchk

Code for default checking.

=item reset

Code to execute when resetting an element

=item read

Code to execute each time an value is read

=item store

Code to execute each time a value is stored

=back

=cut

# Defines Matrix
#
# codepoint->  refer decl postac asgnchk predefchk defchk reset read store
# option
#
# static         X    X
# type                              X
# default                                            X
# default_ctor                                       X
# tie_class                 X                X              X
# v1_compat
# read_cb                                                        X
# store_cb                                                             X

use constant OPTEXT => { DEFAULT => { refer     => '$_[0]->{$name}',
                                      decl      => '',
                                      postac    => '',
                                      asgnchk   => '',
                                      predefchk => '',
                                      defchk    => '',
                                      reset     => '',
                                      read      => ['__VALUE__', ''],
                                      store     => '',
                                    },

                        static =>  { encode  => 1,
                                     refer   => '$store[0]',
                                     decl    => 'my @store;',
                                    },
                        type   =>  { encode  => 2,
                                     asgnchk => <<'END',
for (__FOO__) {
  croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" .
                "  : should be '%s' (or subclass thereof)\n",
                (defined($_)                                     ?
                 (ref($_) ? ref($_) : "plain value(-->$_<--)" )  :
                 '*undef*'
                ), $type))
    unless ! defined $_ or UNIVERSAL::isa($_, $type);
}
END
                                    },
                         default => { encode => 4,
                                      defchk => <<'END',
if ( ! exists %%STORAGE%% ) {
  %%ASGNCHK__SIGIL__($default)%%
  %%STORAGE%% = $default
}
END
                                    },
                         default_ctor => { encode => 8,
                                           defchk => <<'END',
if ( ! exists %%STORAGE%% ) {
  my $default = $dctor->($_[0]);
  %%ASGNCHK__SIGIL__($default)%%
  %%STORAGE%% = $default
}
END
                                         },
                         tie_class => { encode => 16,
                                        postac => <<'END',
tie %%STORAGE(__SIGIL__)%%, $tie_class, @tie_args
  unless exists %%STORAGE%%;
END
                                        predefchk => <<'END',
tie %%STORAGE(__SIGIL__)%%, $tie_class, @tie_args
  unless exists %%STORAGE%%;
END
                                        reset => <<'END',
untie %%STORAGE(__SIGIL__)%%;
END
                                      },
                         v1_compat => { encode => 32,
                                      },
                         read_cb => { encode => 64,
                                      read => [(<<'END') x 2],
{ # Encapsulate scope to avoid redefined $v issues
  my $v = __VALUE__;
  $v = $_->($_[0], $v)
    for @read_callbacks;
  $v;
}
END
                                    },
                         store_cb => { encode => 128,
                                       store =><<'END',
my __NAME__ = __VALUE__;
if ( exists %%STORAGE%% ) {
  my $old = %%STORAGE%%;
  __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old)           %%V2ONLY%%
  __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old, __ALL__)  %%V1COMPAT%%
    for @store_callbacks;
} else {
  __NAMEREF__ = $_->($_[0], __NAMEREF__, $name)                 %%V2ONLY%%
  __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, undef, __ALL__) %%V1COMPAT%%
    for @store_callbacks;
}
END
                                    },
                        typex   =>  { encode  => 256,
                                     asgnchk => <<'END',
for (__FOO__) {
#   $_ += 0;
#  croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" .
#                "  : should be '%s' (or subclass thereof)\n",
#                (defined($_)                                     ?
#                 (ref($_) ? ref($_) : "plain value(-->$_<--)" )  :
#                 '*undef*'
#                ), $typex))
#    unless ! defined $_ or UNIVERSAL::isa($_, $typex);
}
END
                                    },
                       };

# Single value representing the codepoints defined for each option
sub optdefvalue {
  my $class = shift;
  my ($option) = @_;

  my $code = OPTEXT->{$option};
  croak "Illegal option name: '$option'\n"
    unless defined $code;

  my $value = 0;
  for ( @{codepoints()} ) {
    $value |= codepoint_value->{$_}
      if exists $code->{$_};
  }

#  return split //, unpack "b9", chr($value >> 8) . chr($value & 255);
#print $value;
  return split //, unpack "b16", chr($value >> 8) .  chr($value & 255);
}

BEGIN {
  croak "No encode value found for type $_\n"
    for grep ! OPTEXT->{$_}->{encode}, grep $_ ne 'DEFAULT', keys %{OPTEXT()};
}

# -------------------------------------
# CLASS CONSTRUCTION
# -------------------------------------

# -------------------------------------
# CLASS COMPONENTS
# -------------------------------------

=head1 CLASS COMPONENTS

Z<>

=cut

# -------------------------------------
# CLASS HIGHER-LEVEL FUNCTIONS
# -------------------------------------

=head1 CLASS HIGHER-LEVEL FUNCTIONS

Z<>

=cut

=head2 encode

Take a set of options, return a two-letter code being the extension to add to
the method to incorporate the extensions, and a list (arrayref) of the
extensions represented.

=over 4

=item SYNOPSIS

  my ($ext, $opt) =
    Class::MethodMaker::OptExt->encode([qw( static type foobar )]);

=item ARGUMENTS

=over 4

=item options

The options to encode, as an arrayref of option names

=back

=item RETURNS

=over 4

=item ext

A code (string) to append to a methodname to represent the options used.

=item opts

The options represented by the ext .  This is generally a subset of the of
those provided in options, for not all general options are handled by an
encoded methodname.

=back

=back

=cut

sub encode {
  my $class = shift;
  my ($type, $options) = @_;

  {
    my @check;
    for my $opt (grep exists OPTEXT->{$_}, @$options) {
      my @v = $class->optdefvalue($opt);
      $check[$_] += $v[$_]
        for 0..$#v;
    }
    if ( grep $_ > 1, @check ) {
      local $" = ',';
      return;
    }
  }

  my $ext = '';
  my @optused;

  if ( grep $_ eq $type, COMPONENT_TYPES ) {
    my $value = 0;
    for (@$options) {
      push(@optused, $_), $value += OPTEXT->{$_}->{encode}
        if exists OPTEXT->{$_};
    }
    $ext = sprintf("%04x", $value);
  }

  return $ext, \@optused;
}

# -------------------------------------

sub option_names { grep $_ ne 'DEFAULT', keys %{OPTEXT()} }

sub optcode {
  my $class = shift;
  my ($codepoint, $options) = @_;

  my $code;
  for my $opt (grep exists OPTEXT->{$_}->{$codepoint}, @$options) {
    $code = OPTEXT->{$opt}->{$codepoint};
  }

  if ( ! defined $code ) {
    if ( exists OPTEXT->{DEFAULT}->{$codepoint} ) {
      $code = OPTEXT->{DEFAULT}->{$codepoint};
    } else {
      croak "Codepoint '$codepoint' not recognized\n";
    }
  }

  return $code;
}

# -------------------------------------

sub replace {
  my $class = shift;
  my ($st) = @_;
  my %replace;
    $replace{$_} = Class::MethodMaker::OptExt->optcode($_, $st)
        for @{Class::MethodMaker::OptExt->codepoints};
  return %replace;
}

# -------------------------------------
# CLASS HIGHER-LEVEL PROCEDURES
# -------------------------------------

=head1 CLASS HIGHER-LEVEL PROCEDURES

Z<>

=cut

# INSTANCE METHODS -----------------------------------------------------------

# -------------------------------------
# INSTANCE CONSTRUCTION
# -------------------------------------

=head1 INSTANCE CONSTRUCTION

Z<>

=cut

# -------------------------------------
# INSTANCE FINALIZATION
# -------------------------------------

# -------------------------------------
# INSTANCE COMPONENTS
# -------------------------------------

=head1 INSTANCE COMPONENTS

Z<>

=cut

# -------------------------------------
# INSTANCE HIGHER-LEVEL FUNCTIONS
# -------------------------------------

=head1 INSTANCE HIGHER-LEVEL FUNCTIONS

Z<>

=cut

# -------------------------------------
# INSTANCE HIGHER-LEVEL PROCEDURES
# -------------------------------------

=head1 INSTANCE HIGHER-LEVEL PROCEDURES

Z<>

=cut

# ----------------------------------------------------------------------------

=head1 EXAMPLES

Z<>

=head1 BUGS

Z<>

=head1 REPORTING BUGS

Email the development mailing list C<class-mmaker-devel@lists.sourceforge.net>.

=head1 AUTHOR

Martyn J. Pearce

=head1 COPYRIGHT

Copyright (c) 2003 Martyn J. Pearce.  This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

Z<>

=cut

1; # keep require happy.

__END__