#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.                                                  ##
##########################################################################

=head1 NAME

PApp - multi-page-state-preserving web applications

=head1 SYNOPSIS

I<This module requires quite an elaborate setup (see the INSTALL
file). Please read the LICENSE file: this version of PApp is neither GPL
nor BSD licensed).>

=head1 DESCRIPTION

PApp is a complete solution for developing multi-page web
applications that preserve state I<across> page views. It also tracks user
id's, supports a user access system and provides many utility functions
(html, sql...). You do not need (and should not use) the CGI module.

Advantages:

=over 4

=item * Speed. PApp isn't much slower than a hand-coded mod_perl handler,
and this is only due to the extra database request to fetch and restore
state, which typically you would do anyway. To the contrary: a non-trivial
Apache::Registry page is slower than the equivalent PApp application (or
much, much more complicated). 

=item * Embedded Perl. You can freely embed perl into your documents. In
fact, You can do things like these:

   <h1>Names and amounts</h1>
   <:
      my $st = sql_exec \my($name, $amount), "select name, amount from ...",

      while ($st->fetch) {?>
         Name: $name, Amount: $amount<p>
      <:}
   :>
   <hr>

That is, mixing html and perl at statement boundaries.

=item * State-preserving: The global hash C<%S> is automaticaly
preserved during the session. Everything you save there will be available
in any subsequent pages that the user accesses.

=item * XML. PApp-applications are written in XML. While this is no
advantage in itself, it means that it uses a standardized file format that
can easily be extended. PApp comes with a DTD and a vim syntax
file, even ;)

=item * Easy internationalisation. I18n has never been that easy:
just mark you strings with __C<>"string", either in html or in the perl
source. The "poedit"-demo-application enables editing of the strings
on-line, so translaters need not touch any text files and can work
diretcly via the web.

=item * Feature-Rich. PApp comes with a I<lot> of
small-but-nice-to-have functionality.

=back

To get a quick start, read the F<bench.papp> module, the F<dbedit.papp> module,
the F<cluster.papp> module and the F<papp.dtd> description of the papp file
format.

Also, have a look at the F<doc/> subdirectory of the distribution, which will
have some tutorials in sdf and html format.

=cut

package PApp;

use 5.006;

use utf8;
no bytes;

no warnings;

#   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 {
   $VERSION = 1.43;

   use base Exporter;

   @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
   );
   @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;

   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

    $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  = 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

%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";

=head1 Global Variables

Some global variables are free to use and even free to change (yes, we
still are about speed, not abstraction). In addition to these variables,
the globs C<*state>, C<*S> and C<*A> (and in future versions C<*L>)
are reserved. This means that you cannot define a scalar, sub, hash,
filehandle or whatsoever with these names.

=over 4

=item $request [read-only]

The Apache request object (L<Apache>), the same as returned by C<Apache->request>.

=item %state [read-write, persistent]

A system-global hash that can be used for almost any purpose, such as
saving (global) preferences values. All keys with prefix C<papp> are
reserved for use by this module. Everything else is yours.

=item %S [read-write, persistent]

Similar to C<%state>, but is local to the current application. Input
arguments prefixed with a dash end up here.

=item %A [read-write, input only]

A global hash that contains the arguments to the current module. Arguments
to the module can be given to surl or any other function that calls it, by
prefixing parameter names with a minus sign (i.e. "-switch").

=item %P [read-write, input only]

Similar to C<%A>, but it instead contains the parameters from
forms submitted via GET or POST (C<see parse_multipart_form>,
however). Everything in this hash is insecure by nature and must be
used carefully.

Normally, the values stored in C<%P> are plain strings (in utf-8,
though). However, it is possible to submit the same field multiple times,
in which case the value stored in C<$P{field}> is a reference to an array
with all strings, i.e. if you want to evaluate a form field that might be
submitted multiple times (e.g. checkboxes or multi-select elements) you
must use something like this:

   my @values = ref $P{field} ? @{$P{field}} : $P{field};

=item %temporary [not exported]

Is empty at the beginning of a request and will be cleared at request end.

=item $userid [read-only]

The current userid. User-Id's are automatically assigned, you are
encouraged to use them for your own user-databases, but you must not trust
them. C<$userid> is zero in case no userid has been assigned yet. In this
case you can force a userid by calling the function C<getuid>, which
allocated one if necessary,

=item $sessionid [read-only]

