package AMF::Noun;

#    This module implements most of the AMF record object interface (see
#    AMF::Record manpage).

#    An AMF noun is like an AMF record, only without an identifier.


use strict;
use warnings;

use UNIVERSAL qw( isa );
use Carp::Assert;

require AMF::AdjContainer;


sub new {
  my $proto = shift;
  my $class = ref( $proto ) || $proto;

  my @para  = @_;
  
  my $self = {
              TYPE => undef,
              ATTR => undef,
#              ID   => undef,
              @para
             };

  my $attr = $self -> {ATTR};
  if ( $attr -> {id} )  { $self -> {ID}  = $attr -> {id};   }
  if ( $attr -> {ref} ) { $self -> {REF} = $attr -> {ref};  }

  bless $self, $class;
}



sub type { 
  my $self = shift;
  return $self -> {TYPE};
}


sub ref {
  my $self = shift;
  return $self -> {REF};
}

sub id {
  my $self = shift;
  return $self -> {ID};
}




sub get_value {
  my $self = shift;
  my @specs = shift;

  my @res    = ();
  my @values = ();


  for ( @specs ) {
    
    my @steps = split "/", $_;

    my $step = shift @steps;

    if ( not $step 
         or not $self -> {$step} ) {
      return ();  ### no success
    }

    my @next;
    
    {
      my $val;
      
      if ( $step =~ /^@(.+)/ ) {
        $val = $self -> {ATTR} {$1};

      } else {
        $val = $self -> {$step};
      }


      if ( not CORE::ref $val ) {
        return ( $val );
        
      } if ( CORE::ref $val eq 'ARRAY' ) {
        @next = @$val;
      }
    }

    foreach ( @next ) {

      if ( CORE::ref $_  eq 'ARRAY' ) {

        my $subpath;
        if ( scalar @steps ) {
          $subpath = join "/", @steps;

          if ( $subpath =~ /^\@(.+)/ ) {

            my $a = $1;
            if (
                $_ ->[1]     ### attributes
                and CORE::ref $_ ->[1] 
                and defined $_ ->[1] {$a} ) {
              push @values, $_ ->[1] -> {$a};
            } # else { warn "at $a not found in $_->[0]" }
            next;
          }

        }

        my $v = $_ -> [0];

        if ( not $subpath ) {
          push @values, $v;
          next;
        }          

        if (    isa( $v, "AMF::AdjContainer" )
             or isa( $v, "AMF::Noun" ) 
           ) {
          ### verb or adjective-container 

          my @v = $v -> get_value( $subpath );
          push @values, @v;
                        
        } else {
          ### adjective 
          ### nothing else we can do
        }

      } else {
        warn "Incorrect internal structure";
      }
      
    }
    
  }

  ###  filter out empty values
  foreach ( @values ) {
    if ( not $_ ) {  next;  }
    push @res, $_;
  }
  
  # return the found

  if ( wantarray ) {
    return @res;
  } else {
    return $res[0];
  }
}




sub get_value_wattr {
  my $self = shift;
  my $spec = shift;

  my @res    = ();
  my @values = ();

  my @steps = split "/", $spec;

  my $step = shift @steps;

  if ( not $step 
       or not $self -> {$step} ) {
    return ();  ### no success
  }

  my @next;

  {
    my $val;
      
    if ( $step =~ /^@(.+)/ ) {
      return ();

    } else {
      $val = $self -> {$step};
    }
    
    if ( not CORE::ref $val ) {
      return ( );
      
    } if ( CORE::ref $val eq 'ARRAY' ) {
      @next = @$val;
    }
  }

  foreach ( @next ) {

    ###   @next list is expected to contain array refs

    if ( CORE::ref $_  eq 'ARRAY' ) {

      my $subpath;
      if ( scalar @steps ) {
        $subpath = join "/", @steps;
      }

      if ( not $subpath ) {
        push @values, $_;
        next;
      }          

      my $v = $_ -> [0];
     
      if (    isa( $v, "AMF::AdjContainer" )
              or isa( $v, "AMF::Noun" ) 
         ) {
        ### verb or adjective-container 
        
        my @v = $v -> get_value_wattr( $subpath );
        push @values, @v;
        
      } else {
        ### adjective 
        ### nothing else we can do
      }

    } else {
      warn "Incorrect internal structure";
    }
      
  }
    
  ###  filter out empty values
  foreach ( @values ) {
    if ( not defined $_ 
         or not scalar @$_ ) {  next;  }
    push @res, $_;
  }
  
  # return the found

  if ( wantarray ) {
    return @res;
  } else {
    return $res[0];
  }
}



