package PSP::Compiler;

# Copyright (c) 2000, FundsXpress Financial Network, Inc.
# This library is free software released under the GNU Lesser General
# Public License, Version 2.1.  Please read the important licensing and
# disclaimer information included below.

# $Id: Compiler.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;
$PSP::Compiler::VERSION = '0.504';

=head1 NAME

PSP::Compiler - Compiler to construct what parser parses.

=head1 SYNOPSIS

=head1 DESCRIPTION

=cut

use Config;
use Symbol;
use File::Find;
use PSP::Utils qw(dump_object);
use PSP::Parser;
use PSP::Parser::FieldSpace qw(process_fieldspace);
use PSP::Parser::Group qw(process_groups);

=head1 METHODS

=head2 new

=cut

sub new {
  my ($proto,%opt) = @_;

  my $this = { %opt };
  bless $this, ref($proto)||$proto;
  $this->{inputs} or die "compile() requires inputs.\n";

  $this->{n_errors}    = 0;
  $this->{depends}     = [];
  $this->{depends_h}   = {};
  $this->{fieldspaces} = {};
  $this->{submit_ids}  = [];

  return $this;
}

use vars qw($cached_compiler);
sub compile {
  my ($proto,%opt) = @_;

  # this is both an instance and a class method.
  my $this = ref $proto ? $proto : ($cached_compiler || $proto->new(%opt));
  $cached_compiler = $this;

  # determine the input files.
  my @inputs = @{$this->{inputs}};

  # determine if we have an input directory relocation.
  my $input_dir;
  if (@inputs == 1 and -d $inputs[0]) {
    $this->{input_dir} = $input_dir = $inputs[0]
  }
  undef $input_dir if defined $input_dir and $input_dir eq ".";

  # determine the input source files from the inputs.
  my @src_files = $this->find_sources(@inputs);
  @src_files or warn "no sources found.\n";

  # get the seed
  my $seed = $this->get_seed();

  # open and initialize the output file.
  my $out_fh = $this->open_output() unless $this->{makedepend};
  my $n_pages = 0;

  # iterate through the sources.
  my $n = 1;
  for my $src_file (@src_files) {
    $this->{verbose} and print $n++.": Compiling $src_file...\n";

    #print "$src_file =~ s!^($input_dir/?)?!$input_dir/! if $input_dir;\n";
    $src_file =~ s!^($input_dir/?)?!$input_dir/! if $input_dir;

    # create a new parser object, and initialize its state.
    my $parser = PSP::FullParser->new();
    my @prev_propagated = $parser->propagate_state_from($this);

    # parse the input source file.
    my ($ret,$err) = $parser->parse_file($src_file);
    if (!$ret) {
      $this->{n_errors}++;
      $err ||= "$src_file: too many errors";
      warn $err."\n";
      next;
    }

    # do not create an (empty) page sub for a fieldspace
    if ($src_file !~ /.fs$/i) {
      my $top_of_output = $this->top_of_output() unless $n_pages++;
      if ($out_fh) {
        print {$out_fh} $top_of_output if $top_of_output;
        print {$out_fh} $this->process_src_file($parser);
      }
    }

    # transfer the state of the parser back into the compiler.
    PSP::Parser::propagate_state_from($this,$parser,@prev_propagated);

    # Check the stacks for unbalanced tags.
    $this->{n_errors} += $parser->check_integrity();

  }#for (@src_files)

  # process each of the fieldspaces found in all files.
  if ($out_fh) {
    if ($n_pages) {
      print {$out_fh} $this->process_submit_ids();
    }
    for my $fsname (sort keys(%{$this->{fieldspaces}})) {
      my $fieldspace = $this->{fieldspaces}->{$fsname};
      $this->{verbose} and print "Generating '$fsname' fieldspace class\n";
      my $buf = (process_fieldspace($fieldspace).
		 process_groups($fieldspace));
      #MIC3 compatibility hacks.
      $buf =~ s/\bcall_me\b/alias/gc;
      $buf =~ s/\$fs->changed_p\([^\)]+?\(\)[^\)]*\)/\$field->changed_p()/gc;
      print {$out_fh} $buf;
    }
    print {$out_fh} "1;\n";
  } else {
    print "$this->{output}: ".join(" ",@{$this->{depends}})."\n";
  }

  $this->close_output($out_fh) unless $this->{makedepend};

  $this->{debug} and print dump_object($this);

  return $this->{n_errors};
}

sub process_submit_ids {
  my ($this) = @_;

  my $submit_text = join("\n", map { "\t".$_ } @{$this->{submit_ids}}) || "";
  if ($submit_text) {
    $submit_text = " qw(\n$submit_text)";
  } else {
    $submit_text = " qw()";
  }

  my $out = join("\n",
	(("#" x 78),
	 'use vars qw(@submit_ids);',
	 "\@submit_ids =$submit_text;",
	 'sub submit_ids {',
	 '  return @submit_ids;',
	 '}',
	))."\n\n";

  $out;
}

