PApp
view release on metacpan or search on metacpan
- renamed PApp::DataRef parameter force_utf8 to utf8.
- the xs part (surl & friends) did not always honour magic.
- ef_submit did not like the value argument.
- bugworkaround in escape_uri actually had a neccessary side-effect.
- poedit now allows editing of the current display charset.
- ef_checkbox now sets the ref correctly to undef or 1.
- SURL_POP etc. now work on references again.
- implemented ef_radio.
- updated PApp::User for the new lazy-uid-allocation scheme.
- renamed PApp::userid to getuid, exported PApp::User::userid.
- PApp::Application::run did not properly call load_prefs.
- properly downgrade to (fake) "iso-8859-1" when sending binary data.
- some modifications to allow for lazy allocation of userid
and sessionid, as well as hashed stateid allocation.
- minor cleanups in PApp/HTML, implemented selectbox, documented tag.
- fixed nosession handling (& more), removed some dead cows.
- fixing Config.pm.PL for users who use gid 0 with papp.
- removing prefix.psql from kis.papp.
- <language> now deprecated.
- renamed grp.longdesc to grp.comment.
- implemented <nosession> element. should be rewritten using namespaces
- fixed method discard, new method dirty for PApp::DataRef.
- added bin/papp-admin.
- apps/admin improved.
- app.config is now used directly in the new PApp::Application call,
so things like database can be set via the config mechanism.
- %state is now no longer destroyed but rather freed, so
DESTROY will not be called for objects in %state, if they
are saved into the satet database. This is expected, I think.
- PApp::XSLT now supports dynamic scheme handlers.
- moved from Compress::LZV1 to Compress::LZF, please do:
update user set prefs=""; delete from state;
or edit PApp.pm and replace LZF by LZV1.
- fixed PApp::HTML::radio/checkbox.
- fixed ef_relation to support where arguments again.
- 5.5-ified SQL/SQL.xs.
- argl, form-headers are now treated as bytes.
- greatly improved (and fixed) ef_file [untested ;-].
- charset conversion done for ef_sbegin/ef_cbegin.
- some utf8-support for DataRef::DB_row, for dumb databases.
- PApp::HTML::textarea now outputs additional \n before and
after the text (for normalization).
- added PApp::DataRef.
- added <description> tag to papp, maybe soon followed
by <copyright> and <version>.
- workaround for mod_perl or perl bug that causes the 'bool'ean
value of error messages to be shown instead of their string
value. Funny, might be the same bug as with Storable, but
for totally different reasons ;)
- DataRef'ied macro/editform and the apps that were using it.
- PApp::SQL::*fetch methods call finish on the statement handle,
as does sql_exec in void context.
- load_prefs allows empty prefs settings and doesn't log you
out if the preferences field is empty.
- fixed PApp::Callback::create_callback.
- added experimental preferences field for acedit.
- surl now uses "use bytes" because otherwise.. strange things happen.
- implemented ref-to-coderef special in PApp::XML.
- _really_ commented out #?? in PApp/Parser.
- added more compliation facilities to PApp::XML.
- implemented "delayed" option which is handy for debugging
(improves server restart speed at the expense of more memory).
- DataRef/use base: worked around an overload bug in perl.
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";
}
$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
)],
);
};
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 ) }
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]
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>.
=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
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
} 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) {
PApp/Config.pm view on Meta::CPAN
my $dbh = shift;
$dbh->do ("set names latin1 collate latin1_nopad_bin");
$PApp::st_fetchstate = $dbh->prepare ("select count, state, userid, previd, sessid from event_count left join state on (id = ?)");
$PApp::st_newstateids = $dbh->prepare ("update state_seq set seq = last_insert_id(seq) + ?");
$PApp::st_insertstate = $dbh->prepare ("replace into state (id, state, userid, previd, sessid, alternative) values (?,?,?,?,?,?)");
$PApp::st_eventcount = $dbh->prepare ("select count from event_count");
$PApp::st_reload_p = $dbh->prepare ("select count(*) from state where previd = ? and alternative = ?");
$PApp::st_newuserid = $dbh->prepare ("update user_seq set seq = last_insert_id(seq) + 1");
$PApp::st_replacepref = $dbh->prepare ("replace into prefs (uid, path, name, value) values (?,?,?,?)");
$PApp::st_deletepref = $dbh->prepare ("delete from prefs where uid = ? and path = ? and name = ?");
$_->($dbh) for values %prepare_papp_dbh;
}
sub new_dbh {
my $id = shift || "papp_1";
PApp::SQL::connect_cached (
$id,
$PApp::statedb,
PApp/Log.pm view on Meta::CPAN
=over 4
=item expire_user $username, $comment
=item expire_state $ctime
=item for_user <BLOCK>;
Add a callback that is called for each user once before she is
removed. The callback is called with (userid, username, comment, prefs),
where C<prefs> is a hash representing the user's preferences in PApp's
internal format which will change anytime.
=item for_state <BLOCK>, [option => value...]
Add a callback that is called for each state (each unique page-view
generates one entry in the state database). The callback is called
with two hashes, the first a hash containing meta information (see below),
the second is just your standard C<%state> hash.
Contents of the meta hash:
PApp/Log.pm view on Meta::CPAN
my $keepstate = $now - ($arg{keepstate} || 86400* 14);
local $DBH = PApp::Config::DBH;
log_state($keepstate);
# update last seen marker.
{
my $st = sql_exec \my($uid, $ctime), "select userid, unix_timestamp(max(ctime)) from state group by userid";
while($st->fetch) {
sql_exec "replace into prefs (uid, path, name, value) values (?, '', 'papp_lastvisit', ?)", $uid, $ctime;
}
}
#blow away old states (sessions in fact)
{
my @delstates = sql_fetchall "select sessid from state group by sessid having max(ctime) < from_unixtime(?)", $keepstate;
scalar @delstates && sql_exec "delete from state where sessid in (".join( ",", @delstates).")";
}
#expire users...
$st = sql_exec \my($uid, $visited, $known), "select uid, value,max(grpid) from prefs left join usergrp on (uid=userid) where path='' and name='papp_lastvisit' group by uid";
while($st->fetch) {
$known ||= 0;
next if $visited >= ($known ? $keepreguser : $keepuser);
sql_exec "delete from prefs where uid = ?", $uid;
sql_exec "delete from usergrp where userid = ?", $uid if $known;
}
}
=item log_state
Run through the whole state database (not the user database) and log all
state entries that have not been logged before. This is not (yet) atomic,
so do not call this function concurrently.
PApp/Prefs.pm view on Meta::CPAN
use PApp::SQL;
use PApp::Exception qw(fancydie);
use PApp::Callback ();
use PApp::Config qw(DBH $DBH); DBH;
use base Exporter;
$VERSION = 2.4;
@EXPORT = qw(
lockprefs
);
use Convert::Scalar ();
=head2 Functions
=over 4
=item lockprefs { BLOCK }
Execute the given block while the user preferences table is locked against
changes from other processes. Needless to say, the block should execute as
fast as possible. Returns the return value of BLOCK (which is called in
scalar context).
=cut
sub lockprefs(&) {
sql_fetch $DBH, "select get_lock('PAPP_PREFS_LOCK_PREFS', 60)"
or fancydie "PApp::Prefs::lockprefs: unable to aquire database lock";
my $res = eval { $_[0]->() };
{
local $@;
sql_exec $DBH, "select release_lock('PAPP_PREFS_LOCK_PREFS')";
}
die if $@;
$res;
}
=back
=head2 Methods
=over 4
=item $prefs = new PApp::Prefs [$pathref]
Creates a new PApp::Prefs object for the given application path. A
reference to the path variable must be passed in, so that changes in the
path can be tracked by the module.
=cut
sub new {
bless { path => $_[1] }, $_[0];
}
=item $prefs->get($key)
Return the named user-preference variable (or undef, when the variable
does not exist).
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.
=item $prefs->set($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.
=item $ref = $prefs->ref($key)
Return a reference to the preferences value (i.e. a L<PApp::DataRef>
object). Updates to the referee will be seen by all processes.
=item $prefs->user_get($uid, $key)
=item $prefs->user_set($uid, $key, $value)
=item $prefs->user_ref($uid, $key)
These functions work like their counterparts without the C<user_>-prefix, but allow you
to specify the userid you want to query.
=cut
sub user_get($$$) {
my ($prefs, $uid, $key) = @_;
utf8::upgrade ($prefs = ${$prefs->{path}});
utf8::upgrade $key;
sthaw sql_fetch $DBH, "select value from prefs where uid = ? and path = ? and name = ?",
$uid, $prefs, $key
}
sub user_set($$$;$) {
if (defined $_[2]) {
$PApp::st_replacepref->execute($_[1], ${$_[0]{path}}, Convert::Scalar::utf8_upgrade "$_[2]",
sfreeze_cr $_[3]);
} else {
$PApp::st_deletepref->execute($_[1], ${$_[0]{path}}, Convert::Scalar::utf8_upgrade "$_[2]");
}
}
sub user_ref($$$) {
require PApp::DataRef;
\(new PApp::DataRef 'DB_row',
database => $PApp::Config::Database,
table => "prefs",
key => [qw(uid path name)],
id => [$_[1], ${$_[0]{path}}, $_[2]],
utf8 => 1,
)->{
["value", PApp::DataRef::DB_row::filter_sfreeze_cr]
};
}
sub get($$) {
$_[0]->user_get($PApp::userid, $_[1]);
}
sub set($$;$) {
$_[0]->user_set($PApp::userid, $_[1], $_[2]);
}
sub ref($$) {
$_[0]->user_ref($PApp::userid, $_[1]);
}
=item @uids = $prefs->find_value($key, $value)
Return all user ids for which the named key has the given value.
Useful for login-type functions where you look for all users with a
specific value for the "username" key or similar.
=cut
sub find_value($$$) {
sql_ufetchall $DBH, "select uid from prefs where path = ? and name = ? and value = ?",
${$_[0]{path}}, $_[1], $_[2];
}
=back
=head1 SEE ALSO
L<PApp>, L<PApp::User>.
=head1 AUTHOR
PApp/UserObs.pm view on Meta::CPAN
Check wether the current user is already known in the access
database. Returns his username (login) if yes, and C<undef> otherwise.
If the optional argument C<access> is given, it additionally checks wether
the user has the given access right (even if not logged in).
=cut
sub known_user_p(;$) {
my $user = $PApp::prefs->get("papp_username");
if (@_) {
(sql_exists $DBH, "usergrp where userid = ? and grpid = ?",
$userid, grpid shift) ? $user : undef;
} else {
$user;
}
}
=item update_username [$userid, ]$user
Change the login-name of the current user (or the user with id $userid)
to C<$user> and return the userid. If another user of that name already
exists, do nothing and return C<undef>. (See C<choose_username>).
=cut
sub update_username($;$) {
my $uid = @_ > 1 ? shift : getuid;
my $user = Convert::Scalar::utf8_upgrade "$_[0]";
lockprefs {
if ($PApp::prefs->find_value(papp_username => $user)) {
undef $uid;
} else {
$PApp::prefs->user_set($uid, papp_username => $user);
}
};
$uid;
}
=item choose_username $stem
Guess a more-or-less viable but very probable unique username from the
stem given. To create a new username that is unique, use something like
this pseudo-code:
PApp/UserObs.pm view on Meta::CPAN
$username = choose_username $username
done
=cut
sub choose_username($) {
my $stem = $_[0];
my $id;
for(;;) {
my $user = Convert::Scalar::utf8_upgrade $stem.$id;
if (!$PApp::prefs->find_value(papp_username => $user)) {
return $user;
}
$id += 1 + int rand 20;
}
}
=item update_password $pass
Set the (non-crypted) password of the current user to C<$pass>. If
C<$pass> is C<undef>, the password will be deleted and the user cannot
PApp/UserObs.pm view on Meta::CPAN
password, which is just that: a valid password with length zero.
=cut
sub update_password($) {
my ($pass) = @_;
Convert::Scalar::utf8_off Convert::Scalar::utf8_upgrade "$pass";
$pass = defined $pass
? crypt $pass, join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]
: "";
$PApp::prefs->set(papp_password => $pass);
}
=item update_comment $comment
Change the comment field for the current user by setting it to C<$comment>.
=cut
sub update_comment($) {
$PApp::prefs->set(papp_comment => $_[0]);
}
=item username [$userid]
Return the username of the user with id C<$userid> or of the current user,
if no arguments are given.
=cut
sub username(;$) {
$PApp::prefs->user_get(@_ ? $_[0] : $userid, "papp_username");
}
=item userid $username
Return the userid associated with the given user.
=cut
sub userid($) {
$PApp::prefs->find_value(papp_username => $_[0]);
}
=item $uid = user_create
Creates a new anonymous user and returns her user-id.
=cut
sub user_create() {
$PApp::st_newuserid->execute;
sql_insertid $PApp::st_newuserid;
}
=item user_login $userid[, $level]
Log out the current user, switch to the userid C<$userid> and
UNCONDITIONALLY FETCH ACCESS RIGHTS FROM THE USER DB. For a safer
interface using a password, see C<verify_login>.
If the C<$userid> is zero creates a new user without any access rights but
keeps the state otherwise unchanged. You might want to call C<save_prefs>
to save the user preferences (for the current application only, the other
preferences currently are discarded).
The C<$level> argument can be used to differentiate between various
levels of certainty (1 == http-password, 3 = tls-password, 4 =
tls-certificate). The default is 1.
=cut
sub user_login($;$) {
PApp/UserObs.pm view on Meta::CPAN
Deletes the given userid from the system, i.e. the user with the given ID
can no longer log-in or do useful things. Other sessions using this userid
will get errors, so don't use this function lightly.
=cut
sub user_delete(;$) {
my $uid = shift || getuid;
user_login 0 if $userid == $uid;
sql_exec $DBH, "delete from usergrp where userid = ?", $uid;
sql_exec $DBH, "delete from prefs where uid = ?", $uid;
}
=item verify_login $user, $pass
Try to login as user $user, with pass $pass. If the password verifies
correctly, switch the userid (if necessary), add any access rights and
return true. Otherwise, return false and do nothing else.
Unlike the unix password system, empty password fields (i.e. set to undef)
never log-in successfully using this function.
=cut
sub verify_login($$) {
my ($user, $pass) = @_;
Convert::Scalar::utf8_off Convert::Scalar::utf8_upgrade "$pass";
my $userid = userid $user;
if ($userid) {
my $xpass = $PApp::prefs->user_get($userid, "papp_password");
Convert::Scalar::utf8_off $xpass;
if ($xpass ne "" and $xpass eq crypt $pass, substr($xpass,0,2)) {
user_login $userid;
return 1;
}
}
sleep 1;
return 0;
}
PApp itself does not create databases or tables, you must do this
yourself. The papp-install script tries to create the necessary
database and tables, but this extension to DBI is currently only
supported by very few databases (e.g. MySQL), so you have to
either use mysql for papp itself or read the table definitions and
create corersponding tables yourself. Pre-made configs for various
databases are on their way.
A special note is required for the state, user and pkg tables:
These tables store raw binary data in the state/prefs field
respectively. Both of these are usually smaller than 4k (this
depends mainly on the size of the state and user preferences you
need), so most databases can use TEXT/BLOB/IMAGE fields for them.
PApp will not try to "update" the state field, but it will try to
update the "prefs" field which is a problem for some databases.
PApp requires the sql_insertid function, so have a look at the
additional requirements of PApp::SQL below.
PApp::DataRef:
PApp::DataRef uses "harmless" select and update statements to
read/write existing table rows. When creating new rows and
insertid is "1", it will insert the row with the primary key set
to NULL and expect it to create a new row and therefore requires
bin/papp-admin view on Meta::CPAN
printf "%4s %-15s %-59.59s\n", "GID", "NAME", "COMMENT";
while ($st->fetch) {
printf "%4s %-15s %-59.59s\n", $id, $name, $desc;
}
}
sub list_users {
my $st = sql_exec
\my($id),
"select uid from prefs
where path = '' and name = 'papp_username'
and value like ?
order by 1",
$_[0];
printf "%4s %-9s %s\n", "UID", "NAME", "COMMENT";
while ($st->fetch) {
printf "%4s %-9s %s\n",
$id,
(username $id),
$PApp::prefs->user_get($id, "papp_comment");
}
}
sub parsetime {
my $time = shift;
$time =~ m{^\s*(\d+)([smhdDMyY]?)\s*$}
or die "$time: unparseable time value\n";
return $1 * 60 * 60 * 24 * 365.2425 if $2 eq "y" or $2 eq "Y";
return $1 * 60 * 60 * 24 * 30.436875 if $2 eq "M";
papp-install view on Meta::CPAN
sql_exec <<SQL;
create table /*! if not exists */ session (
sid int(10) unsigned not null default '0',
name varchar(255) binary not null default '',
value mediumblob not null,
unique key id (sid,name(200))
) $create_options
SQL
sql_exec <<SQL;
create table /*! if not exists */ prefs (
uid int(10) unsigned not null default '0',
path varchar(255) binary not null default '',
name varchar(255) binary not null default '',
value mediumblob not null,
unique key id (path(140),name(100),uid)
) $create_options
SQL
if ($mode_update && $installed_version < 0.142) {
eval {
my $st = sql_exec \my($userid, $prefs, $user, $pass, $comment),
"select id, prefs, user, pass, comment from user";
print "Converting user preferences data to new format";
while ($st->fetch) {
print ".";
if ($user ne "") {
sql_exec "replace into prefs (uid, path, name, value) values (?,'',?,?)",
$userid, "papp_username", sfreeze_cr $user;
}
if ($pass ne "") {
sql_exec "replace into prefs (uid, path, name, value) values (?,'',?,?)",
$userid, "papp_password", sfreeze_cr $pass;
}
if ($comment ne "") {
sql_exec "replace into prefs (uid, path, name, value) values (?,'',?,?)",
$userid, "papp_comment", sfreeze_cr $comment;
}
if ($prefs ne "") {
$prefs = PApp::Storable::thaw decompress $prefs;
while (my ($path, $keys) = each %$prefs) {
next unless %$keys;
sql_exec $DBH, "replace into prefs (uid, path, name, value) values (?,?,?,?)",
$userid, $path, "papp_prefs",
compress PApp::Storable::nfreeze($keys);
}
}
}
print " done.\n";
};
}
if ($mode_update && $installed_version < 0.21) {
papp-install view on Meta::CPAN
sql_exec "drop table /*! if exists */ obj_attr";
}
sql_exec <<SQL;
create table /*! if not exists */ user_seq (
seq int(10) unsigned not null
) $create_options
SQL
unless (sql_fetch "select count(*) from user_seq") {
sql_exec "insert into user_seq values (?)", 0+sql_fetch "select max(uid) + 1 from prefs";
}
$DBH->do("drop table user") if $mode_update && $installed_version < 0.142;
$DBH->do("alter table grp add comment text not null") if $mode_update && $installed_version < 0.124;
$DBH->do("alter table grp add unique key (name)") if $mode_update && $installed_version < 0.124;
$DBH->do("alter table grp change name name varchar(160) not null") if $mode_update && $installed_version < 0.14;
sql_exec <<SQL;
create table /*! if not exists */ grp (
papp-install view on Meta::CPAN
EOF
if ($mode_init) {
$DBH->do("insert into appset values (1, 'default')")
or warn "unable to create 'default' appset: $DBI::errstr\n";
print "creating admin user and admin group... ";
eval {
my $pass = crypt "public", "xx";
$DBH->do("insert into prefs values (1, '', 'papp_username', 'admin')")
and $DBH->do("insert into prefs values (1, '', 'papp_password', '$pass')")
and $DBH->do("insert into prefs values (1, '', 'papp_comment', 'Main Administrator')")
and $DBH->do("insert into grp values (1, 'admin' , 'hyperuser access rights')")
and $DBH->do("insert into grp values (2, 'poedit' , 'general translator access')")
and $DBH->do("insert into grp values (3, 'poedit_*' , 'translator access for all apps')")
and $DBH->do("insert into grp values (4, 'poedit_papp', 'translator access for papp itself')")
and $DBH->do("insert into usergrp values (1, 1)")
and $DBH->do("insert into usergrp values (1, 2)")
and $DBH->do("insert into usergrp values (1, 3)")
or die;
print <<EOF;
ok
( run in 2.550 seconds using v1.01-cache-2.11-cpan-8f98c5d2c55 )