############################################################
###   data change interface
############################################################

sub add_value {
  my $self = shift;
  my $name = shift;
  my @val  = @_;

  for ( $self ->{$name} ) {
    if ( not $_ ) {  $_ = [];  }
    push @$_, @val;
  }  
}


sub adjective {
  my $self = shift;
  my $name = shift;
  my $ats  = shift || die;
  my %att  = ( %$ats );
  my $value = shift;
  
  my $data = [ $value ];
  if ( scalar keys %att ) {
    push @$data, \%att;
  }
  $self -> add_value( $name, $data );
}


sub adjcontainer {
  my $self = shift;
  my $name = shift;
  my $att  = shift;
  my $value = shift;
  
  my $data = [ $value ];
  my %att = ( %$att );
  if ( scalar keys %att ) {
    push @$data, \%att;
  }
  $self -> add_value( $name, $data );
}


sub verb {
  my $self = shift;
  my $name = shift;
  my $attr = shift;
  
  my @nouns = @_;

  foreach ( @nouns ) {
    if ( isa( $_, 'AMF::Noun' ) ) {
      my $pack = [ $_ ];
      if ( scalar keys %$attr ) {
        $pack -> [1] = $attr;
      }
      $self -> add_value( $name, $pack );

    } else { # foreign
      $self -> add_value( $name, $_ );
    }
  }
  ### XX?  Check attributes?
}


sub foreignel {
  my $self = shift;

  assert( $_[0]     ); # the element name (with the namespace)
  assert( $_[1]     ); # attributes
  assert( CORE::ref $_[2] ); # content (array)
  assert( not $_[3] ); # nothing more
  
  my $name = shift;
  my $attr = shift;
  my $cont = shift;

  $self -> adjective( $name, $attr, $cont );
}




sub problem {
  my $self = shift;
  my $message = shift;
  for ( $self -> {PROBLEMS} ) {
    if ( defined $_ ) {
      $_ .= "\n$message";
    } else {
      $_ = $message; 
    }
  }
}


sub md5checksum {
  my $self = shift;

  if ( $self -> {MD5SUM} ) {
    return $self -> {MD5SUM};
  } 

  require Digest::MD5;
  
  my $xml = $self -> stringify;
  
  require Encode;
  my $digest = Digest::MD5::md5_base64( Encode::encode_utf8( $xml ) );
  $self -> {MD5SUM} = $digest;
  return $digest;
}



# use vars qw( %NSP2U %NSU2P @NSP_used );

# use AMF;

# sub prepare_namespaces {
#   my $spec = $AMF::SPEC;
#   if ( not scalar keys %NSP2U ) {
#     foreach ( $spec -> {namespaces} ) {
#       my $p = $_;
#       my $u = $spec -> {namespaces} {$p};
#       $NSP2U{$p} = $u;
#       $NSP2U{$u} = $p;
#     }
#   }
# }

# sub dump { 
#   my $self = shift;

#   @NSP_used = ();
#   my $xml = $self -> stringify;

#   my $nsdecl = '';

#   foreach ( keys @NSP_used ) {
#     my $prefix = $_;
#     my $uri    = $NSP2U{$prefix};

#     if ( $prefix ) {
#       $nsdecl .= ' xmlns:$prefix="' . $uri . '"';
#     } else {
#       $nsdecl .= ' xmlns="' . $uri . '"';
#     }
#   }

#   my $type = $self->{TYPE};
#   if ( $nsdecl ) {
#     $xml =~ s!^<($type[^<>]+)>!<$1\n $nsdecl>!;
#   }
  
#   return $xml;
# }



sub xml_escape_text($);