A unique number identifying the current session (not page). You could use
this for transactions or similar purposes. This variable might or might
not be zero indicating that no session has been allocated yet (similar to
C<$userid> == 0).

=item $curprefs, $prefs [L<PApp::Prefs>]

The current application's (C<$curprefs>) and the global (C<$prefs>) preferences object.

  $curprefs->get("bg_color");
  ef_string $curprefs->ref("bg_color"), 15;

=item $PApp::papp (a hash-ref) [read-only] [not exported] [might get replaced by a function call]

The current PApp::Application object (see L<PApp::Application>). The
following keys are user-readable:

 config   the argument to the C<config>option given to C<mount>.

=item $ppkg [read-only] [might get replaced by a function call]

This variable contains the current C<PApp::Package> object (see
L<PApp::Package>). This variable might be replaced by something else, so
watch out. This might or might not be the same as $PApp::ppkg, so best use
$ppkg when using it. Ah, actually it's best to not use it at all.

=item $PApp::location [read-only] [not exported] [might get replaced by a function call]

The location value from C<mount>.

=item $PApp::module [read-only] [not exported] [might get replaced by a function call]

The current module I<within> the application (full path).

=item $NOW [read-only]

Contains the time (as returned by C<time>) at the start of the request.
Highly useful for checking cache time-outs or similar things, as it is
faster to use this variable than to call C<time>.

=back

=head1 Functions/Methods

=over 4

=item PApp->search_path(path...);

Add a directory in where to search for included/imported/"module'd" files.

=item PApp->configure(name => value...);

Configures PApp, must be called once and once only. Most of the
configuration values get their defaults from the secured config file
and/or give defaults for applications.

 pappdb        The (mysql) database to use as papp-database
               (default "DBI:mysql:papp")
 pappdb_user   The username when connecting to the database
 pappdb_pass   The password when connecting to the database
 cipherkey     The Twofish-Key to use (16 binary bytes),
               BIG SECURITY PROBLEM if not set!
               (you can use 'mcookie' from util-linux twice to generate one)
 cookie_reset  delay in seconds after which papp tries to
               re-set the cookie (default: one day)
 cookie_expires time in seconds after which a cookie shall expire
               (default: one year)
 logfile       The path to a file where errors and warnings are being logged
               to (the default is stderr which is connected to the client
               browser on many web-servers)

The following configuration values are used mainly for development:

 checkdeps     when set, papp will check the .papp file dates for
               every request (slow!!) and will reload the app when necessary.
 delayed       do not compile applications at server startup, only on first
               access. This greatly increases memory consumption but ensures
               that the httpd startup works and is faster.
 onerr         can be one or more of the following characters that
               specify how to react to an unhandled exception. (default: 'sha')
               's' save the error into the error table
               'v' view all the information (security problem)
               'h' show the error category only
               'a' give the admin user the ability to log-in/view the error

=item PApp->mount_appset($appset)

Mount all applications in the named application set. Usually used in the httpd.conf file
to mount many applications into the same virtual server etc... Example:

  mount_appset PApp 'default';

=item PApp->mount_app($appname)

Can be used to mount a single application.

The following description is no longer valid.

 location[*]   The URI the application is mounted under, must start with "/".
               Currently, no other slashes are allowed in it.
 src[*]        The .papp-file to mount there
 config        Will be available to the application as $papp->{config}
 delayed       see C<PApp->configure>.

 [*] required attributes

=item ($name, $version) = PApp->interface

Return name and version of the interface PApp runs under
(e.g. "PApp::Apache" or "PApp:CGI").

=cut

# 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;
}

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

=item dprintf "format", value...

=item dprint value...

Work just like print/printf, except that the output is queued for later use by the C<debugbox> function.

=item echo value[, value...]

Works just like the C<print> function, except that it is faster for generating output.

=item capture { code/macros/html }

Captures the output of "code/macros/perl" and returns it, instead of
sending it to the browser. This is more powerful than it sounds, for
example, this works:

 <:
    my $output = capture {

       print "of course, this is easy\n";
       echo "this as well";
       :>

       Yes, this is captured as well!
       <:&this_works:>
       <?$captureme:>

       <:

    }; # close the capture
 :>

=cut

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

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

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

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

=item my $guard = PApp::guard { ... }

This creates and returns a guard object. Nothing happens until the object
gets destroyed, in which case the codeblock given as argument will be
executed. This is useful to free locks or other resources in case of a
runtime error or when the coroutine gets canceled, as in both cases the
guard block will be executed. The guard object supports only one method,
C<< ->cancel >>, which will keep the codeblock from being executed.

