PApp
view release on metacpan or search on metacpan
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::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 = 2.4;
use base Exporter::;
our @EXPORT = qw(
debugbox
surl slink sform cform suburl sublink retlink_p returl retlink
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 $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::surl;
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 %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 $curconf; # the current configuration hash
our $request; # the apache request object
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 *location; # 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 $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 %P [read-write, input only]
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 sanitised before use.
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 $PApp::location [read-only] [not exported] [might get replaced by a function call]
The location value from C<mount>.
=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)
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 $url = surl arg => value, ...
C<surl> is one of the most often used functions to create urls. The
arguments are parameters that are passed to the application. Unlike
GET or POST-requests, these parameters are directly passed into the
C<%state>-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 an absolute path under
unix. Examples:
/papp_locale $state{papp_locale}
/tt/var $state{'/tt'}{var} -OR- $S{var} in application /tt
/tt/mod1/var $state{'/tt'}{'/mod1'}{var}
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) = @_;
=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 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;
}
}
=item PApp::flush_state
Save state to disk. USeful when using C<PApp::flush> to create the page
incrementally, to make links valid. Even when the end of page has not been reached.
=cut
sub flush_state() {
$st_insertstate->execute ($stateid,
compress PApp::Storable::mstore (\%state),
$userid, $prevstateid, $sessionid, $alternative)
if @{$state{papp_alternative}};
}
sub update_state() {
%arguments = ();
flush_state;
&_destroy_state; # %P = %state = (), but in a safe way
undef $stateid;
}
################################################################################################
sub warnhandler {
my $msg = $_[0];
PApp->warn ("Warning[$$]: $msg");
}
}
$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}", "possible session tampering detected";
} 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 : {}; #d#
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;
# 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 $@;
( run in 1.822 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )