home *** CD-ROM | disk | FTP | other *** search
/ Freelog 112 / FreelogNo112-NovembreDecembre2012.iso / Graphisme / XnViewMP / XnViewMP.exe / lib / Class / Struct.pm
Text File  |  2011-08-27  |  7KB  |  250 lines
  1. #line 1 "Class/Struct.pm"
  2. package Class::Struct;
  3.  
  4. ## See POD after __END__
  5.  
  6. use 5.006_001;
  7.  
  8. use strict;
  9. use warnings::register;
  10. our(@ISA, @EXPORT, $VERSION);
  11.  
  12. use Carp;
  13.  
  14. require Exporter;
  15. @ISA = qw(Exporter);
  16. @EXPORT = qw(struct);
  17.  
  18. $VERSION = '0.63';
  19.  
  20. ## Tested on 5.002 and 5.003 without class membership tests:
  21. my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
  22.  
  23. my $print = 0;
  24. sub printem {
  25.     if (@_) { $print = shift }
  26.     else    { $print++ }
  27. }
  28.  
  29. {
  30.     package Class::Struct::Tie_ISA;
  31.  
  32.     sub TIEARRAY {
  33.         my $class = shift;
  34.         return bless [], $class;
  35.     }
  36.  
  37.     sub STORE {
  38.         my ($self, $index, $value) = @_;
  39.         Class::Struct::_subclass_error();
  40.     }
  41.  
  42.     sub FETCH {
  43.         my ($self, $index) = @_;
  44.         $self->[$index];
  45.     }
  46.  
  47.     sub FETCHSIZE {
  48.         my $self = shift;
  49.         return scalar(@$self);
  50.     }
  51.  
  52.     sub DESTROY { }
  53. }
  54.  
  55. sub import {
  56.     my $self = shift;
  57.  
  58.     if ( @_ == 0 ) {
  59.       $self->export_to_level( 1, $self, @EXPORT );
  60.     } elsif ( @_ == 1 ) {
  61.     # This is admittedly a little bit silly:
  62.     # do we ever export anything else than 'struct'...?
  63.       $self->export_to_level( 1, $self, @_ );
  64.     } else {
  65.       goto &struct;
  66.     }
  67. }
  68.  
  69. sub struct {
  70.  
  71.     # Determine parameter list structure, one of:
  72.     #   struct( class => [ element-list ])
  73.     #   struct( class => { element-list })
  74.     #   struct( element-list )
  75.     # Latter form assumes current package name as struct name.
  76.  
  77.     my ($class, @decls);
  78.     my $base_type = ref $_[1];
  79.     if ( $base_type eq 'HASH' ) {
  80.         $class = shift;
  81.         @decls = %{shift()};
  82.         _usage_error() if @_;
  83.     }
  84.     elsif ( $base_type eq 'ARRAY' ) {
  85.         $class = shift;
  86.         @decls = @{shift()};
  87.         _usage_error() if @_;
  88.     }
  89.     else {
  90.         $base_type = 'ARRAY';
  91.         $class = (caller())[0];
  92.         @decls = @_;
  93.     }
  94.  
  95.     _usage_error() if @decls % 2 == 1;
  96.  
  97.     # Ensure we are not, and will not be, a subclass.
  98.  
  99.     my $isa = do {
  100.         no strict 'refs';
  101.         \@{$class . '::ISA'};
  102.     };
  103.     _subclass_error() if @$isa;
  104.     tie @$isa, 'Class::Struct::Tie_ISA';
  105.  
  106.     # Create constructor.
  107.  
  108.     croak "function 'new' already defined in package $class"
  109.         if do { no strict 'refs'; defined &{$class . "::new"} };
  110.  
  111.     my @methods = ();
  112.     my %refs = ();
  113.     my %arrays = ();
  114.     my %hashes = ();
  115.     my %classes = ();
  116.     my $got_class = 0;
  117.     my $out = '';
  118.  
  119.     $out = "{\n  package $class;\n  use Carp;\n  sub new {\n";
  120.     $out .= "    my (\$class, \%init) = \@_;\n";
  121.     $out .= "    \$class = __PACKAGE__ unless \@_;\n";
  122.  
  123.     my $cnt = 0;
  124.     my $idx = 0;
  125.     my( $cmt, $name, $type, $elem );
  126.  
  127.     if( $base_type eq 'HASH' ){
  128.         $out .= "    my(\$r) = {};\n";
  129.         $cmt = '';
  130.     }
  131.     elsif( $base_type eq 'ARRAY' ){
  132.         $out .= "    my(\$r) = [];\n";
  133.     }
  134.     while( $idx < @decls ){
  135.         $name = $decls[$idx];
  136.         $type = $decls[$idx+1];
  137.         push( @methods, $name );
  138.         if( $base_type eq 'HASH' ){
  139.             $elem = "{'${class}::$name'}";
  140.         }
  141.         elsif( $base_type eq 'ARRAY' ){
  142.             $elem = "[$cnt]";
  143.             ++$cnt;
  144.             $cmt = " # $name";
  145.         }
  146.         if( $type =~ /^\*(.)/ ){
  147.             $refs{$name}++;
  148.             $type = $1;
  149.         }
  150.         my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
  151.         if( $type eq '@' ){
  152.             $out .= "    croak 'Initializer for $name must be array reference'\n"; 
  153.             $out .= "        if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
  154.             $out .= "    \$r->$elem = $init [];$cmt\n"; 
  155.             $arrays{$name}++;
  156.         }
  157.         elsif( $type eq '%' ){
  158.             $out .= "    croak 'Initializer for $name must be hash reference'\n";
  159.             $out .= "        if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
  160.             $out .= "    \$r->$elem = $init {};$cmt\n";
  161.             $hashes{$name}++;
  162.         }
  163.         elsif ( $type eq '$') {
  164.             $out .= "    \$r->$elem = $init undef;$cmt\n";
  165.         }
  166.         elsif( $type =~ /^\w+(?:::\w+)*$/ ){
  167.             $out .= "    if (defined(\$init{'$name'})) {\n";
  168.            $out .= "       if (ref \$init{'$name'} eq 'HASH')\n";
  169.             $out .= "            { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n";
  170.            $out .= "       elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
  171.             $out .= "            { \$r->$elem = \$init{'$name'} } $cmt\n";
  172.             $out .= "       else { croak 'Initializer for $name must be hash or $type reference' }\n";
  173.             $out .= "    }\n";
  174.             $classes{$name} = $type;
  175.             $got_class = 1;
  176.         }
  177.         else{
  178.             croak "'$type' is not a valid struct element type";
  179.         }
  180.         $idx += 2;
  181.     }
  182.     $out .= "    bless \$r, \$class;\n  }\n";
  183.  
  184.     # Create accessor methods.
  185.  
  186.     my( $pre, $pst, $sel );
  187.     $cnt = 0;
  188.     foreach $name (@methods){
  189.         if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
  190.             warnings::warnif("function '$name' already defined, overrides struct accessor method");
  191.         }
  192.         else {
  193.             $pre = $pst = $cmt = $sel = '';
  194.             if( defined $refs{$name} ){
  195.                 $pre = "\\(";
  196.                 $pst = ")";
  197.                 $cmt = " # returns ref";
  198.             }
  199.             $out .= "  sub $name {$cmt\n    my \$r = shift;\n";
  200.             if( $base_type eq 'ARRAY' ){
  201.                 $elem = "[$cnt]";
  202.                 ++$cnt;
  203.             }
  204.             elsif( $base_type eq 'HASH' ){
  205.                 $elem = "{'${class}::$name'}";
  206.             }
  207.             if( defined $arrays{$name} ){
  208.                 $out .= "    my \$i;\n";
  209.                 $out .= "    \@_ ? (\$i = shift) : return \$r->$elem;\n"; 
  210.                 $out .= "    if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
  211.                 $sel = "->[\$i]";
  212.             }
  213.             elsif( defined $hashes{$name} ){
  214.                 $out .= "    my \$i;\n";
  215.                 $out .= "    \@_ ? (\$i = shift) : return \$r->$elem;\n";
  216.                 $out .= "    if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
  217.                 $sel = "->{\$i}";
  218.             }
  219.             elsif( defined $classes{$name} ){
  220.                 if ( $CHECK_CLASS_MEMBERSHIP ) {
  221.                     $out .= "    croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
  222.                 }
  223.             }
  224.             $out .= "    croak 'Too many args to $name' if \@_ > 1;\n";
  225.             $out .= "    \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
  226.             $out .= "  }\n";
  227.         }
  228.     }
  229.     $out .= "}\n1;\n";
  230.  
  231.     print $out if $print;
  232.     my $result = eval $out;
  233.     carp $@ if $@;
  234. }
  235.  
  236. sub _usage_error {
  237.     confess "struct usage error";
  238. }
  239.  
  240. sub _subclass_error {
  241.     croak 'struct class cannot be a subclass (@ISA not allowed)';
  242. }
  243.  
  244. 1; # for require
  245.  
  246.  
  247. __END__
  248.  
  249. #line 637
  250.