Example: set some flag and clear it again when the coroutine gets canceled
or the function returns:

   sub do_something {
      my $guard = Coro::guard { $busy = 0 };
      $busy = 1;

      # do something that requires $busy to be true
   }

=cut

sub guard(&) {
   bless \(my $cb = $_[0]), "PApp::guard"
}

sub PApp::guard::cancel {
   ${$_[0]} = sub { };
}

sub PApp::guard::DESTROY {
   ${$_[0]}->();
}

=item content_type $type [, $charset]

Sets the output content type to C<$type>. The content-type should be a
registered MIME type (see RFC 2046) like C<text/html> or C<image/png>. The
optional argument C<$charset> can be either "*", which selects a suitable
output encoding dynamically (e.g. according to C<$state{papp_locale}>)
or the name of a registered character set (STD 2). The special value
C<undef> suppresses output character conversion entirely. If not given,
the previous value will be unchanged (the default; currently "*").

Charset-negotiation is not yet implemented, but when it is implemented it
will work like this:

The charset argument might also be an array-reference giving charsets that
should be tried in order (similar to the language preferences). The last
charset will be I<forced>, i.e. characters not representable in the output
will be replaced by some implementation defined way (if possible, this
will be C<&#charcode;>, which is at least as good a replacement as any
other ;)

=cut

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

=item setlocale [$locale]

Sets the locale used by perl to the given (PApp-style) locale string. This
might involve multiple calls to the "real" setlocale which in turn might
be very slow (C<setlocale> is very slow on glibc based systems for
example). If no argument is given it sets the locale to the current user's
default locale (see C<SURL_SET_LOCALE>). NOTE: Remember that PApp (and
Perl) requires iso-8859-1 or utf-8, so be prepared to do any conversion
yourself. In future versions PApp might help you doing this (e.g. by
setting LC_CTYPE to utf-8, but this is not supported on many systems).

At the moment, PApp does not automatically set the (Perl) locale on each
request, so you need to call setlocale before using any locale-based
functions.

Please note that PApp-style locale strings might not be compatible to your
system's locale strings (this function does the conversion).

=cut

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

=item reference_url $fullurl

