File Coverage

lib/Class/MethodMaker/OptExt.pm
Criterion Covered Total %
statement 57 77 74.0
branch 8 14 57.1
condition n/a
subroutine 12 15 80.0
pod 1 5 20.0
total 78 111 70.2


line stmt bran cond sub pod time code
1             # (X)Emacs mode: -*- cperl -*-
2              
3             package Class::MethodMaker::OptExt;
4              
5             =head1 NAME
6              
7             Class::MethodMaker::OptExt - Constants for C::MM's option extension mechanism
8              
9             =head1 SYNOPSIS
10              
11             This class is internal to Class::MethodMaker and should not be used by any
12             clients. It is B part of the public API.
13              
14             =head1 DESCRIPTION
15              
16             This class contains the constants used by Class::MethodMaker to determine the
17             names of its methods dependent upon options invoked.
18              
19             =cut
20              
21             # ----------------------------------------------------------------------------
22              
23             # Pragmas -----------------------------
24              
25             require 5.006;
26 8     8   27 use strict;
  8         9  
  8         225  
27 8     8   35 use warnings;
  8         11  
  8         218  
28              
29             # Inheritance -------------------------
30              
31 8     8   28 use base qw( Exporter );
  8         10  
  8         684  
32             our @EXPORT_OK = qw( OPTEXT );
33              
34             # Utility -----------------------------
35              
36 8     8   34 use Carp qw( carp croak );
  8         12  
  8         418  
37              
38             # ----------------------------------------------------------------------------
39              
40             # CLASS METHODS --------------------------------------------------------------
41              
42             # -------------------------------------
43             # CLASS CONSTANTS
44             # -------------------------------------
45              
46             =head1 CLASS CONSTANTS
47              
48             Z<>
49              
50             =cut
51              
52 8     8   33 use constant COMPONENT_TYPES => qw( scalar array hash );
  8         24  
  8         565  
53              
54             # Max 8 codepoints else fix dereferencing in encode, below
55 8         587 use constant codepoints => [qw( refer decl
56             postac asgnchk
57             predefchk defchk
58             reset
59 8     8   31 read store )];
  8         13  
60             # codepoint_value is a map from codepoint to a unique power of two, used to
61             # check for illegal combinations of options
62 72         564 use constant codepoint_value => +{ map({codepoints->[$_]=>2**$_}
  8         18  
63 8         13 0..$#{codepoints()})
64 8     8   30 };
  8         12  
65 8     8   29 use constant cv_reverse => +{ reverse %{codepoint_value()} };
  8         11  
  8         9  
  8         1204  
66              
67             =head2 OPTEXT
68              
69             OPTEXT is a map from options that are implemented as method extensions to
70             the option parameters.
71              
72             Parameter keys are:
73              
74             =over 4
75              
76             =item encode
77              
78             code number (to allow the option combination to be encoded whilst keeping the
79             length of the subr name no more than 8 chars). encode is required for all
80             opts (for determining method extension), and must be a power of two.
81              
82             =item refer
83              
84             Code for referring to storage (default: '$_[0]->{$name}').
85              
86             =item decl
87              
88             Code for declaring storage.
89              
90             =item postac
91              
92             Code to execute immediately after any assignment check --- for example, to
93             initialize storage if necessary
94              
95             =item asgnchk
96              
97             Code for checking assignments.
98              
99             =item defchk
100              
101             Code for default checking.
102              
103             =item reset
104              
105             Code to execute when resetting an element
106              
107             =item read
108              
109             Code to execute each time an value is read
110              
111             =item store
112              
113             Code to execute each time a value is stored
114              
115             =back
116              
117             =cut
118              
119             # Defines Matrix
120             #
121             # codepoint-> refer decl postac asgnchk predefchk defchk reset read store
122             # option
123             #
124             # static X X
125             # type X
126             # default X
127             # default_ctor X
128             # tie_class X X X
129             # v1_compat
130             # read_cb X
131             # store_cb X
132              
133 8         1733 use constant OPTEXT => { DEFAULT => { refer => '$_[0]->{$name}',
134             decl => '',
135             postac => '',
136             asgnchk => '',
137             predefchk => '',
138             defchk => '',
139             reset => '',
140             read => ['__VALUE__', ''],
141             store => '',
142             },
143              
144             static => { encode => 1,
145             refer => '$store[0]',
146             decl => 'my @store;',
147             },
148             type => { encode => 2,
149             asgnchk => <<'END',
150             for (__FOO__) {
151             croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" .
152             " : should be '%s' (or subclass thereof)\n",
153             (defined($_) ?
154             (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
155             '*undef*'
156             ), $type))
157             unless ! defined $_ or UNIVERSAL::isa($_, $type);
158             }
159             END
160             },
161             default => { encode => 4,
162             defchk => <<'END',
163             if ( ! exists %%STORAGE%% ) {
164             %%ASGNCHK__SIGIL__($default)%%
165             %%STORAGE%% = $default
166             }
167             END
168             },
169             default_ctor => { encode => 8,
170             defchk => <<'END',
171             if ( ! exists %%STORAGE%% ) {
172             my $default = $dctor->($_[0]);
173             %%ASGNCHK__SIGIL__($default)%%
174             %%STORAGE%% = $default
175             }
176             END
177             },
178             tie_class => { encode => 16,
179             postac => <<'END',
180             tie %%STORAGE(__SIGIL__)%%, $tie_class, @tie_args
181             unless exists %%STORAGE%%;
182             END
183             predefchk => <<'END',
184             tie %%STORAGE(__SIGIL__)%%, $tie_class, @tie_args
185             unless exists %%STORAGE%%;
186             END
187             reset => <<'END',
188             untie %%STORAGE(__SIGIL__)%%;
189             END
190             },
191             v1_compat => { encode => 32,
192             },
193             read_cb => { encode => 64,
194             read => [(<<'END') x 2],
195             { # Encapsulate scope to avoid redefined $v issues
196             my $v = __VALUE__;
197             $v = $_->($_[0], $v)
198             for @read_callbacks;
199             $v;
200             }
201             END
202             },
203             store_cb => { encode => 128,
204             store =><<'END',
205             my __NAME__ = __VALUE__;
206             if ( exists %%STORAGE%% ) {
207             my $old = %%STORAGE%%;
208             __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old) %%V2ONLY%%
209             __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old, __ALL__) %%V1COMPAT%%
210             for @store_callbacks;
211             } else {
212             __NAMEREF__ = $_->($_[0], __NAMEREF__, $name) %%V2ONLY%%
213             __NAMEREF__ = $_->($_[0], __NAMEREF__, $name, undef, __ALL__) %%V1COMPAT%%
214             for @store_callbacks;
215             }
216             END
217             },
218             typex => { encode => 256,
219             asgnchk => <<'END',
220             for (__FOO__) {
221             # $_ += 0;
222             # croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" .
223             # " : should be '%s' (or subclass thereof)\n",
224             # (defined($_) ?
225             # (ref($_) ? ref($_) : "plain value(-->$_<--)" ) :
226             # '*undef*'
227             # ), $typex))
228             # unless ! defined $_ or UNIVERSAL::isa($_, $typex);
229             }
230             END
231             },
232 8     8   30 };
  8         10  
