PApp - multi-page-state-preserving web applications

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

#if (!defined $PApp::_compiled) { eval do { local $/; <DATA> }; die if $@ } 1;
#__DATA__

##line 4 "(PApp.pm)"

##########################################################################
## All portions of this code are copyright (c) 2003,2004 nethype GmbH   ##
##########################################################################
## Using, reading, modifying or copying this code requires a LICENSE    ##
## from nethype GmbH, Franz-Werfel-Str. 11, 74078 Heilbronn,            ##
## Germany. If you happen to have questions, feel free to contact us at ##
## license@nethype.de.                                                  ##
##########################################################################

package PApp;

use 5.006;

use utf8;
no bytes;

use common::sense;

#   imports
use Carp;
use FileHandle ();
use File::Basename qw(dirname);

use PApp::Storable;
use Compress::LZF qw(:compress :freeze);

use Crypt::Twofish2;

use PApp::Config qw(DBH $DBH); DBH;
use PApp::FormBuffer;
use PApp::Exception;
use PApp::I18n;
use PApp::HTML qw(escape_uri escape_html tag alink unixtime2http);
use PApp::SQL;
use PApp::Callback;
use PApp::Application;
use PApp::Package;
use PApp::Util;
use PApp::Recode ();
use PApp::Prefs ();
use PApp::Session ();
use PApp::Event ();

<<' */'=~m>>;
 
/*
 * the DataRef (and Callback) modules must be included just in case
 * no application has been loaded and we need to deserialize state,
 * since overloaded packages must already exist before an object becomes
 * overloaded. Ugly.
 */

use PApp::DataRef ();

use Convert::Scalar qw(:utf8 weaken);

BEGIN {
   our $VERSION = 1.45;

   use base Exporter::;

   our @EXPORT = qw(
         debugbox

         surl slink sform cform suburl sublink retlink_p returl retlink
         current_locals reference_url multipart_form parse_multipart_form
         endform redirect internal_redirect abort_to content_type
         abort_with setlocale fixup_marker insert_fixup

         SURL_PUSH SURL_UNSHIFT SURL_POP SURL_SHIFT
         SURL_EXEC SURL_SAVE_PREFS SURL_SET_LOCALE SURL_SUFFIX
         SURL_EXEC_IMMED SURL_START_SESSION

         surl_style postpone
         SURL_STYLE_URL SURL_STYLE_GET SURL_STYLE_STATIC

         $request $NOW *ppkg $papp *state %P *A *S
         $userid $sessionid
         reload_p switch_userid getuid

         dprintf dprint echo capture $request 
         
         N_ language_selector preferences_url preferences_link
         $prefs $curprefs getpref setpref save_prefs
   );
   our @EXPORT_OK = qw(config_eval abort_with_file);

   # might also get loaded in PApp::Util
   require XSLoader;
   XSLoader::load PApp, $VERSION unless defined &PApp::bootstrap;

   our @ISA;
   unshift @ISA, "PApp::Base";
}

sub getuid(); # prototype needed

#   globals
#   due to what I call bugs in mod_perl, my variables do not survive
#   configuration time unless global

use vars qw(
   $translator $configured $cipher_d $libdir $i18ndir $sessionid $prevstateid $alternative
   $cookie_reset $cookie_expires $checkdeps $delayed $content_type $output_charset $surlstyle
   $in_cleanup $onerr $translator $configured $key $statedb $statedb_user $statedb_pass
   $pmod $uid
);

    $translator;

    $configured;

    $key          = $PApp::Config{CIPHERKEY};
our $cipher_e;
    $cipher_d;

    $libdir       = $PApp::Config{LIBDIR};
    $i18ndir      = $PApp::Config{I18NDIR};

our $stateid;     # uncrypted state-id
    $sessionid;
    $prevstateid;
    $alternative;

our $userid;      # uncrypted user-id

our %state;
our %arguments;
our %temporary;
our %S; # points into %state
our %A; # points into %arguments
our %P;

our %papp;        # toplevel ("mounted") applications

our $NOW;         # the current time (so you only need to call "time" once)

# other globals. must be globals since they should be accessible outside
our $output;      # the collected output (must be global)
our $routput = \$output; # the real output, even inside capture {}
our $doutput;     # debugging output
our @fixup;

our $location;    # the current location (a.k.a. application, pathname)
our $pathinfo;    # the "CGI"-pathinfo
our $papp;        # the current location (a.k.a. application)

our $modules;     # the module state
our $module;      # the current module name (single component)
our $curprfx;     # the current state prefix
our $curpath;     # the current application/package path
our $curmod;      # the current module (ref into $modules)#d##FIXME#
our $ppkg;        # the current package (a.k.a. package)
our $curconf;     # the current configuration hash

our $request;     # the apache request object

our %module;      # module path => current module

our @pmod;        # the current stack of pmod's NYI

our $langs;       # contains the current requested languages (e.g. "de, en-GB")

    $cookie_reset   = 86400;       # reset the cookie at most every ... seconds
    $cookie_expires = 86400 * 365; # cookie expiry time (one year, whooo..)

    $checkdeps;   # check dependencies (relatively slow)
    $delayed;     # delay loading of apps until needed