Return a url suitable for external referencing of the current
page. If C<$fullurl> is given, a full url (including a protocol
specifier) is generated. Otherwise a partial uri is returned (without
http://host:port/).

This is only a bona-fide attempt: The current module must support starting
a new session and only "import"-variables and input parameters are
preserved.

=cut

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 "&amp;", (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" : "");
}

=item $url = surl ["module"], arg => value, ...

C<surl> is one of the most often used functions to create urls. The first
argument is a comma-seperated list of target modules that the url should
refer to. If it is missing the url will refer to the current module state,
as will a module name of ".". The most common use is just a singular
module name. Examples:

 .            link to the current module
 menu         link to module "menu" in the current package
 fall/wahl    link to the current module but set the subpackage
              "fall" to module "wahl".
 fall/,menu   link to the menu module and set the subpackage
              "fall" to the default module (with the empty name).

The remaining arguments are parameters that are passed to the new
module. Unlike GET or POST-requests, these parameters are directly passed
into the C<%S>-hash (unless prefixed with a dash), i.e. you can use this
to alter state values when the url is activated. This data is transfered
in a secure way and can be quite large (it will not go over the wire).

When a parameter name is prefixed with a minus-sign, the value will end up
in the (non-persistent) C<%A>-hash instead (for "one-shot" arguments).

Otherwise the argument name is treated similar to a path under unix: If it
has a leading "/", it is assumed to start at the server root, i.e. with
the application location. Relative paths are resolved as you would expect
them. Examples:

 /papp_locale  $state{papp_locale}
 /tt/var       $state{'/tt'}{var} -OR- $S{var} in application /tt
 /tt/mod1/var  $state{'/tt'}{'/mod1'}{var}
 ../var        the "var" statekey of the module above in the stack

The following (symbolic) modifiers can also be used:

 SURL_PUSH(<path> => <value>)
 SURL_UNSHIFT(<path> => <value>)
   treat the following state key as an arrayref and push or unshift the
   argument onto it.

 SURL_POP(<path-or-ref>)
 SURL_SHIFT(<path-or-ref>)
   treat the following state key as arrayref and pop/shift it.

 SURL_EXEC(<coderef>) [obsolete]
   treat the following parameter as code-reference and execute it
   after all other assignments have been done. this SURL modifier
   is deprecated, PApp::Callback callbacks don't need this modifier
   anymore.

   Nowadays, code-references found anywhere in the surlargs are treated
   as if they had a SURL_EXEC wrapped around them. IF you want to pass a
   coderef, you therefore have to pass a reference to it or wrap it into
   an object.

 SURL_EXEC_IMMED(<coderef>)
   Like SURL_EXEC, but will be executed immediately when parsing. This
   can be used to implement special surl behaviour, because it can affect
   values specified after this specification. Normally, you don't want
   to use this call.

 SURL_SAVE_PREFS
   call save_prefs

 SURL_START_SESSION
   start a new session, tearing the connection to the current session.
   must be specified early in the surlargs. Right now, the %state is not
   being cleared and retains its old values, so watch out!

 SURL_STYLE_URL
 SURL_STYLE_GET
 SURL_STYLE_STATIC
   set various url styles, see C<surl_style>.

 SURL_SUFFIX(<file>)
   sets the filename in the generated url to the given string. The
   filename is the last component of the url commonly used by browsers as
   the default name to save files. Works only with SURL_STYLE_GET.

Examples:

 SURL_PUSH("stack" => 5)   push 5 onto @{$S{stack}}
 SURL_SHIFT("stack")       shift @{$S{stack}}
 SURL_SAVE_PREFS           save the preferences on click
 SURL_EXEC($cref->refer)   execute the PApp::Callback object

=item surl_style [newstyle]

Set a new surl style and return the old one (actually, a token that can be
used with C<surl_style>. C<newstyle> must be one of:

 SURL_STYLE_URL
   The "classic" papp style, the session id gets embedded into the url,
   like C</admin/+modules-/bhWU3DBm2hsusnFktCMbn0>.

 SURL_STYLE_GET
   The session id is encoded as the form field named "papp" and appended
   to the url as a get request, e.g. C</admin/+modules-?papp=bhWU3DBm2hsusnFktCMbn0>.

 SURL_STYLE_STATIC
   The session id is not encoded into the url, e.g. C</admin/+modules->,
   instead, surl returns two arguments. This must never be set as a
   default using C<surl_style>, but only when using surl directly.

=cut

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

=item postpone { ... } [args...]

Can only be called inside (or before) SURL_EXEC callbacks, and postpones
the block to be executed after all other callbacks. Just like callbacks
themeselves, these callbacks are executed in FIFO order. The current
database handle will be restored.

=cut

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);
   };
}

=item $ahref = slink contents,[ module,] arg => value, ...

This is just "alink shift, &url", that is, it returns a link with the
given contants, and a url created by C<surl> (see above). For example, to create
a link to the view_game module for a given game, do this:

 <? slink "Click me to view game #$gamenr", "view_game", gamenr => $gamenr :>

The view_game module can access the game number as $S{gamenr}.

=cut

# 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;
}

=item suburl [surl-args]

Creates a URL like C<surl>, but also pushes the current module state
onto the return stack. It preserves all current locals for the
"return jump".

=item sublink content [, surl-args]

Just like C<suburl> but creates an C<A HREF> link with given contents.

=item retlink_p

Return true when the return stack has some entries, otherwise false.

=item returl [surl-args]

Return a url that has the effect of returning to the last
C<suburl>-caller.

=item retlink content [, surl-args]

Just like returl, but creates an C<A HREF> link with the given contents.

=cut

# 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;
}

=item ($marker, $ref) = fixup_marker [$initial_content]

Create a new fixup marker and return a scalar reference to it's
replacement text (initially empty if not specified). At page output time
any fixup markers in the document are replaced by this scalar.

The initial content can also be a code reference which will be evaluated
at marker output time.

=item $ref = insert_fixup [$initial_content]

Similar to C<fixup_marker>, but inserts the marker into the current output stream.

=cut

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;
}

=item sform [\%attrs,] [module,] arg => value, ...

=item cform [\%attrs,] [module,] arg => value, ...

=item multipart_form [\%attrs,], [module,] arg => value, ...

=item endform

Forms Support

These functions return a <form> or </form>-Tag. C<sform> ("simple form")
takes the same arguments as C<surl> and return a <form>-Tag with a
GET-Method.  C<cform> ("complex form") does the same, but sets method to
POST. Finally, C<multipart_form> is the same as C<cform>, but sets the
encoding-type to "multipart/form-data". The latter data is I<not> parsed
by PApp, you will have to call parse_multipart_form (see below)
when evaluating the form data.