233              
234             # Single value representing the codepoints defined for each option
235             sub optdefvalue {
236 55     55 0 78 my $class = shift;
237 55         56 my ($option) = @_;
238              
239 55         65 my $code = OPTEXT->{$option};
240 55 50       119 croak "Illegal option name: '$option'\n"
241             unless defined $code;
242              
243 55         63 my $value = 0;
244 55         49 for ( @{codepoints()} ) {
  55         95  
245 495 100       797 $value |= codepoint_value->{$_}
246             if exists $code->{$_};
247             }
248              
249             # return split //, unpack "b9", chr($value >> 8) . chr($value & 255);
250             #print $value;
251 55         595 return split //, unpack "b16", chr($value >> 8) . chr($value & 255);
252             }
253              
254             BEGIN {
255 8         3180 croak "No encode value found for type $_\n"
256 8     8   10 for grep ! OPTEXT->{$_}->{encode}, grep $_ ne 'DEFAULT', keys %{OPTEXT()};
257             }
258              
259             # -------------------------------------
260             # CLASS CONSTRUCTION
261             # -------------------------------------
262              
263             # -------------------------------------
264             # CLASS COMPONENTS
265             # -------------------------------------
266              
267             =head1 CLASS COMPONENTS
268              
269             Z<>
270              
271             =cut
272              
273             # -------------------------------------
274             # CLASS HIGHER-LEVEL FUNCTIONS
275             # -------------------------------------
276              
277             =head1 CLASS HIGHER-LEVEL FUNCTIONS
278              
279             Z<>
280              
281             =cut
282              
283             =head2 encode
284              
285             Take a set of options, return a two-letter code being the extension to add to
286             the method to incorporate the extensions, and a list (arrayref) of the
287             extensions represented.
288              
289             =over 4
290              
291             =item SYNOPSIS
292              
293             my ($ext, $opt) =
294             Class::MethodMaker::OptExt->encode([qw( static type foobar )]);
295              
296             =item ARGUMENTS
297              
298             =over 4
299              
300             =item options
301              
302             The options to encode, as an arrayref of option names
303              
304             =back
305              
306             =item RETURNS
307              
308             =over 4
309              
310             =item ext
311              
312             A code (string) to append to a methodname to represent the options used.
313              
314             =item opts
315              
316             The options represented by the ext . This is generally a subset of the of
317             those provided in options, for not all general options are handled by an
318             encoded methodname.
319              
320             =back
321              
322             =back
323              
324             =cut
325              
326             sub encode {
327 60     60 1 70 my $class = shift;
328 60         69 my ($type, $options) = @_;
329              
330             {
331 60         72 my @check;
  60         49  
332 60         163 for my $opt (grep exists OPTEXT->{$_}, @$options) {
333 55         128 my @v = $class->optdefvalue($opt);
334             $check[$_] += $v[$_]
335 55         601 for 0..$#v;
336             }
337 60 50       207 if ( grep $_ > 1, @check ) {
338 0         0 local $" = ',';
339 0         0 return;
340             }
341             }
342              
343 60         66 my $ext = '';
344 60         156 my @optused;
345              
346 60 100       214 if ( grep $_ eq $type, COMPONENT_TYPES ) {
347 56         63 my $value = 0;
348 56         84 for (@$options) {
349 65 100       199 push(@optused, $_), $value += OPTEXT->{$_}->{encode}
350             if exists OPTEXT->{$_};
351             }
352 56         209 $ext = sprintf("%04x", $value);
353             }
354              
355 60         209 return $ext, \@optused;
356             }
357              
358             # -------------------------------------
359              
360 0     0 0   sub option_names { grep $_ ne 'DEFAULT', keys %{OPTEXT()} }
  0            