our %preferences; # keys that are preferences are marked here

    $content_type;
    $output_charset;
our $output_p = 0;# flush called already?

    $surlstyle  = 1; # scalar SURL_STYLE_URL;

    $in_cleanup = 0; # are we in a clean-up phase?

    $onerr      = 'sha';
our $warn_log; # all warnings will be logged here

our $url_prefix_nossl = undef;
our $url_prefix_ssl = undef;
our $url_prefix_sslauth = undef;

our $logfile = undef;

our $prefs    = new PApp::Prefs \"";      # the global preferences
our $curprefs = new PApp::Prefs *curprfx; # the current application preferences

our ($st_reload_p, $st_replacepref, $st_deletepref, $st_newuserid, $st_insertstate,
     $_config, $st_newstateids, $st_fetchstate, $st_eventcount, $event_count);

%preferences = (  # system default preferences
   '' => [qw(
      papp_locale
      papp_cookie
   )],
);

# flush translation table caches when they are re-written
PApp::Event::on papp_i18n_flush => sub {
   PApp::I18n::flush_cache;
};

our $papp_main;

our $restart_flag;
if ($restart_flag) {
   die "FATAL ERROR: PerlFreshRestart is buggy\n";
   PApp::Util::_exit(0);
} else {
   $restart_flag = 1;
}

our $save_prefs_cb = create_callback {
   &save_prefs if $userid;
} name => "papp_save_prefs";

our $start_session_cb = create_callback {
   &start_session;
} name => "papp_start_session";

sub SURL_PUSH         ($$){ ( "\x00\x01", undef, @_ ) }
sub SURL_UNSHIFT      ($$){ ( "\x00\x02", undef, @_ ) }
sub SURL_POP          ($) { ( "\x00\x81", @_ ) }
sub SURL_SHIFT        ($) { ( "\x00\x82", @_ ) }
#sub SURL_EXEC         ($) { SURL_PUSH("/papp_execonce" => $_[0]) }
sub SURL_EXEC_IMMED   ($) { "\x00\x91", \$_[0] }
sub SURL_EXEC         ($) { $_[0] }
sub SURL_SAVE_PREFS   ()  { $save_prefs_cb }
sub SURL_SET_LOCALE   ($) { ( SURL_SAVE_PREFS, "/papp_locale" => $_[0] ) }
sub SURL_START_SESSION()  { SURL_EXEC_IMMED ($start_session_cb) }

sub SURL_SUFFIX       ($) { ("\x00\x41", @_) }
sub SURL_STYLE        ($) { ("\x00\x42", @_) }
sub _SURL_STYLE_URL   ()  { 1 }
sub _SURL_STYLE_GET   ()  { 2 }
sub _SURL_STYLE_STATIC()  { 3 }

sub SURL_STYLE_URL    ()  { SURL_STYLE(_SURL_STYLE_URL    ) }
sub SURL_STYLE_GET    ()  { SURL_STYLE(_SURL_STYLE_GET    ) }
sub SURL_STYLE_STATIC ()  { SURL_STYLE(_SURL_STYLE_STATIC ) }

sub CHARSET (){ "utf-8" } # the charset used internally by PApp

# we might be slow, but we are rarely being called ;)
sub __($) {
   $translator
      ? $translator->get_table($langs)->gettext($_[0])
      : $_[0]
}

sub N_($) { $_[0] }

# constant
our $xmlnspapp = "http://www.plan9.de/xmlns/papp";

# undocumented interface. uarg. values %{$event_handler{type}} gives coderefs
our %event_handler;

sub event {
   my $self = shift;
   my $event = shift;
   $_->($event) for values %{$event_handler{$event}};
   for $papp (values %{$papp->{"/"}}) {
      $papp->event($event);
   }
}

sub search_path {
   shift;
   goto &PApp::Config::search_path;
}

sub PApp::Base::configure {
   my $self = shift;
   my %a = @_;
   my $caller = caller;

   $configured = 1;

   exists $a{libdir}		and $libdir	  = $a{libdir};
   exists $a{pappdb}		and $statedb	  = $a{pappdb};
   exists $a{pappdb_user}	and $statedb_user = $a{pappdb_user};
   exists $a{pappdb_pass}	and $statedb_pass = $a{pappdb_pass};

   exists $a{cookie_reset}	and $cookie_reset = $a{cookie_reset};
   exists $a{cookie_expires}	and $cookie_expires = $a{cookie_expires};

   exists $a{cipherkey}		and $key	  = $a{cipherkey};

   exists $a{onerr}		and $onerr	  = $a{onerr};

   exists $a{url_prefix_nossl}	and $url_prefix_nossl   = $a{url_prefix_nossl};
   exists $a{url_prefix_ssl}	and $url_prefix_ssl     = $a{url_prefix_ssl};
   exists $a{url_prefix_sslauth}and $url_prefix_sslauth = $a{url_prefix_sslauth};

   exists $a{checkdeps} 	and $checkdeps	  = $a{checkdeps};
   exists $a{delayed} 		and $delayed	  = $a{delayed};

   exists $a{logfile}		and $logfile	  = $a{logfile};

   my $lang = { lang => 'en', domain => 'papp' };
   
  $papp_main = new PApp::Application::PApp
      path   => "$libdir/apps/papp.papp",
      name   => "papp_main",
      appid  => 0;

   $papp_main->new_package(
      name      => 'papp',
      domain    => 'papp',
   );

   $papp_main->load_config;

   for (
         "$libdir/macro/admin.papp",
         "$libdir/macro/util.papp",
         "$libdir/macro/editform.papp",
         $INC{"PApp.pm"},
         $INC{"PApp/FormBuffer.pm"},
         $INC{"PApp/I18n.pm"},
         $INC{"PApp/Exception.pm"},
       ) {
      $papp_main->register_file($_, domain => "papp", lang => "en");
   };

   $papp{$papp_main->{appid}} = $papp_main;
}