All of these functions except endform accept an initial hashref with
additional attributes (see L<PApp::HTML>), e.g. to set the name attribute
of the generated form elements.

Endform returns a closing </form>-Tag, and I<must> be used to close forms
created via C<sform>/C<cform>/C<multipart_form>.

=cut

sub sform(@) {
   local $surlstyle = _SURL_STYLE_PLAIN;
   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>";
}

=item parse_multipart_form \&callback;

Parses the form data that was encoded using the "multipart/form-data"
format. Returns true when form data was present, false otherwise.

For every parameter, the callback will be called with four
arguments: Handle, Name, Content-Type, Content-Type-Args,
Content-Disposition (the latter two arguments are hash-refs, with all keys
lowercased).

If the callback returns true, the remaining parameter-data (if any) is
skipped, and the next parameter is read. If the callback returns false,
the current parameter will be read and put into the C<%P> hash. This is a
no-op callback:

   sub my_callback {
      my ($fh, $name, $ct, $cta, $cd) = @_;
      my $data;
      read($fh, $data, 99999);
      if ($ct =~ /^text\/i) {
         my $charset = lc $cta->{charset};
         # do conversion of $data
      }
      (); # do not return true
   }

The Handle-object given to the callback function is actually an object of
type PApp::FormBuffer (see L<PApp::FormBuffer>). It will
not allow you to read more data than you are supposed to. Also, remember
that the C<READ>-Method will return a trailing CRLF even for data-files.

HINT: All strings (pathnames etc..) are probably in the charset specified
by C<$state{papp_lcs}>, but maybe not. In any case, they are octet
strings so watch out!

=cut

# 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);
      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;
}

=item PApp::flush [not exported by default]

Send generated output to the client and flush the output buffer. There is
no need to call this function unless you have a long-running operation
and want to partially output the page. Please note, however, that, as
headers have to be output on the first call, no headers (this includes the
content-type and character set) can be changed after this call. Also, you
must not change any state variables or any related info after this call,
as the result might not get saved in the database, so you better commit
everything before flushing and then just continue output (use GET or POST
to create new links after this).

Flushing does not yet harmonize with output stylesheet processing, for the
semi-obvious reason that PApp::XSLT does not support streaming operation.

BUGS: No links that have been output so far can be followed until the
document is finished, because the neccessary information will not reach
the disk until the document.... is finished ;)

=cut

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;
}

=item PApp::set_output ($data) [not exported by default]

Clear the output so far and set it to C<data>. This only clears committed
output, not any partial output within C<capture> blocks.

=cut

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

=item PApp::send_upcall BLOCK

Immediately stop processing of the current application and call BLOCK,
which is run outside the handler compartment and without state or other
goodies (like redirected STDOUT). It has to return one of the status codes
(e.g. &PApp::OK). Never returns.

If you want to output something in an upcall, try to use this sequence:

   abort_with {
      content_type "text/html";
      $request->status ("401");
      $request->header_out ("WWW-Authenticate" => "Basic realm=\"$realm\"");
      PApp::set_output "...";
      PApp::flush;
   };

You should never need to call this function directly, rather use
C<internal_redirect> and other functions that use upcalls to do their
work.

=cut

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

=item redirect url

=item internal_redirect url

Immediately redirect to the given url. I<These functions do not
return!>. C<redirect_url> creates a http-302 (Page Moved) response,
changing the url the browser sees (and displays). C<internal_redirect>
redirects the request internally (in the web-server), which is faster, but
the browser might or might not see the url change.

=cut

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 };
}

=item abort_to surl-args

Similar to C<internal_redirect>, but filters the arguments through
C<surl>. This is an easy way to switch to another module/webpage as a kind
of exception mechanism. For example:

 my ($name, ...) = sql_fetch "select ... from game where id = ", $S{gameid};
 abort_to "games_overview" unless defined $name;

This is used in the module showing game details. If it doesn't find the
game it just aborts to the overview page with the list of games.

=cut

sub abort_to {
   internal_redirect &surl;
}

=item abort_with BLOCK

Abort processing of all modules and execute BLOCK in an upcall (See
L<send_upcall> for limitations on the environment) and never return. This
function is handy when you are deeply nested inside a module stack but
want to output your own page (e.g. a file download). Example:

 abort_with {
    content_type "text/plain";
    echo "This is the only line ever output";
 };

