package TDS::Tdf::Parser;
# $Id: Parser.pm,v 1.22.8.2 2001/02/28 17:35:17 tom Exp $
################################################################

=head1 NAME

TDS::Tdf::Parser - parse the given line

=head1 SYNOPSIS

 use TDS::Tdf::Parser;

 $p = new TDS::Tdf::Parser;

 while (<>){
     $p->Parse($_);
 }

 print $p->top->AsHTML({});

=head1 DESCRIPTION


=cut

################################################################

use strict qw(vars);

use ObjectTemplate;
use CGI::Tools;

use TDS::Tdf::Command;
use TDS::Tdf::Command::Classes;
use TDS::Mode;

=head2 MEMBER VARIABLES

 top       top node(TDS::Tdf::Command::Tdf)
 noparse   do NOT parse if true

=cut


attributes qw(top
	      noparse in_autolist);

use vars qw(@ISA
	    $UseRoffFormat
	    $AutoParagraphComplete $AutoHttpLink $AutoListing
	    $ContinueLineByEscape
	    $WarnReserved);
@ISA = qw(ObjectTemplate);


=head1 STATIC VARIABLES

 $AutoParagraphComplete   auto paragraph completion
 $AutoHttpLink            auto linking
 $AutoListing             auto listing
 $ContinueLineByEscape    contiuas line by /\$/
 $WarnReserved            warn if reserved command used
=cut


$AutoParagraphComplete = 1;
$AutoHttpLink = 1 unless defined $AutoHttpLink;
$AutoListing = 0 unless defined $AutoListing;
$ContinueLineByEscape = 0 unless defined $ContinueLineByEscape;
$WarnReserved = 1 unless defined $WarnReserved;
$UseRoffFormat = 0 unless defined $UseRoffFormat;

################################################################

=head1 MEMBER FUNCTIONS

=cut

sub initialize($)
{
    my $self = shift;

    $self->top(new TDS::Tdf::Command::Tdf);
    $self->top->{'pos'} = $self->top;

    # depended on TDS::Tdf::Command
#    print STDERR "parser setup:", times(), "\n";
    &TDS::Tdf::Command::Setup()
	unless $TDS::Tdf::Command::SetupDone;
#    print STDERR "parser setup done:", times(), "\n";
    $self->SUPER::initialize;
}

################################################################

=head2 $p->Parse($line);

与えられた行 $line を解析する
コマンド行なら $cmd_name or "/$cmd_name" を返す。テキストなら返さない

=cut

sub Parse($$)
{
    my ($self, $line) = @_;

#    $line =~ s/(\n\r)+$/\n/;
#    $line =~ s/\r+$/\n/;
    $line =~ s/\r\n/\n/;
    $line =~ s/\r/\n/;
    
    # 強制改行
    my $br_flg = 1 if !$self->noparse && $line =~ s/~$//;
    my $kind;

#    print "line: $line";
    # continuas line
    if (!$self->noparse &&
	$ContinueLineByEscape && $line =~ /^(.*)\\$/){    # /\$/
	$line = $1;
    }

    # may be tdf-command
    my $pat = '(/?)([A-Z]+)([\*\+\#]?)\s(.*)';
    if ($UseRoffFormat){
	$pat = '\.' . $pat;
    }
#    if ($line =~ m!^(/?)([A-Z]+)([\*+\#]?)\s(.*)$!){
    if ($line =~ m/^$pat$/){
	my ($is_end, $cmd_name, $opt_char, $arg) =
	    ($1 eq '/', $2, $3, $4);
	my $var = "TDS::Tdf::Command::${cmd_name}::NoParse";
	my $noparse = $$var;
#	print "$var, $noparse<br>";
	
#	print "CMD:$cmd_name<br>";
	unless ($is_end){
	    if ($noparse){
		$self->noparse(1);
	    } elsif ($self->noparse){
		$self->text($line);
		return undef;
	    }
#	    print "start: $line";
    	    $self->start($cmd_name, $arg, $opt_char, $line,
			 {'link'=>$opt_char eq '*',
			  'as_multiline'=>$opt_char eq '+',
			  'anchor'=>$opt_char eq '#'
			  });
	    $kind = $cmd_name;
	} else {
	    if ($noparse){
		$self->noparse(0);
	    } elsif ($self->noparse){
		$self->text($line);
		return undef;
	    }
	    $self->end($cmd_name, $arg);
	    $kind = "/$cmd_name";
	}
    } elsif ($AutoListing && (!$self->noparse) &&
#	     $line =~ /^(・|\*|\+)(.*)$/){      # 自動リスト生成
	     $line =~ /^(・|＋)(.*)$/){      # 自動リスト生成
	$self->in_autolist(1);               # flag on
	my $list_type = ($1 eq '+') ? 'OL' : 'UL';
	my $content = $2;
	my $li = new TDS::Tdf::Command::LI;
#	print "content-type: text/html\n\n";
	my $pos_name = $self->top->{'pos'}->Name;
#	print "$pos_name<br>";
	if ($pos_name !~ /^$list_type$/){
	    my $pos = $self->top->InsertCommand($list_type);
	    $self->top->{'pos'} = $pos;
	}
#	push(@{$li->{content}}, $content);
	$li->PushContent(Escape($content));
	$self->top->InsertCommand($li);
	$self->end("LI");
    } else {                              # plain text
	$self->text($line);
    }
    # if null line(/~$/), add BR
    if ($br_flg){
	my $br = new TDS::Tdf::Command::BR;
	$self->top->{'pos'}->PushContent($br);
    }
#    return $kind;
}
################################################################

