package Web::Skeleton;

use strict;
use warnings;

use XML::LibXSLT;
use XML::LibXML;

#use ACIS::Web::Config;
#use ACIS::Web::Session;

use Web::Common;

use CGI;
use CGI::Untaint;

use Carp qw( verbose );
use CGI::Carp qw(fatalsToBrowser set_message);

use utf8;

BEGIN
 {
  set_message (\&Web::Common::critical_message);
 }; 

use Data::Dumper;

use sql_helper;

use ACIS::Data::DumpXML qw(dump_xml);

use Storable;

sub new
 {
  my $class   = shift;
  my $params  = {@_};
  
  #- Анализирует входящий запрос, производит общую абстрактную
  # обработку запроса
  
#  $home = $ACIS::LocalConfig::local_path
#   unless (defined $home);
  
  debug "creating Web::Skeleton object in $home";
  
  my $self    =
   {
    'home'           => $params -> {'home'},
  
    'config-file'    => $params -> {'config'} || '.config',
    'screen-file'    => $params -> {'screen-config'} || 'screens.xml',
  
    'config-module'  => $params -> {'config-module'}  || 'Web::Skeleton::Config',
    'session-module' => $params -> {'session-module'} || 'Web::Skeleton::Session',
   };
  
  bless $self, $class;
  
  debug 'loading configuration';
  
  $self -> config;
  
  debug "fetch request data";
  
  my $query = new CGI;
  
  my $base_url = $self -> {'config'} -> {'base-url'};
  
  my $unescaped_url = $ENV{REQUEST_URI};
  $unescaped_url =~ s/%(\w\w)/chr(hex($1))/eg;
  
  my $requested_url =
   "http://$ENV{HTTP_HOST}$unescaped_url";
   
  my ($acis_request) = ($requested_url =~ /^$base_url\/?(.*?)(?=\?|\/?$)/);
  
  $acis_request = ''
   unless defined $acis_request;
  
  debug "processing url: $requested_url, base url: $base_url, difference: $acis_request";
  
  my ($screen_name, $session_id) = split '!', $acis_request;
  
  $self -> {'variables'} =
   {
    'admin-email' => $self -> {'config'} -> {'admin-email'},
    'site-name'   => $self -> {'config'} -> {'site-name'},
    'base-url'    => $base_url,
    'debug'       => $ACIS::DEBUG,
    'form-data'   => {},
    'errors'      => [],
    'form-errors' =>
     {
      'required-absent' => [],
      'invalid-values'  => [],
     },
   };

  my $template_set = $self -> {'config'} -> {'template-set'};
  my $shared = $self -> {'config'} -> {'static-base-dir'};
  my $static = $self -> {'config'} -> {'static-base-url'};
  
  my $paths =
   {
    'home'        => $home,
    'shared'      => $shared,
    'static'      => $static,
    'presenters'  => "$home/presentation/$template_set",
   };
  
  if( defined $session_id )
   {
    $paths -> {'session'}     = "$home/sessions/$session_id";
    $paths -> {'unconfirmed'} = "$home/unconfirmed/$session_id.xml";
   }

  $self -> {'paths'} = $paths;

  $self -> {'request'} =
   {
    'CGI'        => $query,
    'params'     => scalar $query -> param,
    'screen'     => $screen_name,
    'session-id' => $session_id,
   };
  
  $self -> session;
  
  debug "processing request screen: $screen_name"
   if defined $screen_name;
  
  debug "proceed with session: $session_id"
   if defined $session_id;
  
  return $self;
 }


##############################################################
### некоторое количество функций немного облегчающих жизнь ###
##############################################################

