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

Class-MethodMaker documentation Contained in the Class-MethodMaker distribution.

Index

Code Index:

NAME

Top

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

SYNOPSIS

Top

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

DESCRIPTION

Top

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

CLASS CONSTANTS

Top

OPTEXT

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

Parameter keys are:

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.

refer

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

decl

Code for declaring storage.

postac

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

asgnchk

Code for checking assignments.

defchk

Code for default checking.

reset

Code to execute when resetting an element

read

Code to execute each time an value is read

store

Code to execute each time a value is stored

CLASS COMPONENTS

Top

CLASS HIGHER-LEVEL FUNCTIONS

Top

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.

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

options

The options to encode, as an arrayref of option names

RETURNS

ext

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

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.

CLASS HIGHER-LEVEL PROCEDURES

Top

INSTANCE CONSTRUCTION

Top

INSTANCE COMPONENTS

Top

INSTANCE HIGHER-LEVEL FUNCTIONS

Top

INSTANCE HIGHER-LEVEL PROCEDURES

Top

EXAMPLES

Top

BUGS

Top

REPORTING BUGS

Top

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

AUTHOR

Top

Martyn J. Pearce

COPYRIGHT

Top

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.

SEE ALSO

Top

Class-MethodMaker documentation Contained in the Class-MethodMaker distribution. 
# (X)Emacs mode: -*- cperl -*-

package Class::MethodMaker::OptExt;


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

# 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
# -------------------------------------


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()} };


# 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
# -------------------------------------


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


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
# -------------------------------------


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

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


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

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


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


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


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


1; # keep require happy.

__END__