=cut

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

=item PApp::abort_with_file *FH [, content-type]

Abort processing of the current module stack, set the content-type header
to the content-type given and sends the file given by *FH to the client.
No cleanup-handlers or similar functions will get called and the function
does of course not return. This function does I<not> call close on the
filehandle, so if you want to have the file closed after this function
does its job you should not leave references to the file around.

=cut

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 set_cookie {
   $request->header_out (
      'Set-Cookie',
      "PAPP_1984="
      . (PApp::X64::enc $cipher_e->encrypt(pack "VVVV", $userid, 0, 0, $state{papp_cookie}))
      . "; PATH=/; EXPIRES="
      . unixtime2http($NOW + $cookie_expires, "cookie")
   );
}

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;
}

=item debugbox

Create a small table with a single link "[switch debug mode
ON]". Following that link will enable debugigng mode, reload the current
page and display much more information (%state, %P, %$papp and the request
parameters). Useful for development. Combined with the admin package
(L<macro/admin>), you can do nice things like this in your page:

 #if admin_p
   <: debugbox :>
 #endif

=cut

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>";
}

=item language_selector $translator [, $current_langid]

Create (and output) html code that allows the user to select one of the
languages reachable through the C<$translator>. If C<$current_langid> is
missing, uses $PApp::langs to select a suitable candidate.

This function is slightly out-of-place in the PApp module and might move
to a more appropriate place in the future.

Usually used like this:

   <:language_selector $papp_translator:>

If you want to build your own language selector, here's how:

   # iterate over all languages supported by this translator
   for my $lang ($translator->langs) {

      # translate the language id into the vernacular language name
      my $name = PApp::I18n::translate_langid($lang, $lang);

      if ($lang eq $current) {
         # this is the currently selected language...
         echo "[$name]";
      } else {
         # or a language we could switch to
         echo slink "[$name]", SURL_SET_LOCALE($lang);
      }

   }

=cut

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>";
      }
   }
   
}

=item preferences_url

Returns the url which, when selected, will guide the user to the papp
preferences editor.

=item preferences_link

Creates an html-button (actually just A HREF at the moment) which guides
the user to the papp preferences editor.

=cut

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] =~ /^(.*)\/([^\/]*)$/;
}

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

=item reload_p

Return the count of reloads, i.e. the number of times this page
was reloaded (which means the session was forked).

This is a relatively costly operation (a database access), so do not do it
by default, but only when you need it.

=cut

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

=item getpref $key

Return the named user-preference variable (or undef, when the variable
does not exist) for the current application.

User preferences can be abused for other means, like timeout-based session
authenticitation. This works, because user preferences, unlike state
variables, change their values simultaneously in all sessions.

See also L<PApp::Prefs>.

=item setpref $key, $value

Set the named preference variable. If C<$value> is C<undef>, then the
variable will be deleted. You can pass in (serializable) references.

See also L<PApp::Prefs>.

=cut

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;
      }
   }
}

=item save_prefs

Save the preferences for all currently loaded applications.

=cut

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);
}

=item switch_userid $newuserid

Switch the current session to a new userid. This is useful, for example,
when you do your own user accounting and want a user to log-in. The new
userid must exist, or bad things will happen, with the exception of userid
zero, which sets the current user to the anonymous user (userid zero)
without changing anything else.

=cut

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
   }
}

=item $userid = PApp::newuid

Create a new (anonymous) user id.

=item $userid = getuid

Return a user id, allocating it if necessary (i.e. if the user has no
unique id so far). This can be used to force usertracking, just call
C<getuid> in your C<newuser>-callback. See also C<$userid> to get the
current userid (which might be zero).

=cut

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];
   }
};

=item PApp::config_eval BLOCK

Evaluate the block and call PApp->config_error if an error occurs. This
function should be used to wrap any perl sections that should NOT keep
the server from starting when an error is found during configuration
(e.g. Apache <Perl>-Sections or the configuration block in CGI
scripts). PApp->config_error is overwritten by the interface module and
should usually do the right thing.

=cut

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 $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 ($request->header_in('Cookie') =~ /PAPP_1984=([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;

=back

=head1 SEE ALSO

The C<macro/admin>-package in the distribution, the demo-applications
(.papp-files).

=head1 AUTHOR

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

=cut