package AMF::Parser::Basic;

###  object-oriented and flexible


use strict;
use warnings;

use XML::Parser::Expat;
no Carp::Assert;  ### NO DEBUGging

require Exporter;


use vars  qw( @EXPORT @EXPORT_OK @ISA );
@ISA    = qw( Exporter );

@EXPORT = qw( cur_context open_context close_context spec $spec error warning 
              push_record pop_record
              $expat
              debug
            );

@EXPORT_OK = qw( &cur_context &open_context &close_context 
                 &spec );


use vars  qw( $self $spec $stack $context $rlist $expat $records_stack );


require AMF::Record;
require AMF::Parser::Contexts;

my $hpkg = 'AMF::Parser::Basic::';


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

  my @para  = @_;
  
  my $self = {
              NOUN_CB => undef,
              SPEC   => undef,
              XML_LANG_CASCADING => 1,
              REPORT_ENCLOSED_NOUNS => 0,
              @para,
#              REPORT => 1,
              STACK => [],
              LIST  => [],
             };

  bless $self, $class;
  
  $self -> create_parser ();
  
  return $self;
}

sub create_parser {
  my $self = shift;

  my $parser = XML::Parser::ExpatNB -> new( Namespaces => 1 );

  no strict 'refs';

  $parser -> setHandlers( 'Start', \&{"${hpkg}StartTag"},
                          'End',   \&{"${hpkg}EndTag"},
                          'Char',  \&{"${hpkg}Text"},
                        );
                                         
  assert( $parser ) if DEBUG;
  $self -> {PARSER} = $parser;
}


sub initialize {
  $self = shift;

  $spec  = $self -> {SPEC};
  $stack = $self -> {STACK} = [];
  $rlist = $self -> {LIST}  = [];

  $records_stack = $self -> {RECORDSTACK} = [];

  $self -> {EOF}   = 0;
  $self -> {FATAL_ERROR} = 0;
  $self -> {INPUT} = 0;

  undef $AMF::Parser::Contexts::XML_LANG;
}


sub parse_file {
  my $self = shift;
  my $file = shift || die;
  
  if ( $self -> start_file( $file ) ) {
    
    while ( not $self->{EOF} 
            and not $self -> {FATAL_ERROR} ) {
      $self -> get_more_data();
    }
  }

  return not $self -> {FATAL_ERROR};  
}


sub parse_string {
  $self = shift;
  my $str  = shift;
  
  $self -> initialize;
  
  my $parser = $self ->create_parser;
  
  
  { no strict 'refs';
    &{ "${hpkg}StartDocument" } ( $parser );
  }

  $parser -> parse_more( $str );
  $parser -> parse_done;
  $self -> {EOF} = 1;

  return not $self -> {FATAL_ERROR};  
}

sub parse_fh {
  $self  = shift;
  my $fh = shift || die;

  $self -> initialize;
  if ( $fh and not eof( $fh ) ) {
    $self -> {INPUT} = 'fh';
    $self -> {fh} = $fh;

    my $parser = $self ->create_parser;
    
    { no strict 'refs';
      &{ "${hpkg}StartDocument" } ( $parser );
    }
    
    return 1;
  }

  return undef;
}


sub start_file {
  $self    = shift;
  my $file = shift || die;

  $self -> initialize;

  my $open = open INPUT, $file;
  if ( $open ) {
    $self -> {INPUT} = 'file';

    my $parser = $self ->create_parser;
    
    { no strict 'refs';
      &{ "${hpkg}StartDocument" } ( $parser );
    }

    return 1;

  } 

  return undef;
}


sub get_more_data {
  my $self  = shift;
  my $parser = $self -> {PARSER};

  assert( $self -> {INPUT} );

  my $return;
  my $src = $self->{INPUT};
  my $buffer;
  my $chars ;
  if ( $src eq 'file' ) {
    $chars = read INPUT, $buffer, 7000;

  } elsif ( $src eq 'fh' ) {
    $chars = read $self->{fh}, $buffer, 7000;
  }

  my $eof;
  if ( $chars < 7000 ) {   $eof = 1;   }

  eval {
    if ( $buffer ) {
      $parser -> parse_more( $buffer );
    } 
    if ( $eof  ) {
      $parser -> parse_done();
    }
  };


  if ( $@ ) {
    if ( $@ =~ m!xml/parser!i 
         or $@ =~ m! at line \d+, column !i ) {
      if ( $self -> {REPORT} ) {
        my $m = $@;
        if ( $@ =~ m/^\s+(.+?)\s*$/ ) { $m = $1; }
        if ( $m =~ m!^(.+) at lib/AMF/Parser/Basic.pm line \d+$! ) { $m = $1; }
        print "  XML error: $m\n";
        $self -> {FATAL_ERROR} = 1;
      }

    } else {
      ### anything else
      if ( $self -> {REPORT} ) {
        my $m = substr( $@, 0 );
        if ( $@ =~ m/^\s+(.+?)\s*$/ ) { $m = $1; }
        print "  Parser: $m";
        $self -> {FATAL_ERROR} = 1;
      }
    }
    undef $@;
    $return = "0 but true";
  }


  $self -> {EOF} = $eof;
  if ( $eof ) {

    if ( $src eq 'file' ) {
      close INPUT;
    } else {
      close $self ->{fh};
    }
    
    undef $self -> {INPUT};
    if ( not $return ) { 
      no strict 'refs';
      &{ "${hpkg}EndDocument" } ( $parser );
    }
  }

  return $return || $chars;
}