sub config
 {
  my $self = shift;
  
  return $self -> {'config'}
      if $self -> {'config'};
  
  my $module = $self -> {'config-module'};
  my $module_path = $module;
  $module_path =~ s|::|\/|g;
  
  my $home = $self -> {'home'};
  my $config_file = $home . '/' . $self -> {'config-file'};
  my $screen_file = $home . '/' . $self -> {'screen-file'};
  
  my $config_object;
  
  my $bin_config_file = $config_file . '.binary';
  
  debug "compare timestamps of the config file '$config_file', its binary dump '$bin_config_file' and module '$module'";

  my $configuration_package_file = $INC {$module_path};
  
  my $package_change = -M $configuration_package_file;
  my $config_change  = -M $config_file;
  my $screen_change  = -M $screen_file;
  my $binary_change  = -M $bin_config_file
   if -f $bin_config_file;
  
  my $last_modified = $config_change;
  my $action = 'parse';
  
  if ($package_change < $config_change)
   {
    debug "module are newer than configuration";
    $last_modified = $package_change;
    $action = 'parse';
   }
  
  if ($screen_change < $last_modified)
   {
    debug "screen configuration changes are newer than configuration";
    $last_modified = $screen_change;
    $action = 'parse';
   }
  
  if ( (-f $bin_config_file) and ($binary_change < $last_modified) )
   {
    debug "configuration binary newer than new";
    $action = 'restore';
   }
  
  if ($action eq 'parse')
   {
    debug 'parsing configuration';
    
    $config_object = $module -> retrieve ($home, $config_file, $screen_file)
     || critical "$module did not work";

    store ( $config_object, $bin_config_file )
     or log_error ( "cannot write binary config to '$bin_config_file'" );
   }
  elsif ($action eq 'restore')
   {
    debug "loading configuration binary" ;
    $config_object = retrieve ( $bin_config_file );
   }
  
  critical 'something wrong in configuration'
   unless defined $config_object and $config_object;
  
  $self -> {'config'} = $config_object;
  
  foreach my $module (@{$config_object -> {'modules'}})
   {
    debug "try using $module";
    eval "use $module;";
    critical $@ if $@;
   }
  
  return $self -> {'config'};
 }

sub error
 {
  my $self = shift;
  my $error = shift;
  
  unless (defined $error)
   { return $self -> {'error'}; }
  
  $self -> {'error'} = $error;
 }

sub session
 {
  my $self = shift;
  
  return $self -> {'session'};
 }

sub paths
 {
  my $self = shift;
  return $self -> {'paths'};
 }

sub request
 {
  my $self = shift;
  return $self -> {'request'};
 }

sub variables
 {
  my $self = shift;
  return $self -> {'variables'};
 }
 
sub sql_object
 {
  my $self = shift;
  
  return $self -> {'sql-object'}
   if defined $self -> {'sql-object'};

  sql_helper -> set_log_filename ( $self ->{home} . '/sql.log' );

  my $config = $self -> config;

  $self -> {'sql-object'} = sql_helper ->
   new( $config -> {'db-name'}, $config -> {'db-user'}, $config -> {'db-pass'} )
    or return undef;
  
  return $self -> {'sql-object'};
 }

sub handle_request
 {
  my $self = shift;
  
  #- используя конфигурацию, находит соответствующий список
  #  обработчиков.
  
  my $config = $self -> {'config'};
  
  my $screen_name = $self -> request -> {'screen'};
  
  $screen_name = 'index'
   unless ($screen_name);
  
  unless (defined $self -> config -> screen ($screen_name))
   {
    $screen_name = 'index';
    push @{$self -> variables -> {'errors'}}, 'screen-not-found';
   }
  
  $self -> variables -> {'screen-name'} = $screen_name;
  
  $self -> add_to_process_queue ($screen_name);
  $self -> set_presenter ($screen_name);
  
  #- передает управление первому обработчику из списка обработчиков для этого
  
  while (my $processor = $self -> next_processor)
   {
    debug "launch '$processor'";
    
    no strict;
    &$processor ($self);
   }
  
  debug "processors finished";
  
  if (defined $self -> session and scalar keys %{$self -> session})
   {
    $self -> session -> save ($self -> request -> {'session-id'});
    debug "session saved";
   }

  my $location = $self->{'redirect-to'};
  
  if ($location)
   {
    $ACIS::DEBUGIMMEDIATELY
                 ? print "Location: <a href='$location'>$location</a>\n\n" 
                 : print "Location: $location\n\n";
    return;
   }
  
  my $base_url = $self -> {'config'} -> {'base-url'};
  my $action   = "$base_url/$screen_name";
  my $session  = $self -> {'request'} -> {'session-id'};
  if ($session)
   {
    $action .= "!$session";
   }
  
  $self -> variables -> {'form-action'} = $action;
  
  $self -> variables -> {'session'} = $session;
  
  my $vars_xml_dumped = dump_xml ($self -> variables);
  
  my $content = launch_presenter
   ($self -> {'presenter'} -> {'type'},
    $vars_xml_dumped,
    $self -> {'presenter'} -> {'file'});
    
  debug "content: \n$vars_xml_dumped\n";
  
  print '</pre>'
   if $ACIS::DEBUGIMMEDIATELY;
  
  my $encoding = $self -> config -> {'encoding'};
  
  $encoding = 'utf-8'
   unless ( defined $encoding and $encoding );
  
  print "Content-Type: text/html; charset=$encoding\n\n";
  print $content;
  
 }

