1## Copyright (c) 2000, 2001
2## Carnegie Mellon University Sphinx Group, Kevin A. Lenzo, Alan W Black
3## This software is available under the same terms as Perl itself.
4## Thanks much to Martijn van Beers (LotR)
5
6=head1 NAME
7
8Class::MethodMapper - Abstract Class wrapper for AutoLoader
9
10=head1 SYNOPSIS
11
12  BEGIN {
13    @MMDerived::ISA = qw(Class::MethodMapper
14                                  Exporter AutoLoader);
15  }
16
17  sub new {
18    my $class = shift;
19    my @args = @_;
20
21    my $self = Class::MethodMapper->new();
22    bless $self, $class;
23
24    my %map = (
25      'time_style' => {
26        'type'  => 'parameter',
27        'doc'   => 'How recording duration is decided',
28        'domain' => 'enum',
29        'options' => [qw(track prompt fixed click_stop deadman)],
30        'value' => 'prompt',
31      },
32
33      'iter_plan' => {
34        'type'  => 'volatile',
35        'doc'   => 'Currently active plan for iteration: perl code.',
36        'value' => 'play; color("yellow"); hold(0.75); color("red"); '
37                     . 'record; color;' ,  # see FestVox::ScriptLang
38
39      },
40    );
41
42    $self->set_map(%map);
43    $self->set(@args) if @args;
44    $self;
45  }
46
47=head1 DESCRIPTION
48
49Class::MethodMapper takes a hash of hashes and creates
50get() and set() methods, with (some) validation, for the
51maps listed.  Generally, a C<parameter> is something that
52can be saved and restored, whereas a C<volatile> is not
53serialized at save-time.
54
55=cut
56
57
58package Class::MethodMapper;
59$Class::MethodMapper::VERSION = "1.0";
60use strict;
61
62use Exporter;
63use AutoLoader;
64use English;
65use Cwd;
66use Sys::Hostname;
67use UNIVERSAL qw(isa);
68use IO::File;
69use Data::Dumper;
70
71BEGIN {
72  @MethodMapper::ISA = qw(Exporter AutoLoader);
73}
74
75=head1 CONSTRUCTORS
76
77=over 4
78
79=item new(@args)
80
81Creates and initializes an empty Class::MethodMapper.
82Calls C<set()> with its arguments.
83
84=back
85
86=head1 BUILT-IN METHODS
87
88=over 4
89
90=cut
91
92sub new {
93  my $class = shift;
94  my $self  = {};
95  bless $self, $class;
96
97  $self->set(@_) if @_;
98
99  return $self;
100}
101
102sub clone {
103  my $self = shift;
104
105  my %map = ($self->get_map('parameter'), $self->get_map('volatile'));
106  foreach my $key (keys %map) {
107    my $foo = {value => $map{$key}};
108    my $type = $self->get_meta ('type', $key);
109    $type && ($foo->{type} = $type);
110    my $doc = $self->get_meta ('doc', $key);
111    $doc && ($foo->{doc} = $doc);
112    my $domain = $self->get_meta ('domain', $key);
113    $domain && ($foo->{domain} = $domain);
114    my $options = $self->get_meta ('options', $key);
115    $options && ($foo->{options} = $options);
116    $map{$key} = $foo;
117  }
118  my $new = new Class::MethodMapper;
119  bless $new, ref ($self);
120  $new->set_map (%map);
121  $new->set (@_) if @_;
122  return $new;
123}
124
125=item set_map(%map)
126
127Sets the complete map for this object.  See FestVox::InitMap
128for a good example of a method map; it is the big one that
129FestVox::PointyClicky itself uses.  This should be generalized
130to let you set B<which> map, as C<get_map()> below.
131
132=cut
133
134sub set_map {
135  my $self = shift;
136  my %map  = @_;
137
138  for my $k (keys %map) {
139    $self->{$k} = $map{$k};
140  }
141  $self;
142}
143
144=item get_map($type)
145
146Get the map of a particular type, e.g. C<parameter>.  Note
147that the object itself is the top-level (complete) map,
148since Class::MethodMapper writes into variables in the object
149of the same name; the 'map' itself is just the variables
150of that C<type>.
151
152=cut
153
154sub get_map {
155  my $self = shift;
156  my $type  = shift;
157  my %map;
158
159  for my $var (grep $self->{$_}->{type} eq $type, keys %$self) {
160    # bare metal here since it'll be called all the time.
161    $map{$var} = $self->{$var}->{value};
162  }
163  %map;
164}
165
166=item delete_map(@mapnames)
167
168Delete the mapping for each variable in C<@mapnames>.
169
170=cut
171
172sub delete_map {
173  my $self = shift;
174  while (my $k = shift) {
175    delete $self->{$k};
176  }
177  $self;
178}
179
180=item get_meta('type', 'var')
181
182Get the C<meta> data of a given type for a named variable
183in th method map.
184
185  type     e.g. 'volatile', 'parameter'
186  doc      some human-readable string do describe this
187  value    current value; useful for initialization
188  domain   e.g. 'enum' or 'ref'
189  options  if domain is 'enum', an array reference of allowed values
190           if domain is 'ref', 'ARRAY', 'HASH' or the name of a class.
191
192=cut
193
194sub get_meta {
195  my $self = shift;
196  my $what = shift;
197  my $method = shift;
198  if (defined $self->{$method}
199      and defined $self->{$method}->{$what}) {
200    my $it = $self->{$method}->{$what};
201    # do something with ARRAY and HASH refs?
202    return($it);
203  } else {
204    undef;
205    # warn "$method does't have a meta type $what";
206  }
207}
208
209=item set_meta('type', 'var', value)
210
211Just what you would think.  Sets the C<meta> variable C<type>
212of C<var> to C<value>.
213
214=cut
215
216sub set_meta {
217  my $self = shift;
218  my $what = shift;
219  my $method = shift;
220  my $value = shift;
221  if (defined $self->{$method}) {
222    $self->{$method}->{$what} = $value;
223  } else {
224    # warn "$method does't have a meta type $what";
225  }
226  $self;
227}
228
229
230sub _enum_set {
231  my ($self, $key, $val) = @_;
232  my ($class) = $self =~ /^(.*?)=/g;
233
234  if (defined (my $options = $self->{$key}->{options})) {
235    if (grep { $_ eq $val } @$options) {
236      $self->{$key}->{value} = $val;
237    } else {
238      if ($self =~ /^(.*?)=/) {
239	my $sane = $options->[0];
240	my $o = join ', ', @$options;
241	warn "${class}->$key: '$val' is not one of ($o). "
242	  . "Using '$sane' instead.\n";
243	$self->{$key}->{value} = $sane;
244      }
245    }
246  } else {
247    $self->{$key}->{value} = $val;
248  }
249}
250
251sub _ref_set {
252  my ($self, $key, $val) = @_;
253  my ($class) = $self =~ /^(.*?)=/g;
254
255  my $ref = $self->{$key}->{options};
256  if (isa ($val, $ref)) {
257    $self->{$key}->{value} = $val;
258  } else {
259    warn "${class}->$key: '$val' is not a $ref\-ref. "
260      . "Using 'undef' instead.\n";
261    $self->{$key}->{value} = undef;
262  }
263}
264
265=item set('var' => 'value')
266
267Set the variable C<var> to
268the value C<'value'>.  Checks if C<var> is in the method
269map, and complains if it is not.  Does basic type checking
270if the C<meta> variable C<domain> is defined.
271
272This means it checks if the value is an element in the array
273reference in C<options> if C<domain> is 'enum' and checks if
274the value is indeed a reference of the specified type
275if C<domain> is 'ref'
276
277=cut
278
279sub set {
280  my $self = shift;
281
282  if (@_) {
283    my $class;
284    if ($self =~ /^(.*?)=/) {
285      $class = $1;
286    }
287
288    while (my $key = shift @_) {
289      my $val = shift @_;
290      if (not defined $self->{$key}) {
291	my ($p,$f,$l) = caller;
292	warn "$class doesn't have a(n) '$key' method [$f line $l]\n"
293	    if $class;
294      } else {
295	no strict 'refs';
296	my $domain = $self->{$key}->{domain};
297	if ($domain) {
298	  my $func = "_$domain\_set";
299	  $self->$func ($key, $val);
300	} else {
301	  $self->{$key}->{value} = $val;
302	}
303      }
304    }
305  }
306}
307
308=item get('var')
309
310Return the value of 'var' if it is defined and in the
311method map.
312
313=cut
314
315sub get {
316  my $self = shift;
317  my $method = shift;
318  my $caller_file = shift;
319  my $caller_line = shift;
320
321  if ($self =~ m/^(.*?)=/) {
322    my $class = $1;
323
324    if (not defined $self->{$method}) {
325      warn "MethodMapper: $self Can't AutoLoad instance method $method at $caller_file line $caller_line\n";
326      return undef;
327    } else {
328      if (not defined $self->{$method}->{type}) {
329	# warn "Unknown method call $method of type $type at $caller_file line $caller_line\n";
330	return undef;
331      }
332      return $self->{$method}->{value};
333    }
334  } else {
335    warn "MethodMapper: Can't invoke $method on $self at $caller_file line $caller_line\n";
336    return undef;
337  }
338}
339
340sub AUTOLOAD {
341  my $self = shift ;
342
343  # for $AUTOLOAD
344  no strict 'vars';
345
346  my $method = $AUTOLOAD;
347  $method =~ s/^.*:://;
348
349  if (@_) {
350    $self->set($method => $_[0]);
351  } else {
352    my ($p, $file, $line) = caller;
353    $self->get($method, $file, $line);
354  }
355}
356
357
358sub DESTROY {
359  my $self = shift;
360
361  for my $type (keys %$self) {
362    for my $param (keys %{$self->{$type}}) {
363      undef $self->{$type}->{$param};
364    }
365  }
366  #FIXME: find out what this was for, and how to change it to
367  #make it not give warnings on subclasses
368  #$self->SUPER::DESTROY;
369}
370
371=item save('type', \&callback, @args)
372
373loops over all the keys that have type 'type' and calls
374
375    &$callback ($self, $key, $value, @args);
376
377for each of them, where $key is the value of each key and $value
378is the hashref for its value.
379
380=cut
381
382sub save {
383    my ($self, $type, $callback, @args) = @_;
384
385    my %copy = $self->get_map($type);
386    foreach my $key (keys %copy) {
387      &$callback ($self, $key, $self->{$key}, @args);
388   }
389}
390
391=item save_config ('filename')
392
393saves all 'parameter' type key/value pairs to 'filename'
394
395=cut
396
397sub save_config {
398  my $self = shift;
399  my $file = shift;
400
401  my $fh = new IO::File (">$file");
402  unless (defined $fh) {
403    warn "MethodMapper: couldn't save state to $file: $!";
404    return 0;
405  }
406
407  my $host = Sys::Hostname::hostname;
408  my $username = getpwuid($REAL_USER_ID);
409
410  $self =~ /^(.*?)=/;
411  my $class = $1;
412
413  print $fh "#\n";
414  print $fh "# $class Configuration\n";
415  print $fh "# Last modified: $username\@$host ".localtime()."\n";
416  print $fh "#\n\n";
417
418  my $cb = sub {
419    my ($self, $key, $value) = @_;
420    my $v = '';
421
422    if (not defined $value->{value}) {
423      $v = '';
424    } else {
425      $v = $value->{value};
426    }
427
428    my $t = sprintf "%-20s", $key;
429    print $fh "\n";
430
431    print $fh "# $value->{doc}\n";
432    if ($value->{domain} eq 'ref') {
433      local $Data::Dumper::Indent = 1;
434      local $Data::Dumper::Terse = 1;
435      print $fh "$t => ", Data::Dumper->Dump ([$v]);
436    } else {
437      print $fh "$t => $v\n";
438    }
439  };
440
441  $self->save ('parameter', $cb);
442  print $fh "\n";
443  $fh->close;
444
445  return 1;
446}
447
448=item (\&callback, @args)
449
450loads earlier saved values of the object keys back by calling
451
452    &$callback ($self, @args);
453
454it expects the callback to return a ($key, $value) list. keeps
455looping till the callback function returns an undefined key.
456
457=cut
458
459sub restore {
460  my ($self, $callback, @args) = @_;
461
462  while (1) {
463    my ($key, $value) = &$callback ($self, @args);
464    return unless defined $key;
465    if (defined $value) {
466      $self->set ($key, $value);
467    }
468  }
469}
470
471=item restore_config ('filename')
472
473loads values from the file 'filename', which is in the format that
474save_config writes out.
475
476=cut
477
478sub restore_config {
479  my ($self, $file) = @_;
480  my $fh = new IO::File ($file);
481
482  unless (defined $fh) {
483    warn "MethodMapper: couldn't restore state from $file: $!\n";
484    return 0;
485  }
486  my $cb = sub {
487    my ($self) = @_;
488
489    # we only do one var, but we need the while for multiline stuff
490    return undef if $fh->eof;
491    my ($reffirst, $key, $value);
492    while (<$fh>) {
493      #my $line = <$fh>;
494
495      unless (/\S/) {
496	# try to catch runaway multilines by not allowing them to
497	# contain empty lines.
498	$reffirst = '';
499	next;
500      }
501      next if /^\#/;    # comment: FIRST char is a #
502
503      chomp;
504      if ($reffirst ne '') {
505	my $last = ']' if $reffirst eq '[';
506	$last = '}' if $reffirst eq '{';
507	my $line = $_;
508	$line =~ s/^\s+/ /;
509	$value .= $line;
510	next unless /^$last$/;
511	return ($key, eval ($value));
512	$reffirst = '';
513      }
514      ($key, $value) = split /\s+=>\s+/, $_, 2;
515      if (defined $key) {
516	if ($self->{$key}->{domain} eq 'ref') {
517	  if ($value eq '[' or $value eq '{') {
518	    $reffirst = $value;
519	  }
520	} else {
521	  return ($key, $value);
522	}
523      }
524    }
525  };
526
527  $self->restore ($cb);
528  close $fh;
529
530  return 1;
531}
532
533
5341;
535__END__
536
537=item var()
538
539C<var> itself is promoted to method status; if given no
540argument, it is considered a C<get()>, and if given
541argument(s), it is considered a C<set()>.  Thus, if you
542had a parameter called C<active> in the method map,
543Class::MethodMapper would use AutoLoader to create a C<active()>
544method (if ever called), so that C<$self->active> would
545return the current value, and C<$self->active(1)> would
546set it to C<1>.
547
548=back
549
550=head1 BUGS
551
552Terribly underdocumented.
553
554=head1 AUTHOR
555
556Copyright (c) 2000 Kevin A. Lenzo and Alan W Black, Carnegie
557Mellon Unversity.
558