sub PApp::Base::configured {
   # mod_perl does this to us....
   #$configured and warn "PApp::configured called multiple times\n";

   if ($configured == 1) {
      if (!$key) {
         warn "no cipherkey was specified, this is an insecure configuration";
         $key = "c9381ddf6cfe96f1dacea7e7a86887542d6aaa6476cf5bbf895df0d4f298e741";
      }
      my $key = pack "H*", $key;
      $cipher_d = new Crypt::Twofish2 $key;
      $cipher_e = new Crypt::Twofish2 $key;

      PApp::Event::skip_all_events;

      PApp::I18n::set_base($i18ndir);

      $translator = PApp::I18n::open_translator("papp", "en");

      $configured = 2;

      PApp->event('init');
   } elsif ($configured == 0) {
      fancydie "PApp: 'configured' called without preceding 'configure'";
   }
}

# must be called after fork, see PApp::Apache
sub post_fork_cleanup {
   PApp::I18n::flush_cache;
   PApp::SQL::reinitialize;
   undef $PApp::Config::DBH;
   PApp::Config::DBH;
}

sub configured_p {
   $configured;
}

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

sub echo(@) {
   $output .= join "", @_;
}

sub capture(&) {
   local *output;
   &{$_[0]};
   $output;
}

sub dprintf(@) {
   my $format = shift;
   $doutput .= sprintf $format, @_;
}

sub dprint(@) {
   $doutput .= join "", @_;
}

use Guard ();
BEGIN { *guard = \&Guard::guard }

sub content_type($;$) {
   $content_type = shift;
   $output_charset = lc shift if @_;
}

sub setlocale(;$) {
   my $locale = @_ ? $_[0] : $state{papp_locale};
   require POSIX;
   POSIX::setlocale (LC_ALL => $locale);
}

sub reference_url {
   my $url;
   if ($_[0]) {
      $url = "http://" . $request->hostname;
      $url .= ":" . $request->get_server_port if $request->get_server_port != 80;
   }
   my $get = join "&", (map {
               escape_uri($_) . (defined $S{$_} ? "=" . escape_uri $S{$_} : "");
             } grep {
                exists $S{$_}
                   and exists $pmod->{state}{import}{$_}
                   and not exists $pmod->{state}{preferences}{$_}
             } keys %{$pmod->{state}{import}}),
             (map {
                escape_uri($_) . (defined $P{$_} ? "=" . escape_uri $P{$_} : "");
             } grep {
                exists $S{$_}
                   and not exists $pmod->{state}{import}{$_}
             } keys %P);
   "$url$location+$module" . ($get ? "?$get" : "");
}

sub surl_style {
   my $old = $surlstyle;
   $surlstyle = $_[1] || $_[0];
   $old;
}

sub postpone(&;@) {
   my ($cb, @args) = @_;
   my ($db, $dbh) = ($PApp::SQL::Database, $PApp::SQL::DBH);
   push @{$state{papp_execonce}}, sub {
      local $PApp::SQL::Database = $db;
      local $PApp::SQL::DBH      = $dbh;
      $cb->(@args);
   };
}

# complex "link content, secure-args"
sub slink {
   alink shift, &surl;
}

# Return current local variables as key => value pairs.
sub current_locals {
   map { ($_, $S{$_}) }
       grep exists $ppkg->{local}{$_}
            && exists $ppkg->{local}{$_}{$module},
               keys %S;
}

# some kind of subroutine call
sub suburl {
   surl @_, SURL_PUSH(\$state{papp_return}, [
      (\modpath_freeze $modules),
      current_locals,
   ]);
}

# some kind of subroutine call
sub sublink {
   my $content = shift;
   alink $content, suburl @_;
}

# is there a backreference?
sub retlink_p() {
   scalar@{$state{papp_return}};
}

sub returl(;@) {
   surl @{$state{papp_return}[-1]}, @_, SURL_POP(\$state{papp_return});
}

sub retlink {
   alink shift, &returl;
}