sub add_to_process_queue
 {
  my $self = shift;
  my $screen = shift;

  debug "add '$screen' screen to processor queue";

  my $processors;
  
  if ($self -> request -> {'params'})
   {
    $processors = $self -> config -> screen ($screen) -> {'process-calls'};
   }
  else
   {
    $processors = $self -> config -> screen ($screen) -> {'init-calls'};
   }

  push @{$self -> {'processors'}}, @$processors;

 }

sub set_presenter
 {
  my $self = shift;
  my $screen = shift;
  
  $self -> {'presenter'} =
   $self -> config -> screen ($screen) -> {'presentation'};
   
 }
 
sub clear_process_queue
 {
  my $self = shift;
  
  debug 'requested for clearing processor queue, processed';
  
  $self -> {'processors'} = [];
 }
 
sub next_processor
 {
  my $self = shift;
  
  return shift @{ $self -> {'processors'} };
 }

sub redirect_to_screen
 {
  my $self   = shift;
  my $screen = shift;
  
  my $base_url = $self -> {'config'} -> {'base-url'};
  $base_url = "http://$base_url"
   unless $base_url =~ /^\/|^http:\/\//;
   
  my $session_id =
   $self -> request -> {'session-id'};
   
  $self -> {'redirect-to'} = "$base_url/$screen!$session_id";
 }

sub redirect
 {
  my $self = shift;
  my $url  = shift;
  
  $self -> {'redirect-to'} = "$url";
 }

sub launch_presenter
 {
  my $type = shift;
  my $data = shift;
  my $file = shift;
  
  my $result;
  
  my $error;
  my $msg = '';
  
  debug "applying stylesheet when needed and generate page content";
  
  unless (-f $file)
   {
    debug "we can't load file stylesheet '$file'";
    $error = 'found';
   }
  
  if ($type eq 'xslt' and not $error)
   {
    my $parser = new XML::LibXML;
    my $xslt   = new XML::LibXSLT;

    $parser -> expand_entities (0);
    $parser -> load_ext_dtd (0);
    
    my $binary_xslt = $file . '.binary';
    
    my $stylesheet;
    eval 
     {
      my $style_doc = $parser -> parse_file ($file);
      $stylesheet   = $xslt  -> parse_stylesheet($style_doc);
     };
    
    if ($@ or not defined $stylesheet )
     {
      $error = 'parse';
      $msg = "<b>error text:</b>$@\n<br><pre><tt>$data</tt></pre>\n<br>";
      die $@;
     } 
    
    eval 
     {
      my $source = $parser -> parse_string ($data);
      my $results = $stylesheet -> transform($source);
      $result = $stylesheet -> output_string($results);
     };
    
    if ($@)
     {
      $error = 'transform';
      $msg = "<b>error text:</b>$@\n<br><pre><tt>$data</tt></pre>\n<br>";
      die $@;
     }
   }
  elsif ($type eq 'static' and not $error)
   {
    open HTML_FILE, $file;
    local $/ = undef;
    $result = <HTML_FILE>;
    close HTML_FILE;
   }

  if ($error)
   {
    $result = qq[
    <html>
     <head><title>stylesheet error</title></head>
     <body>
      <h2>stylesheet parse error</h2>

      <p>we cannot $error stylesheet '$file'.</p>

      <p>$msg</p>

     </body>
    </html>];
   }
  return $result;
 }

 
1;

__END__

=head1 NAME

ACIS::Web

=head1 SYNOPSIS

 use ACIS::Web;
 my $acis = new ACIS::Web ('t/acis-home');
 
 $xml = dump_xml(@list)

=head1 DESCRIPTION

основной модуль для работы с веб-интерфейсом ACIS.

=head2 Configuration variables

задрало все

The generated XML is influenced by a set of configuration variables.
If you modify them, then it is a good idea to localize the effect. E.g.:

  sub my_dump_xml {
      local $Data::DumpXML::INDENT = "";
      local $Data::DumpXML::XML_DECL = 0;
      local $Data::DumpXML::DTD_LOCATION = "";
      local $Data::DumpXML::NS_PREFIX = "dumpxml";

      return dump_xml(@_);
  }

This variables are used from originally written Data::DumpXML:

=over

=item $Data::DumpXML::INDENT

You can set the variable $Data::DumpXML::INDENT to control the amount
of indenting.  The variable contains the whitespace you want to be
used for each level of indenting.  The default is a single space.  To
suppress indenting set it as "".

=item $Data::DumpXML::INDENT_STYLE

This variable controls where end element are placed.  If you set this
variable to the value "Lisp" then end tags are not prefixed by NL.
This give a more compact output.

=item $Data::DumpXML::XML_DECL