sub stringify {
  my $self   = shift;
  my $prefix = shift || '';
  
  my $s = '';

  my $type = $self->{TYPE};
  if ( $type ) {
    
    $s = "$prefix<$type";
    if ( $self -> {ID} ) {
      $s .= " " . 
        xml_attribute( 'id', $self->{ID} );
    }
    if ( $self -> {REF} ) {
      $s .= " " . 
        xml_attribute( 'ref', $self->{REF} );
    }
    $s .=">\n";
  } 

  foreach ( keys %$self ) {
    if ( m/^\p{Ll}/ ) {
      my $k = $_;
      my $v = $self -> {$_};
      my $childtype;
      
      if ( CORE::ref $v ) {
        if ( isa( $v, "ARRAY" ) ) {

          if ( CORE::ref $v->[0] eq 'ARRAY' ) {
            
            if ( isa( $v->[0][0], 'AMF::AdjContainer' ) ) {
              $childtype = 'adjcontainer';

            } elsif ( isa( $v->[0][0], 'AMF::Noun' ) ) {
              $childtype = 'verb';

            } elsif ( not CORE::ref $v ->[0][0] ) {
              $childtype = 'adjective';
            }

          }

          if ( $childtype ) {
            no strict 'refs';
            $s .= &{ "dump_child_$childtype" }( $k, $v, "$prefix  " );
          }
        }
      }
      
    } else {
#      $s .= "  <${_}/>\n";
    }
  }
  
  if ( $type ) {
    $s .= "$prefix</$type>";
  }

  return $s;
}

sub stringify_attributes ($) {
  my $attr = shift;
  my $s = '';
  if ( $attr and CORE::ref $attr eq 'HASH' ) {
    foreach ( keys %$attr ) { 
      my $name = $_;
      my $va   = $attr -> {$name};
      if ( $name =~ m/\s/ ) {
        ### XXX  Namespace-qualified attributes
      } else {          
        $s .= " ";
        $s .= xml_attribute( $name, $va );
      }
    }
  }
  return $s;
}

sub dump_child_verb {
  my $verb = shift;
  my $list = shift;
  my $prefix = shift || "  ";

  my $last_attrs;

  my $s = '';

  foreach ( @$list ) {
    my $attr     = $_ -> [1];
    my $attr_str = stringify_attributes( $attr );
    
    if ( not defined $last_attrs
         or $attr_str ne $last_attrs ) {
      if ( defined $last_attrs ) {
        $s .= "$prefix</$verb>\n";
      }
      $s .= "$prefix<$verb$attr_str>\n";
    }

    $s .= $_ ->[0] -> stringify( "$prefix  " );
    $s .= "\n";
    $last_attrs = $attr_str;
  }
  $s .= "$prefix</$verb>\n";
  return $s;
}


sub dump_child_adjective {
  my $adj  = shift;
  my $list = shift;
  my $prefix = shift || "  ";

  my $s = '';

  my $ename = $adj;
  my $nsdecl = '';

  if ( $ename =~ m/^(\S*)\s(\S+)$/ ) {
    $ename = $2;
    $nsdecl = " " . 
      xml_attribute( "xmlns", $1 );
  }
   
  foreach ( @$list ) {
    my $val  = $_ -> [0];
    my $attr = $_ -> [1];
    $s .= "$prefix<$ename$nsdecl";
    $s .= stringify_attributes $attr;
    $s .= ">";
    $s .= xml_escape_text $val;
    $s .= "</$ename>\n";
  }
  return $s;
}


sub dump_child_adjcontainer {

  my $adj  = shift;
  my $list = shift;
  my $prefix = shift || "  ";

  my $s = '';

  foreach ( @$list ) {
    if ( isa( $_->[0], 'AMF::AdjContainer' ) ) {
      my $attr = $_ ->[1];
      my $astr = stringify_attributes $attr;

      $s .= "$prefix<$adj$astr>\n";
      $s .= $_->[0] -> stringify ( $prefix );
      $s .= "$prefix</$adj>\n";

    } else {
      $s .= "$prefix<!-- incorrect structure, expected AdjContainer -->\n";
    }
  }

  return $s;
}


sub xml_attribute($$) {
  my $name  = shift;
  my $value = shift;
 
  for ( $value ) {
    s!&!&amp;!g;
    s!<!&lt;!g;
    s!'!&apos;!g;
    s!"!&quot;!g;
    tr/\0-\x{8}\x{B}\x{C}\x{E}-\x{1F}/?/;
  }
  return "$name='$value'";
}

sub xml_escape_text($) {
  my $value = shift;
  for ( $value ) {
    s!&!&amp;!g;
    s!<!&lt;!g;
    s!]]>!]]&gt;!g;
    tr/\0-\x{8}\x{B}\x{C}\x{E}-\x{1F}/?/;
  }
  return $value;
}

1;


