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