This boolean variable controls whether an XML declaration should be
prefixed to the output.  The XML declaration is the <?xml ...?>
thingy.  The default is 1.  Set this value to 0 to suppress the
declaration.

=item $Data::DumpXML::NAMESPACE

This variable contains the namespace used for the the XML elements.
The default is to let this be a URI that actually resolve to the XML
Schema on CPAN.  Set it to "" to disable use of namespaces.

=item $Data::DumpXML::NS_PREFIX

This variable contains the namespace prefix to use on the elements.
The default is "" which means that a default namespace will be declared.

=item $Data::DumpXML::SCHEMA_LOCATION

This variable contains the location of the XML Schema.  If this
variable is non-empty, then an C<xsi:schemaLocation> attribute will be
added the top level C<data> element.  The default is to not include
this as the location can be guessed from the default XML namespace
used.

=item $Data::DumpXML::DTD_LOCATION

This variable contains the location of the DTD.  If this variable is
non-empty, then a <!DOCTYPE ...> will be included in the output.  The
default is to point to the DTD on CPAN.  Set it to "" to suppress the
<!DOCTYPE ...> line.

=back

переменные, содержащие названия имен элементов генерируемого XML.

=over

=item $Data::DumpXML::ROOT_NAME

определяет название элемента root XML документа. по умолчанию
устанавливается в 'data'

=item $Data::DumpXML::ARRAY_ELEMENT

определяет название элемента XML документа, содержащего элемент
массива perl. по умолчанию устанавливается в 'list-item'

=item $Data::DumpXML::HASH_ELEMENT

определяет название элемента XML документа, содержащего элемент
хэша perl. по умолчанию устанавливается в 'hash-item'

=item $Data::DumpXML::REFERENCE

определяет название элемента XML документа, содержащего ссылку
на структуру perl. по умолчанию устанавливается в 'reference'

=back

=head1 DIFFERENCE

различие между output Data::DumpXML и ACIS::Data::DumpXML
заключается в том, что ACIS::Data::DumpXML генерирует упрощенные
структуры perl.

пример:

  $a = bless [1,2], "Foo";
  dump_xml($a);

у нас имеется в переменной $a ссылка на blessed "Foo" массив,
содержащий два элемента.

ACIS::Data::DumpXML

  <?xml version="1.0" encoding="UTF-8"?>
  <data class="Foo">
   <list-item>1</list-item>
   <list-item>2</list-item>
  </data>

Data::DumpXML  
  
  <?xml version="1.0" encoding="US-ASCII"?>
  <data xmlns="http://www.cpan.org/.../Data-DumpXML.xsd">
   <ref>
    <array class="Foo">
     <str>1</str>
     <str>2</str>
    </array>
   </ref>
  </data>

в модуле ACIS::Data::DumpXML принимаются некие допущения, как то:
для perl необязательно указывать ссылку, то есть структуру

$a -> {b} -> {c} -> {d} ...

можно записать как

$a -> {b}{c}{d} ...

такие же допущения принимаются и в генерируемом XML, только
применяются они еще и с учетом специфики XML:

так как root-level элемент может быть только один, то объект,
который передается dumper, становится либо ссылкой на структуру
данных perl, либо scalar.

элемент, содержащий вложенные элементы типа 'list-item' или 'hash-item',
трактуются как массив и хэш соответственно.

если между открывающим и закрывающим тегом не содержится никаких
символов (<list-item></list-item> или <list-item />), то значение
трактуется как пустая строка.

пустой массив и хэш экспортируются в виде <empty-array /> и
<empty-hash />; неопределенные значения в <undef />

=head1 BUGS

Class names with 8-bit characters will be dumped as Latin-1, but
converted to UTF-8 when restored by the Data::DumpXML::Parser.

The content of globs and subroutines are not dumped.  They are
restored as the strings; "** glob **" and "** code **".

LVALUE and IO objects are not dumped at all.  They will simply
disappear from the restored data structure.

=head1 SEE ALSO

L<ACIS::Data::DumpXML::Parser>, L<XML::Parser>, L<XML::Dumper>, L<Data::Dump>

=head1 AUTHORS

The C<ACIS::Data::DumpXML> module is written by Ivan Baktcheev
<arglebarle@tut.by>, based on C<Data::DumpXML>.

The C<Data::DumpXML> module is written by Gisle Aas <gisle@aas.no>,
based on C<Data::Dump>.

The C<Data::Dump> module was written by Gisle Aas, based on
C<Data::Dumper> by Gurusamy Sarathy <gsar@umich.edu>.

 Copyright 2003 Ivan Baktcheev.
 Copyright 1998-2003 Gisle Aas.
 Copyright 1996-1998 Gurusamy Sarathy.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