sub perlcheck_output {
  my ($this,$fname) = @_;
  $fname ||= $this->{output};

  my $cmd = "$Config{perlpath} -c";
  $this->{perlcheck_args} and $cmd .= " ".$this->{perlcheck_args};
  $cmd .= " ".$fname;

  $this->{verbose} and print "checking with '$cmd'...\n";

  system($cmd);

  return $?>>8;
}

sub open_output {
  my ($this,$fname) = @_;
  $fname ||= $this->{output};

  my $out_fh = gensym();
  -f $fname and rename $fname, "$fname~";
  open $out_fh, ">$fname#" or die "open: $fname#: $!\n";

  my $localtime = localtime();

  print $out_fh <<"EOS";
# Warning: this file was automatically generated.  You may lose your changes.
# Compiled on: $localtime
# $0 @main::ARGV

EOS

  return $out_fh;
}

sub close_output {
  my ($this,$out_fh) = @_;
  my $fname = $this->{output};

  $out_fh or return;
  close $out_fh;

  $this->{check} and !$this->{n_errors} and
    $this->{n_errors} = $this->perlcheck_output($this->{output}."#");

  if (!$this->{n_errors}) {
    rename "$fname#", $fname or die "rename $fname# -> $fname: $!\n";
  }
}

sub top_of_output {
  my ($this) = @_;

  my $localtime = localtime();
  my $out = "";

  my ($class,$isa);
  if (my $pile_name = $this->{pile_name}) {
    $class = "Pile::".$pile_name;
    $isa = "PSP::Pile";
  } elsif (my $page_name = $this->{page_name}) {
    $class = "Page::".$page_name;
    $isa = "PSP::Page";
  } else {
    die "There is neither a pile nor page associated with output file.\n";
  }

  $out = join("\n",
	("package $class;",
	 "",
	 "use strict;",
	 "use $isa;",
	 "use HTMLIO::Utils;",
	 "BEGIN { \@${class}::ISA = qw($isa); }",
	 "use PSP::Output;",
	 ))."\n\n";

  # include control.pl if present.
  my %fnames;
  for my $input (@{$this->{inputs}},@{$this->{includepath}}) {
    next unless -d $input;
    my $fname = "$input/control.pl";
    next if $fnames{$fname}++;
    if (-f $fname) {
      local $/ = undef;
      my $ctl_fh = gensym();
      open $ctl_fh, $fname;
      $out .= "### begin $fname\n";
      $out .= <$ctl_fh>;
      $out .= "### end $fname\n\n";
      close $ctl_fh;
      $this->{depends} and push @{$this->{depends}}, $fname;
      $this->{depends_h}->{$fname}++;
    }
  }

  return $out;
}

sub process_src_file {
  my ($this,$parser) = @_;

  my $page_name = $parser->page_name();
  $this->{verbose} and print " Generating $page_name()\n";

  my $out = "";

  $out .= ("#" x 78)."\n";
  #print any declaration code.
  if (my $decl = $parser->pop_decl()) {
    $out .= $decl."\n\n";
  }

  my $page_code = $parser->page_code();
  my $page_method;
  if ($parser->pile_name()) {
    $page_method = $page_name;
    #this is a MIC compatibility hack.
    $page_code =~ s{
		     return_page\(\s*\$cgi\s*,\*(\'\")(.+?)\1\s*\)
		   }{
		     \$pile->goto_page('$2')
		   }xg;
  } else {
    $page_method = "page";
  }
  #this is a MIC compatibility hack.
  $page_code =~ s/\boutput\(/\$out->put(/g;

  #print the page that we just parsed
  $out .= join("\n",
	("sub $page_method {",
	 '  my ($page) = @_;',
	 '  my $pile = $page;',
	 '  (my $page_name = (caller(0))[3]) =~ s/.*::page__//;',
	 '  my $cgi = $page->cgi();',
	 '  my $out = PSP::Output->new();',
	 '  my ($fs,$error_obj,$_field,$_no_prop);',
	 '',
	 $page_code,
	 '',
	 '  return $out->get();',
	 '}'))."\n\n";

  $parser->can("dump_submits") and
    $out .= $parser->dump_submits($this->{submit_ids});

  $parser->can("dump_verifies") and
    $out .= $parser->dump_verifies();

  $out =~ s/\n\s*\n+/\n\n/sg;
  $out =~ s/\s*$/\n/sg;

  return $out;
}

sub find_sources {
  my ($this,@inputs) = @_;

  my @sources;
  my $input_dir = $this->{input_dir};
  for my $input (@inputs) {
    if (-f $input) {
      push @sources, $input;
      next;
    }
    die "$input is neither a directory nor file.\n" unless -d $input;
    $this->{verbose} and print "scanning $input for sources..\n";

    # if there is a .pspignore file, create a list of ignore regex's
    my @ignore_re;
    if (open OUT, "$input/.pspignore") {
      while (<OUT>) {
	s/\s+$//;
	$_ or next;
	s!/!\\/!g;
	s!\.!\\.!;
	push @ignore_re, eval "sub { \$_[0] =~ /^$_\$/o; }";
      }
    }

    # do the find (exclude files matching @ignore_re).
    my @out = ();
    find(sub {
	   my $good = /\.(html|psp|fs)$/i && !/^.\#/;
	   for my $re_sub (@ignore_re) {
	     $good or last;
	     &$re_sub($File::Find::name) and undef $good;
	   }
	   push @out, $File::Find::name if $good;
	 }, $input);
    # remove the input directory from each path.
    #print "before: (@out) - $input_dir;\n";
    grep s/^$input_dir\///, @out;
    #print "after: (@out);\n";

    # sort the targets so that .fs get processed first
    @out = sort { ($b =~ /fs$/i) - ($a =~ /fs$/i) } @out;
    $this->{verbose} and print "found ".@out." sources in $input.\n";
    push @sources, @out;
  }

  return @sources;
}

sub get_seed {
  my ($this) = @_;
  my $seed = $this->{seed};

  # if there is a request to reuse the seed file, attempt to do so
  my $seed_fh = gensym();
  if ($this->{reuseseeds} and $this->{seedfile}) {
    if (! open $seed_fh, $this->{seedfile}) {
      warn("Seed file $this->{seedfile} not found; reverting to ".
	   ($seed ? "passed seed" : "pseudo-random seed").".\n");
    } else {
      chomp($seed = <$seed_fh>);
      close $seed_fh;
    }
  }

  # if the seed is not defined, generate it.
  $seed or $seed = int(rand(900000))*10000 + 100000000;
  #my @l = localtime();
  #$time_seed = sprintf "%d%02d%02d%02d%02d",$l[4]+1,$l[3],$l[2],$l[1],$l[0];

  # write this seed to the file.
  if ($this->{seedfile}) {
   if (! open $seed_fh, ">".$this->{seedfile}) {
    warn "open seed file: $this->{seedfile}\n";
   } else { 
    print $seed_fh "$seed\n";
    close $seed_fh;
   }
  }

  $this->{seed} = $seed;
  return $seed;
}

package PSP::FullParser;

use PSP::Parser;
use PSP::Parser::Control;
use PSP::Parser::Form;
use PSP::Parser::Message;
use PSP::Parser::FieldSpace;
use PSP::Parser::Group;
use PSP::Parser::Error;
use PSP::Parser::Table;

use vars qw(@ISA);
@ISA = qw(PSP::Parser
	  PSP::Parser::Control
	  PSP::Parser::Form
	  PSP::Parser::Message
	  PSP::Parser::FieldSpace
	  PSP::Parser::Group
	  PSP::Parser::Error
	  PSP::Parser::Table);

sub new {
  my ($proto,@args) = @_;

  my $this = $proto->SUPER::new(@args);
  bless $this, ref($proto)||$proto;

  return $this;
}

=head2 pre_parse_file

 instance
 () pre_parse_file (string $path)

DESCRIPTION:

Will then open pre-parse the page.

  #$this->{parent_parser} or $this->pre_parse_file();

=cut

sub pre_parse_file {
  my ($this,$path) = @_;

  my $pre_parser = PSP::PreParser->new();
  $pre_parser->propagate_state_from($this);

  my $ret = $pre_parser->parse_file($path) or throw
    Error::Simple("Error pre-parsing $path.");

  #This is the only thing we propagate back for now.
  $this->{preparsed} = $pre_parser->{preparsed};

  #i don't know what these below are.. but i think they're unnecessary?
  if (0) {
    #are there dynamic displays that we need to set up for?
    if (%{$this->{preparsed}->{dynamic_displays}}) {
      #if there are, we puth the setup code at the top so that the vars
      #will be ready for the request group stuff and rollbacks, etc.,
      #that are not after the dynamicdisplay tag
      $this->setup_for_dynamic_displays();
    }

    my $change_flag_data = $this->{preparsed}->{change_flag_data};
    for my $var (values %$change_flag_data) {
      $this->{current_page} .= "my $var;\n";
    }
  }

  return $ret;
}

package PSP::PreParser;

use PSP::Parser;
use PSP::Parser::PreScan;

use vars qw(@ISA);
@ISA = qw(PSP::Parser
	  PSP::Parser::PreScan);

sub new {
  my ($proto,@args) = @_;

  my $this = $proto->SUPER::new(@args);
  bless $this, ref($proto)||$proto;

  return $this;
}

1;
__END__

=head1 BUGS

No known bugs, but this does not mean no bugs exist.

=head1 SEE ALSO

L<HTML::Parser>, 

=head1 COPYRIGHT

 PSP - Perl Server Pages
 Copyright (c) 2000, FundsXpress Financial Network, Inc.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2 of the License, or (at your option) any later version.

 BECAUSE THIS LIBRARY IS LICENSED FREE OF CHARGE, THIS LIBRARY IS
 BEING PROVIDED "AS IS WITH ALL FAULTS," WITHOUT ANY WARRANTIES
 OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, WITHOUT
 LIMITATION, ANY IMPLIED WARRANTIES OF TITLE, NONINFRINGEMENT,
 MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, AND THE
 ENTIRE RISK AS TO SATISFACTORY QUALITY, PERFORMANCE, ACCURACY,
 AND EFFORT IS WITH THE YOU.  See the GNU Lesser General Public
 License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

=cut