sub fixup_marker {
   push @fixup, $_[0];
   (
      (sprintf "\x{fc00}%06d", $#fixup),
      \$fixup[-1],
   );
}

sub insert_fixup {
   my ($marker, $ref) = fixup_marker $_[0];
   $PApp::output .= $marker;
   $ref;
}

sub sform(@) {
   local $surlstyle = _SURL_STYLE_URL;
   tag "form", { ref $_[0] eq "HASH" ? %{+shift} : (), method => 'get', action => &surl };
}

sub cform(@) {
   tag "form", { ref $_[0] eq "HASH" ? %{+shift} : (), method => 'post', action => &surl };
}

sub multipart_form(@) {
   tag "form", { ref $_[0] eq "HASH" ? %{+shift} : (), method => 'post', action => &surl, enctype => "multipart/form-data" };
}

sub endform {
   "</form>";
}

# parse a single mime-header (e.g. form-data; directory="pub"; charset=utf-8)
sub parse_mime_header {
   my $line = $_[0];
   $line =~ /([^ ()<>@,;:\\".[\]=]+)/g; # the tspecials from rfc1521, except /
   my @r = $1;
   no utf8; # devel7 has no polymorphic regexes
   use bytes; # these are octets!
   while ($line =~ /
                        \G\s*;\s*
                        (\w+)=
                        (?:
                          \"( (?:[^\\\015"]+|\\.)* )\"
                          |
                          ([^ ()<>@,;:\\".[\]]+)
                        )
                  /gxs) {
      push @r, lc $1;
      my $value = $2 || $3;
      # we dequote only the three characters that MUST be quoted, since
      # microsoft is obviously unable to correctly implement even mime headers:
      # filename="c:\xxx". *sigh*
      $value =~ s/\\([\015"\\])/$1/g;
      push @r, $value;
   }
   @r;
}

# see PApp::Handler near the end before deciding to call die in
# this function.
sub parse_multipart_form(&) {
   no utf8; # devel7 has no polymorphic regexes
   my $cb  = shift;
   my $ct = $request->header_in("Content-Type");
   $ct =~ m{^multipart/form-data} or return;
   $ct =~ m#boundary=\"?([^\";,]+)\"?#; #FIXME# should use parse_mime_header
   my $boundary = $1;
   my $fh = new PApp::FormBuffer
                fh => $request,
                boundary => $boundary,
                rsize => $request->header_in("Content-Length");

   $request->header_in("Content-Type", "");

   while ($fh->skip_boundary) {
      my ($ct, %ct, %cd);
      my $hdr = "";
      my $line;
      do {
	 $line = $fh->READLINE;
	 if ($line =~ /^\s/) {
	    $hdr .= $line;
	 } else {
	    if ($hdr =~ /^Content-Type:\s+(.*)$/i) {
	       ($ct, %ct) = parse_mime_header $1;
	    } elsif ($hdr =~ /^Content-Disposition:\s+(.*)/i) {
	       (undef, %cd) = parse_mime_header $1;
	       # ^^^ eq "form-data" or die ";-[";
	    }
	    $hdr = $line;
	 }
      } while ($line ne "");

      my $name = delete $cd{name};

      if (defined $name) {
         $ct ||= "text/plain";
         $ct{charset} ||= $state{papp_lcs} || "iso-8859-1";
         $cb->($fh, $name, $ct, \%ct, \%cd);

         # read (& skip) the remaining data, if any
         my $buf; 1 while $fh->read($buf, 16384) > 0;
      }
   }

   $request->header_in("Content-Length", 0);

   1;
}

sub _unicode_to_entity {
   sprintf "&#x%x;", $_[0];
}

sub flush_cvt {
   if (@fixup) {
      my @fixup = map { (ref) ? &$_ : $_ } @fixup;
      $$routput =~ s/\x{fc00}(......)/$fixup[$1]/sg;
   }

   # charset conversion
   if ($output_charset eq "*") {
      #d##FIXME#
      # do "output charset" negotiation, at the moment this is truely pathetic
      if (utf8_downgrade $$routput, 1) {
         $output_charset = "iso-8859-1";
      } else {
         utf8_upgrade $$routput; # must be utf8 here, but why?
         $output_charset = "utf-8";
      }
   } elsif ($output_charset) {
      # convert to destination charset
      if ($output_charset ne "iso-8859-1" || !utf8_downgrade $$routput, 1) {
         utf8_upgrade $$routput; # wether here or in pconv doesn't make much difference
         if ($output_charset ne "utf-8") {
            my $pconv = PApp::Recode::Pconv::open $output_charset, CHARSET, \&_unicode_to_entity
                           or fancydie "charset conversion to $output_charset not available";
            $$routput = PApp::Recode::Pconv::convert($pconv, $$routput);
         } # else utf-8 == transparent
      } # else iso-8859-1 == transparent
   } else {
      utf8_downgrade $$routput;
   }

   $state{papp_lcs} = $output_charset;
   $request->content_type($output_charset
                          ? "$content_type; charset=$output_charset"
                          : $content_type);
}

sub flush_snd {
   use bytes;

   $request->send_http_header unless $output_p++;
   # $routput should suffice in the next line, but it sometimes doesn't,
   # so just COPY THAT DAMNED THING UNTIL MODPERL WORKS. #d##FIXME#TODO#
   $request->print ($$routput) unless $request->header_only;

   $$routput = "";
}

sub flush {
   flush_cvt;
   local $| = 1;
   flush_snd;
}

sub flush_snd_length {
   use bytes;

   flush_cvt;
   $request->header_out('Content-Length', length $$routput);
   flush_snd;
}

sub set_output {
   $$routput = $_[0];
}

sub send_upcall(&) {
   local $SIG{__DIE__};
   die bless $_[0], PApp::Upcall::;
}

sub internal_redirect {
   my $url = $_[0];
   send_upcall {
      # we have to get rid of the old request (think POST, and Apache->content)
      $request->method ("GET");
      $request->header_in ("Content-Type", "");
      $request->internal_redirect ($url);
      return &OK;
   };
}

sub _gen_external_redirect {
   my $url = $_[0];
   $request->status (302);
   $request->header_out (Location => $url);
   set_output "
<html>
<head><title>".__"page redirection"."</title></head>
<meta http-equiv=\"refresh\" content=\"0;URL=$url\">
</head>
<body text=\"black\" link=\"#1010C0\" vlink=\"#101080\" alink=\"red\" bgcolor=\"white\">
<large>
This page has moved to <tt>$url</tt>.<br />
<a href=\"$url\">
".__"The automatic redirection  has failed. Please try a <i>slightly</i> newer browser next time, and in the meantime <i>please</i> follow this link ;)"."
</a>
</large>
</body>
</html>
";
   eval { flush(1) };
   return &OK;
}

sub redirect {
   my $url = $_[0];
   send_upcall { _gen_external_redirect $url };
}

sub abort_to {
   internal_redirect &surl;
}

sub abort_with(&) {
   local *output = $routput;
   &{$_[0]};
   send_upcall {
      flush(1);
      return &OK;
   }
}

sub _send_file($$$) {
   my ($fh, $ct, $inclen) = @_;
   $request->content_type ($ct) if $ct;
   $request->header_out ('Content-Length' => $inclen + (-s _) - tell $fh) if -f $fh;
   $request->send_http_header;
   $request->send_fd ($fh) unless $request->header_only;
}

sub abort_with_file($;$) {
   my ($fh, $ct) = @_;
   send_upcall {
      _send_file ($fh, $ct, 0);
      return &OK;
   }
}

sub cookie($) {
   $temporary{cookie}{$_[0]}
}

sub add_cookie($$;%) {
   my ($name, $value, %param) = @_;

   $value = "$name=$value";

   $param{expires} = unixtime2http ($param{expires}, "cookie")
      if exists $param{expires};

   while (my ($k, $v) = each %param) {
      $value .= ";$k";
      $value .= "=$v" if defined $v;
   }

   # most clients (including firefox) are broken and need separate set-cookie headers
   # this currently breaks PApp::CGI
   $request->headers_out->add ('Set-Cookie' => $value);
}

sub _set_cookie {
   add_cookie papp_1984 => (PApp::X64::enc $cipher_e->encrypt(pack "VVVV", $userid, 0, 0, $state{papp_cookie})),
      path    => "/",
      expires => $NOW + $cookie_expires;
}

sub _debugbox {
   my $r;

   my $pre1 = "<font color='black' size='3'><pre>";
   my $pre0 = "</pre></font>";

   my $_modules = eval { modpath_freeze($modules) } || do { $@ =~ s/ at \(.*$//s; "&lt;$@|".(escape_html PApp::Util::dumpval $modules)."&gt;" };
   my $_curmod  = eval { modpath_freeze($$curmod) } || do { $@ =~ s/ at \(.*$//s; "&lt;$@|".(escape_html PApp::Util::dumpval $$curmod)."&gt;" };

   $r .= "<h2>Status:</h2>$pre1\n",
   $r .= "UsSAS = ($userid,$prevstateid,$stateid,$alternative,$sessionid); location = $location; curpath+module = $curpath+$module;\n";
   $r .= "langs = $langs; modules = $_modules; curmod = $_curmod;\n";

   $r .= "$pre0<h3>Debug Output (dprint &amp; friends):</h3>$pre1\n";
   $r .= escape_html($doutput);

   $r .= "$pre0<h3>Input Parameters (%P):</h3>$pre1\n";
   $r .= escape_html(PApp::Util::dumpval(\%P));

   $r .= "$pre0<h3>Input Arguments (%arguments):</h3>$pre1\n";
   $r .= escape_html(PApp::Util::dumpval(\%arguments));

   $r .= "${pre0}<h3>Global State (%state):</h3>$pre1\n";
   $r .= escape_html(PApp::Util::dumpval(\%state));

   if (0) { # nicht im moment, nutzen sehr gering
   $r .= "$pre0<h3>Application Definition (%\$papp):</h3>$pre1\n";
   $r .= escape_html(PApp::Util::dumpval($papp,{
            #CB     => $papp->{cb}||{},
            #CB_SRC => $papp->{cb_src}||{},
         }));
   }

   $r .= "$pre0<h3>Apache->request:</h3>$pre1\n";
   $r .= escape_html($request->as_string);

   $r .= "$pre0\n";

   $r =~ s/&#0;/\\0/g; # escape binary zero
   $r;
}

sub debugbox {
   echo "<br /><table cellpadding='10' bgcolor='#e0e0e0' width='100%' align='center'><tr><td id='debugbox'><font size='6' face='Helvetica' color='black'>";
   if (0||$state{papp_debug}) {
      echo slink("[switch debug mode OFF]", "/papp_debug" => undef);
      echo _debugbox;
   } else {
      echo slink("[switch debug mode ON]", "/papp_debug" => 1);
   }
   echo "</font></td></tr></table>";
}

sub language_selector {
   my $translator = shift;
   my $current = shift || $translator->get_table($langs)->lang;
   for my $lang ($translator->langs) {
      next if $lang eq "*" || lc $lang eq "mul";
      my $name = PApp::I18n::translate_langid($lang, $lang);
      if ($lang ne $current) {
         echo slink "[$name]", SURL_SET_LOCALE($lang);
      } else {
         echo "<b>[$name]</b>";
      }
   }
   
}

sub preferences_url {
   $papp_main->surl("pref_edit");
}

sub preferences_link {
   alink __"[Preferences]", &preferences_url;
}

#############################################################################
# path stuff, ought to go into xs, at least
#############################################################################

sub abs_path($) {
   expand_path(shift, $curpath);
}

# ($path, $key) = split_path $keypath;
sub split_path($) {
   $_[0] =~ /^(.*)\/([^\/]*)$/;
}

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

sub reload_p {
   if ($prevstateid) {
      $st_reload_p->execute($prevstateid, $alternative);
      $st_reload_p->fetchrow_arrayref->[0]
   } else {
      0;
   }
}

sub getpref($) {
   $curprefs->get($_[0]);
}

sub setpref($;$) {
   $curprefs->set($_[0], $_[1]);
}

# forcefully (re-)read the user-prefs and returns the "new-user" flag
# reads all user-preferences (no args) or only the preferences
# for the given path (argument is given)
sub load_prefs($) {
   if ($userid) {
      my $st = sql_exec $DBH, \my($prefs),
                        "select value from prefs where uid = ? and path = ? and name = 'papp_prefs'",
                        $userid, $_[0];
      if ($st->fetch) {
         $prefs &&= PApp::Storable::thaw decompress $prefs;

         my $h = $_[0] ? $state{$_[0]} : \%state;
         @$h{keys %$prefs} = values %$prefs;

         return 0;
      } else {
         return 1;
      }
   }
}

sub save_prefs {
   my %prefs;
   my $userid = getuid;

   while (my ($path, $keys) = each %preferences) {
      next if $path && !exists $state{$path};
      
      my $h = $path ? $state{$path} : \%state;
      $prefs{$path} = { map { $_ => $h->{$_} } grep { defined $h->{$_} } @$keys };
   }

   while (my ($path, $keys) = each %prefs) {
      if (%$keys) {
         $st_replacepref->execute($userid, $path, "papp_prefs", 
                                  compress PApp::Storable::nfreeze($keys));
      } else {
         $st_deletepref->execute($uid, $path, "papp_prefs");
                        $userid, $path, "papp_prefs";
      }
   }
}

sub start_session {
   ($sessionid, $prevstateid, $alternative) = ($stateid, 0, 0);
}

sub switch_userid {
   if ($userid != $_[0]) {
      $userid = $_[0];

      if ($userid) {
         load_prefs "";
         for (keys %preferences) {
            load_prefs $_ if exists $state{$_};
         }
      }

      $state{papp_switch_newuserid} = $_[0];
      $state{papp_cookie} = 0; # unconditionally re-set the cookie
   }
}

sub newuid() {
   $st_newuserid->execute;
   return sql_insertid $st_newuserid;
}

sub getuid() {
   $userid ||= do {
      switch_userid newuid;
      $userid;
   }
}

sub update_state {
   %arguments = %A = ();

   $st_insertstate->execute($stateid,
                            compress PApp::Storable::mstore(\%state),
                            $userid, $prevstateid, $sessionid, $alternative)
      if @{$state{papp_alternative}};

   &_destroy_state; # %P = %S = %state = (), but in a safe way
   undef $stateid;
}

sub flush_pkg_cache  {
   DBH->do ("delete from pkg");
}

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

sub warnhandler {
   my $msg = $_[0];
   PApp->warn ("Warning[$$]: $msg");
}

sub PApp::Base::warn {
   if ($request) {
      (my $msg = $_[1]) =~ s/\n$//;
      $request->warn ($msg);
      $warn_log .= "$msg\n";
   } else {
      print STDERR $_[1];
   }
};

our $eval_level = 0;

sub config_eval(&) {
   if (!$eval_level) {
      local $eval_level = 1;
      local $SIG{__DIE__} = \&PApp::Exception::diehandler;
      my $retval = eval { &{$_[0]} };
      config_error PApp $@->as_string if $@;
      return $retval;
   } else {
      return &{$_[0]};
   }
}

my %app_cache;

# find app by mountid or name
sub load_app($$) {
   my $class = shift;
   my $appid_or_name = shift;

   return $app_cache{$appid_or_name} if exists $app_cache{$appid_or_name};

   my $st = sql_exec DBH,
                     \my($appid, $name, $path, $mountconfig, $config),
                     "select id, name, path, mountconfig, config from app
                                            where "
                      . ($appid_or_name+0 eq $appid_or_name ? "id =" : "name like")
                      . " ?", "$appid_or_name"; #D#D "" workaround for DBD::mysql
   $st->fetch or fancydie "load_app: no such application", "appid => $appid_or_name";

   my %config = eval $config;

   $@ and fancydie "error while evaluating config for [appid=$appid]", $@,
      info => [path => $path],
      info => [name => $name],
      info => [appid => $appid],
      info => [config => PApp::Util::format_source $_config];

   my $class;

   if ($path =~ /^(PApp::[^\/]+)(.*)$/) {
      $class = $1;
      $path = $2;
   } else {
      $class = "PApp::Application::PApp";
   }

   $app_cache{$appid} =
   $app_cache{$name} = new $class
      delayed	         => 1,
      mountconfig	 => $mountconfig,
      url_prefix_nossl   => $url_prefix_nossl,
      url_prefix_ssl     => $url_prefix_ssl,
      url_prefix_sslauth => $url_prefix_sslauth,
      %config,
      appid		 => $appid,
      path		 => $path,
      name		 => $name;
}

sub PApp::Base::mount_appset {
   my $self = shift;
   my $appset = shift;
   my @apps;

   config_eval {
      my $setid = sql_fetch DBH, "select id from appset where name like ?", $appset;
      $setid or fancydie "$appset: unable to mount nonexistant appset";
   };

   my $st = sql_exec
               DBH,
               \my($id),
               "select app.id from app, appset where app.appset = appset.id and appset.name = ?",
               $appset;

   while ($st->fetch) {
      config_eval {
         my $papp = PApp->load_app($id);
         PApp->mount($papp);
         push @apps, $papp;
      }
   }
   @apps;
}

sub PApp::Base::mount_app {
   my $self = shift;
   my $app = shift;
   my $id;

   config_eval {
      $id = sql_fetch DBH, "select id from app where name like ?", $app;
      $id or fancydie "$app: unable to mount nonexistant application $id";

      $app = PApp->load_app($id);
      PApp->mount($app);
   };

   $app;
}

sub PApp::Base::mount {
   my $self = shift;
   my $papp = shift;

   my %arg = @_;

   $papp{$papp->{appid}} = $papp;

   $papp->mount;

   $papp->load unless $arg{delayed} || $PApp::delayed;
}

sub list_apps() {
   keys %papp;
}

sub handle_error($) {
   my $exc = $_[0];

   UNIVERSAL::isa $exc, PApp::Exception::
      or $exc = new PApp::Exception error => 'Script evaluation error',
                                    info => [$exc];
   $exc->errorpage;
   $request->status(500);
   eval { update_state };
   eval { flush_cvt };
   if ($request) {
      $request->log_reason ($exc, $request->filename);
   } else {
      print STDERR $exc;
   }
}

# return a new stateid, pool stateids a bit
{
   my ($id1, $id2);

   sub newstateid {
      if ($id1 == $id2) {
         $st_newstateids->execute(16);
         $id1 = sql_insertid $st_newstateids;
         $id2 = $id1 + 16;
      }
      $id1++;
   }
}

my $last_bench;
sub bench {
   my $n = Time::HiRes::time;
   if ($NOW <= $last_bench && @_) {
      warn "($_[0]): " . ($n - $last_bench);
   }
   $last_bench = $n;
}

################################################################################################
#
#   the PApp request handler
#
# on input, $location, $pathinfo, $request and $papp must be preset
#
sub _handler {
   # for debugging only, maybe?
   local $SIG{QUIT} = sub { Carp::confess "SIGQUIT" };

   $NOW = time;

   undef $stateid;

   defined $logfile and open (local *STDERR, ">>", $logfile);

   $output_p = 0;
   $doutput = "";
   $output = "";
   @fixup = ();
   tie *STDOUT, "PApp::Catch_STDOUT";
   $content_type = "text/html";
   $output_charset = "*";
   $warn_log = "";

   local %temporary;

   eval {
      local $SIG{__DIE__}  = \&PApp::Exception::diehandler;
      local $SIG{__WARN__} = \&warnhandler;

      $DBH = DBH;

      %P = %arguments = ();
      _set_params PApp::HTML::parse_params $request->query_string;
      _set_params PApp::HTML::parse_params $request->content
         if $request->header_in("Content-Type") eq "application/x-www-form-urlencoded";

      my $state =
            delete $P{papp}
            || ($pathinfo =~ s%/([\-.a-zA-Z0-9]{22,22})$%% && $1);

      if ($state) {
         ($userid, $prevstateid, $alternative, $sessionid) =
            unpack "VVVxxxx", $cipher_d->decrypt(PApp::X64::dec $state);

         $st_fetchstate->execute($prevstateid);
         $state = $st_fetchstate->fetchrow_arrayref;
      } else {
         $st_eventcount->execute;
         $state = $st_eventcount->fetchrow_arrayref;
      }

      $stateid = newstateid;

      PApp::Event::handle_events ($state->[0])
         if $event_count != $state->[0];

      if (defined (my $cookie = $request->header_in ('Cookie'))) {
         # parse NAME=VALUE
         my @kv;

         for ($cookie) {
            while (/\G\s* ([^=;,[:space:]]+) (?: \s*=\s* (?: "( (?:[^\\"]+ | \\.)*)" | ([^;,[:space:]]*) ) )?/gcxs) {
               my $name = $1;
               my $value = $3;

               unless (defined $value) {
                  # also catches $2=$3=undef
                  $value = $2;
                  $value =~ s/\\(.)/$1/gs;
               }

               push @{$temporary{cookie}{lc $name}}, $value;

               last unless /\G\s*;/gc;
            }
         }
      }

      if (defined $state->[1]) {
         $stateid = newstateid;

         $sessionid = $state->[4];

         *state = PApp::Storable::mretrieve decompress $state->[1];

         if ($state->[2] != $userid) {
            if ($state->[2] != $state{papp_switch_newuserid}) {
               fancydie "user id mismatch ($state->[2] <> $state{papp_switch_newuserid}", "maybe someone is tampering?";
            } else {
               $userid = $state{papp_switch_newuserid};
            }
         }
         delete $state{papp_switch_newuserid};

         set_alternative $state{papp_alternative}[$alternative];

         $papp = $papp{$state{papp_appid}}
                 or fancydie "Application not mounted", $location,
                             info => [appid => $state{papp_appid}];

      } else {
         start_session;

         $state{papp_appid} = $papp->{appid};

         $modules = $pathinfo =~ m%/(.*?)/?$% ? modpath_thaw $1 : {};

         if ($temporary{cookie}{papp_1984}[0] =~ /^([0-9a-zA-Z.-]{22,22})$/) {
            ($userid, undef, undef, $state{papp_cookie}) = unpack "VVVV", $cipher_d->decrypt(PApp::X64::dec $1);
            load_prefs "";
         } else {
            $userid = 0;
         }
      }
      $state{papp_alternative} = [];

      $langs = $state{papp_lcs};
      if ($langs eq "utf-8") {
         # force utf8 on
         for (keys %P) {
            utf8_on $_ for ref $P{$_} ? @{$P{$_}} : $P{$_};
         }
      } elsif ($langs !~ /^(?:|ascii|us-ascii|iso-8859-1)$/i) {
         my $pconv = PApp::Recode::Pconv::open CHARSET, $langs
                        or fancydie "charset conversion from $langs not available";
         for (keys %P) {
            $_ = utf8_on $pconv->convert_fresh($_) for ref $P{$_} ? @{$P{$_}} : $P{$_};
         }
      }

      $langs = "$state{papp_locale},".$request->header_in("Content-Language").",en";

      $papp->check_deps if $checkdeps;

      unless ($papp->{compiled}) {
         $papp->load_code;
         $papp->event("init");
         $papp->event("childinit");
      }

      local $module = undef; # in case a callback calls abort_to etc. #d# remove?

      # do not use for, as papp_execonce might actually grow during
      # execution of these callbacks.
      while (@{$state{papp_execonce}}) {
         eval {
            (shift @{$state{papp_execonce}})->() while @{$state{papp_execonce}};
            1;
         } or (UNIVERSAL::isa $@, PApp::Upcall:: and die)
           or $papp->uncaught_exception ($@, 1);
      }
      delete $state{papp_execonce};

      if ($state{papp_cookie} < $NOW - $cookie_reset) {
         $state{papp_cookie} = $NOW;
         _set_cookie;
      }

      eval { $papp->run; 1; }
         or (UNIVERSAL::isa $@, PApp::Upcall:: and die)
         or $papp->uncaught_exception ($@, 0);

      flush_cvt;

      update_state;
      undef $stateid;

      1;
   } or do {
      delete $state{papp_execonce};

      if (UNIVERSAL::isa $@, PApp::Upcall::) {
         my $upcall = $@;
         eval { update_state };
         untie *STDOUT; open STDOUT, ">&1";
         return &$upcall;
      } else {
         handle_error $@;
      }
   };

   untie *STDOUT; open STDOUT, ">&1";

   flush_snd_length;

   # now eat what the browser sent us (might give locking problems, but
   # that's not our bug).
   parse_multipart_form {} if $request->header_in("Content-Type") =~ m{^multipart/form-data};

   undef $request; # preserve memory

   return &OK;
}

sub PApp::Catch_STDOUT::TIEHANDLE {
   bless \(my $unused), shift;
}

sub PApp::Catch_STDOUT::PRINT {
   shift;
   $output .= join "", @_;
   1;
}

sub PApp::Catch_STDOUT::PRINTF {
   shift;
   $output .= sprintf(shift,@_);
   1;
}

sub PApp::Catch_STDOUT::WRITE {
   my ($self, $data, $length) = @_;
   $output .= $data;
   $length;
}

1;