sub get_next_noun {
  $self = shift;

  if ( scalar @$rlist ) {
    return shift @$rlist;

  } else {

    while ( not scalar @$rlist ) {
      if ( $self -> {EOF} 
           or $self -> {FATAL_ERROR} ) {
        return undef;
      }
      $self -> get_more_data();
    }

    return $self -> get_next_noun;
  }
}


sub push_record ($) { push @$records_stack, shift; }
sub pop_record  () { return pop @$records_stack; }


sub debug (@) {
#  print @_, "\n";
}

sub error ($) {
  my $m = shift;
  if ( $self -> {REPORT} ) {
    $expat -> xpcroak( "AMF error: $m\n" );
  }
  $records_stack->[-1] -> problem( "error: $m" );
}

sub warning ($) {
  my $m = shift;

  my $pos  = $expat -> current_column;
  my $line = $expat -> current_line; 
  my $byte = $expat -> current_byte;     

  my $message = "warning: $m at line $line, column $pos, byte $byte";

  if ( $self -> {REPORT} ) {
#    $expat -> xpcarp( "AMF warning: $m\n" );
#    my $context = $expat -> position_in_context( 1 );
    print "  AMF ", $message, "\n";
  }
  if ( scalar @$records_stack ) {
    $records_stack->[-1] -> problem( $message );
  }
}


sub cur_context {
  return $stack -> [-1];
}

sub open_context {
  my $type = shift;
  my @para = @_;

  my $new = AMF::Parser::Contexts -> new( $type, $self, @para );

  assert( $new ) if DEBUG;
  push @$stack, $new;

  if ( DEBUG ) {
    print "open context: $new (@para)\n";
  }
}

sub close_context {
  assert( scalar @$stack ) if DEBUG;

  if ( DEBUG ) {
    print "close context\n";
  }

  my $last = pop @$stack;
  if ( scalar @_ ) {
    $stack -> [-1] -> child( @_ );
  }
}

sub spec {
  return $spec; 
}


sub StartDocument {
  $expat = shift;
  $expat->{Text} = '';

  open_context( 'Free' );
}



sub StartTag {
  $expat  = shift;
  my $name = shift;

  doText();

#  print "element: $name\n";
  %_ = ();
  my $ns_uris = $spec -> {namespace_uris};

  while ( scalar @_ ) {
    my $at = shift;
    my $va = shift;
    my $uri = $expat -> namespace( $at );
    if ( $uri ) { 
      if ( $ns_uris ->{$uri} ) {
        my $prefix = $ns_uris ->{$uri};
        $at = "$prefix:$at";

      } else {
        $at = "$uri $at";
      }
    }
    $_{$at} = $va;
  }

  assert( $stack )        if DEBUG;
  assert( $stack -> [0] ) if DEBUG;
  assert( $stack -> [-1] ) if DEBUG;
  assert( ref( $stack -> [-1] ) ) if DEBUG;

  my $uri = $expat -> namespace( $name );
  my $context = $stack -> [-1] -> element( $name, $uri );

  if ( $context ) {
    open_context( $context, $name );
  }
  return;
       
}

sub EndTag {
  my $exp  = shift;
  my $name = shift;

  ### XXX set expat->{Context} as XML::Parser::Stream does?
  doText();

  assert( $stack -> [-1] ) if DEBUG;
  my $cur = $stack -> [-1];
  my $uri = $exp -> namespace( $name );
  $cur -> end_tag( $name, $uri );
}


sub Text {
  my $expat = shift;
  $expat->{Text} .= shift;
}

sub doText   {
  if ( length $expat->{Text} ) {
    $_ = $expat->{Text};
    assert( $stack -> [-1] ) if DEBUG;
    assert( scalar @$stack ) if DEBUG;
    my $cur = $stack -> [-1];
    $cur -> text( $_ );
    $expat->{Text} = '';
  }
}


sub EndDocument {
  my $exp = shift;

  assert( scalar @$stack ) if DEBUG;
  assert( scalar @$stack == 1 ) if DEBUG;
  close_context();

  undef $expat;
  return 1;
}

sub PI {}



1;