361              
362             sub optcode {
363 0     0 0   my $class = shift;
364 0           my ($codepoint, $options) = @_;
365              
366 0           my $code;
367 0           for my $opt (grep exists OPTEXT->{$_}->{$codepoint}, @$options) {
368 0           $code = OPTEXT->{$opt}->{$codepoint};
369             }
370              
371 0 0         if ( ! defined $code ) {
372 0 0         if ( exists OPTEXT->{DEFAULT}->{$codepoint} ) {
373 0           $code = OPTEXT->{DEFAULT}->{$codepoint};
374             } else {
375 0           croak "Codepoint '$codepoint' not recognized\n";
376             }
377             }
378              
379 0           return $code;
380             }
381              
382             # -------------------------------------
383              
384             sub replace {
385 0     0 0   my $class = shift;
386 0           my ($st) = @_;
387 0           my %replace;
388 0           $replace{$_} = Class::MethodMaker::OptExt->optcode($_, $st)
389 0           for @{Class::MethodMaker::OptExt->codepoints};
390 0           return %replace;
391             }
392              
393             # -------------------------------------
394             # CLASS HIGHER-LEVEL PROCEDURES
395             # -------------------------------------
396              
397             =head1 CLASS HIGHER-LEVEL PROCEDURES
398              
399             Z<>
400              
401             =cut
402              
403             # INSTANCE METHODS -----------------------------------------------------------
404              
405             # -------------------------------------
406             # INSTANCE CONSTRUCTION
407             # -------------------------------------
408              
409             =head1 INSTANCE CONSTRUCTION
410              
411             Z<>
412              
413             =cut
414              
415             # -------------------------------------
416             # INSTANCE FINALIZATION
417             # -------------------------------------
418              
419             # -------------------------------------
420             # INSTANCE COMPONENTS
421             # -------------------------------------
422              
423             =head1 INSTANCE COMPONENTS
424              
425             Z<>
426              
427             =cut
428              
429             # -------------------------------------
430             # INSTANCE HIGHER-LEVEL FUNCTIONS
431             # -------------------------------------
432              
433             =head1 INSTANCE HIGHER-LEVEL FUNCTIONS
434              
435             Z<>
436              
437             =cut
438              
439             # -------------------------------------
440             # INSTANCE HIGHER-LEVEL PROCEDURES
441             # -------------------------------------
442              
443             =head1 INSTANCE HIGHER-LEVEL PROCEDURES
444              
445             Z<>
446              
447             =cut
448              
449             # ----------------------------------------------------------------------------
450              
451             =head1 EXAMPLES
452              
453             Z<>
454              
455             =head1 BUGS
456              
457             Z<>
458              
459             =head1 REPORTING BUGS
460              
461             Email the development mailing list C.
462              
463             =head1 AUTHOR
464              
465             Martyn J. Pearce
466              
467             =head1 COPYRIGHT
468              
469             Copyright (c) 2003 Martyn J. Pearce. This program is free software; you can
470             redistribute it and/or modify it under the same terms as Perl itself.
471              
472             =head1 SEE ALSO
473              
474             Z<>
475              
476             =cut
477              
478             1; # keep require happy.
479              
480             __END__