=head2 $p->start($cmd_name, $content, $opt_char, $line, $opt);

start command:
create new node, and construct tree

$cmd_name  command name
$content   body content
$opt_char  option charactor such as +, * 
$line      original line
$opt       ???

=cut

sub start($$$;$$)
{
    my ($self, $cmd_name, $cont, $opt_char, $line, $opt) = @_;
    
    my $cmd;
#    my $cmd_name = $vars[0];
#    print "$cmd_name, ";
    my $class = "TDS::Tdf::Command::$cmd_name";
#    print "$class, $opt->{link}<br>" if $opt->{link};

#    eval("\$cmd = new $class;");
#    eval { $cmd = new $class; };
    unless ( $TDS::Tdf::Command::IsCommand{$cmd_name}){
	if ($WarnReserved){
	    # using WARNING command
	    my $warning = new TDS::Tdf::Command::WARNING;
	    $warning->PushContent("Warning:'$cmd_name' is reserved.");
	    $self->top->{'pos'}->PushContent($warning);
	    $self->text("$cmd_name $cont\n");
	} else {
	    $self->text("$cmd_name $cont\n");
	}
	return;
    }
    $cmd = new $class;
#    print "line: $line";
    $cmd->{line} = $line;
    my $pos = $self->top->{'pos'} || $self->top;

    # set attributes and element to new Command
    {
	my $n_attr = $cmd->{num_attr};
	$cmd->EscapeEntity(\$cont);
	my @vars = split(/ /, $cont, -1);    # last space is also considered
	
	# in CMD* href ... 
	if (ref $opt && $opt->{'link'}){
	    $opt->{href} = shift(@vars);     # shift attribute array
	}
	# in CMD# anchor
	if (ref $opt && $opt->{'anchor'}){
	    $opt->{anchor} = shift(@vars);
	}
	# set to attr
	$cmd->{attr} = [$cmd_name, @vars[0..$n_attr-1]];
	
	if (ref $opt && $opt->{'as_multiline'}){   # IsOneline -> CMD+
	    $cmd->{is_oneline} = 0;
	    $cmd->{omittable_end} = 0;
	    $cmd->{has_arg_content} = 0;
	    $cmd->{ext_attrs} = join(' ', @vars);
	} else {
	    if ($cmd->{has_arg_content}){
		# set arguments to  $cmd->content
		push(@{$cmd->{content}}, join(' ', @vars[$n_attr..$#vars]));
	    } else {
		# set to extend attributes
		$cmd->{ext_attrs} = join(' ', @vars[$n_attr..$#vars]);
	    }
	}
	$cmd->{opt} = $opt;
    }

    # check structure
    my $pos_name = $pos->Name;
    my $allowed = "TDS::Tdf::Command::${pos_name}::Allowed";
    
    # auto paragraph completation
    my $cmd_type = "TDS::Tdf::Command::${cmd_name}::Type";
#    print "\n$pos_name:";
#    print %$allowed;
    if ($$cmd_type eq 'inline' &&
	!$$allowed{'Inline'} # $$pos_type ne 'block'
	){
#	print "$pos_name - $cmd_name, ";
#	print "P inserted<br>";
#	 $pos->InsertCommand("P");
	$pos = $self->top->InsertCommand("P");
	# pos is changed
	$self->top->{'pos'} = $pos;
	$pos_name = $pos->Name;
	$allowed = "TDS::Tdf::Command::P::Allowed";
    }

#    if (!$pos->allowed($cmd_name)){
#    print "$cmd_name\n"
    ;
    # end tag completation
    unless ($$allowed{$cmd_name}){
#	print "not allowed($cmd_name in $pos_name)<br>\n";
	if ($pos_name ne $cmd_name && !$pos->{omittable_end}){
#	    print "!!! Warning !!!\n";
	    my $warning = new TDS::Tdf::Command::WARNING;
	    $warning->PushContent("Not Allowed $cmd_name in $pos_name. ");
	    $pos->PushContent($warning);
	    $pos = $self->end($cmd_name);
	} else {
	    # complete end command automatically if omittable
	    $pos = $self->end($cmd_name) if $pos->{'omittable_end'};
#	    $pos = $self->end($pos_name);
	}
    }
    $self->top->InsertCommand($cmd, $opt);

    if ($cmd->{is_oneline}){ # ||    # oneline 
	$self->end($cmd->Name);
    }
}
################################################################

=head2 $p->end($cmd_name);

end command:
move current position

=cut

sub end ($$)
{
    my ($self, $cmd_name) = @_;

#    print "/$cmd_name\n";
    my $pos = $self->top->{'pos'} || $self->top;

    $cmd_name =~ s/SNEW/NEW/;
    $cmd_name =~ s/SSUB/SUB/;
    
    while (defined $pos){
	my $pos_name = $pos->Name;
	$pos_name =~ s/SNEW/NEW/;
	$pos_name =~ s/SSUB/SUB/;
	last if $pos_name eq $cmd_name;
#	print "end: $pos_name, $cmd_name<br>";
	$pos =  $pos->{parent};
    }
#    print "end:";
    $self->top->{'pos'} =
	(ref $pos) ?
	    $pos->{parent} :
		$self->top->{'pos'}->{parent};
#    print "/$cmd_name pos:", $self->top->pos->Name, "<br>\n";
#    $pos;
#    return $self->top->pos;
}
################################################################

=head2 $p->text($text);

text line
set to current position

=cut

sub text($$)
{
    my ($self, $text) = @_;
    my $pos = $self->top->{'pos'} || $self->top;
#    print $pos->Type, "-$text<br>\n";
    
    # auto paragraph completation
    my $class = ref $pos;
    my $type = "${class}::Type";
    my $allowed = "${class}::Allowed";
    if (/^$/){                    # in null line -> add P
	if ($pos->Name eq 'P'){
	    $pos = $self->end($pos->Name);
	} elsif ($AutoListing &&
		 $self->in_autolist && $pos->Name =~ /^[OU]L$/){
	    $pos = $self->end($pos->Name);
	    $self->in_autolist(0);
	}
#    } elsif ($$type ne "block" && !$pos->opt->{as_multiline}){
    } elsif (!$self->noparse && $text =~ /^\#\#/){  # /^\##/ do NOT anything
	return undef;
    } elsif (!$self->noparse && $text =~ /^\#(.*)/){   # comment line
	my $comment = new TDS::Tdf::Command::COMMENT;
	$comment->PushContent($1);
	$pos->PushContent($comment->AsHTML);
	return;
    } elsif (!$$allowed{'Inline'}){ #  && !$pos->opt->{as_multiline}){	
	$pos = $self->top->InsertCommand("P");
    }

    # http://, ftp:// auto linking
    if ($AutoHttpLink){
	if ($text =~ m!^(http|ftp)(://[^\s]+)(\s.*)$!){
#	if ($text =~ m!^(http://[^\s]+)(\s.*)$! ||
#	    $text =~ m!^(ftp://[^\s]+)(\s.*)$!){
	    my $link = new TDS::Tdf::Command::LINK;
	    $link->{attr}->[1] = "$1$2";
	    push(@{$link->{content}}, "$1$2");
	    $self->top->{'pos'}->PushContent($link);
	    $text = $3;
	} elsif ($text =~ m!^([\w]+@[\w\.]+)(\s.*)$!){
	    my $mailto = new TDS::Tdf::Command::MAILTO;
	    $mailto->{attr}->[1] = $1;
	    push(@{$mailto->{content}}, $1);
	    $self->top->{'pos'}->PushContent($mailto);
	    $text = $2;
	}
    }
    
    $pos->EscapeEntity(\$text);
#    print STDERR $pos->Name, ", ";
    $pos->PushContent($text);
    $self->top->{'pos'} = $pos;
}
    
1;
