PApp

 view release on metacpan or  search on metacpan

Agni.pm  view on Meta::CPAN

sub staging_path_p($) {
   $pathname[$_[0]] =~ m{/staging/$};
}

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

our $hold_updates;
our @held_updates;

sub hold_updates(&;@) {
   local $hold_updates = $hold_updates + 1;
   eval { &{+shift} };

   # ALWAYS broadcast updates, even if we are deeply nested
   if (@held_updates) {
      local $@;
      PApp::Event::broadcast agni_update => @held_updates;
      @held_updates = ();
   }

Agni.pm  view on Meta::CPAN

      Agni::update @event;
   };

   check_gidseq $force;

   sql_exec "unlock tables";

   die if $@;
}

sub gc_find_instances_by_id(&@) {
   my ($cb, @seed) = @_;

   while (@seed) {
      $cb->(@seed);

      @seed = sql_fetchall
                 "select distinct obj.id
                  from obj
                     inner join d_int on (obj.id = d_int.id and d_int.type = $OID_ISA)
                     inner join obj iobj on (iobj.gid = d_int.data and obj.paths & iobj.paths <> 0)

Agni.pm  view on Meta::CPAN

sub agni_refresh {
   $PApp::NOW = time;
   $PApp::SQL::DBH = PApp::Config::DBH;

   %PApp::temporary = ();

   PApp::Event::check;
}

sub agni_exec(&) {
   my $cb = shift;

   local $PApp::SQL::Database = $PApp::Config::Database;
   local $PApp::SQL::DBH;
   local %PApp::state;
   local %PApp::temporary;

   agni_refresh;

   &$cb;

PApp.pm  view on Meta::CPAN

    }; # close the capture
 :>

=cut

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

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

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

PApp.pm  view on Meta::CPAN

=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, ...

PApp.pm  view on Meta::CPAN

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

PApp.pm  view on Meta::CPAN

      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,

PApp.pm  view on Meta::CPAN

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]

PApp.pm  view on Meta::CPAN

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

PApp/Callback.pm  view on Meta::CPAN

sub new {
   my $self = shift;
   my %attr = @_;

   bless { %$self,
      args => $attr{args} || [],
   }, __PACKAGE__;
}

sub register_callback(&;@) {
   shift if $_[0] eq __PACKAGE__;
   my ($package, $filename, $lineno) = caller;
   my $id;
   my $code = shift;
   my %attr = @_;

   if (ref $code) {
      $id = $attr{name} ? "I$attr{name}" : "A$filename:$lineno";
   } else {
      $code = $package."::$code" unless $code =~ /::/;

PApp/Callback.pm  view on Meta::CPAN

   delete $attr{__do_refer} ? $self->refer : $self;
}

=item create_callback <same arguments as register_callback>

Just like C<register_callback>, but additionally calls C<refer> (see
below) on the result, returning the function reference directly.

=cut

sub create_callback(&;@) {
   push @_, __do_refer => 1;
   goto &register_callback;
}

=item $cb = $func->refer([args...])

Create a callable object (a code reference). The callback C<$cb> can
either be executed by calling the C<call> method or by treating it as a
code reference, e.g.:

PApp/Env.pm  view on Meta::CPAN

=item lockenv BLOCK

Locks the environment table against modifications (this is, again,
only implemented for mysql so far), while executing the specified
block. Returns the return value of BLOCK (which is called in scalar
context).

=cut

sub lockenv(&) {
   sql_fetch $DBH, "select get_lock('PAPP_ENV_LOCK_ENV', 60)"
      or fancydie "PApp::Env::lockenv: unable to aquire database lock";
   my $res = eval {
      local $SIG{__DIE__};
      $_[0]->();
   };
   {
      local $@;
      sql_exec $DBH, "do release_lock('PAPP_ENV_LOCK_ENV')";
   }

PApp/Env.pm  view on Meta::CPAN

with the value as first argument. The code-reference must modify the
argument in-place, e.g.:

   modifyenv { $_[0]++ } "myapp_counter";

The modification will be done atomically. C<modifyenv> returns whatever
the BLOCK returned.

=cut

sub modifyenv(&$) {
   my ($code, $key) = @_;
   my $res;
   lockenv {
      my $val = getenv $key;
      $res = $code->($val);
      setenv $key, $val;
   };
   $res;
}

PApp/Exception.pm  view on Meta::CPAN

when an error occurs. Example:

   try {
      ... code
   } catch {
      ... code to be executed when an exception was raised
   };

=cut

sub try(&;$@) {
   my @r = eval {
      local $SIG{__DIE__} = \&diehandler;
      &{+shift};
   };
   if ($@) {
      die if UNIVERSAL::isa $@, PApp::Upcall::;
      my $err = shift;
      fancydie $err, $@, @_;
   }
   wantarray ? @r : $r[-1];
}

sub catch(&;%) {
   fancydie "catch not yet implemented";
}

=item $exc->errorpage

This method is being called by the PApp runtime whenever there is no handler
for it. It should (depending on the $PApp::onerr variable and others!) display
an error page for the user. Better overwrite the following methods, not this one.

=item $exc->ep_save

PApp/Lock.pm  view on Meta::CPAN

@EXPORT = qw(locked);

=item locked BLOCK name, [timeout, [holdtime]]

Execute the given BLOCK while holding the lock NAME. The lock will be
given up as soon as the block is left. See the C<new> method for the
meaning of the arguments.

=cut

sub locked(&@) {
   my $block = shift;
   $lock = new PApp::Lock @_;
   eval {
      local $SIG{__DIE__} = \&PApp::Exception::diehandler;
      $lock->lock or do {
         require POSIX;
         fancydie "unable to aquire lock", $lock->{name},
                  info => [ breaktime => "The lock expires ".
                            POSIX::strftime("%Y-%m-%d %H:%M:%S %z", localtime $lock->breaktime)],
                  info => [ timeout  => $lock->{timeout} ],

PApp/Prefs.pm  view on Meta::CPAN

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

PApp/Session.pm  view on Meta::CPAN

=item locksession { BLOCK }

Execute the given block while the session 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 locksession(&) {
   sql_fetch $DBH, "select get_lock('PAPP_SESSION_LOCK_SESSION', 60)"
      or fancydie "PApp::Session::locksession: unable to aquire database lock";
   my $res = eval { $_[0]->() };
   {
      local $@;
      sql_exec $DBH, "select release_lock('PAPP_SESSION_LOCK_SESSION')";
   }
   die if $@;
   $res;
}

PApp/Util.pm  view on Meta::CPAN

=head2 Source Filtering

A very primitive form of source filtering can be implemented using
C<filter_add>, C<filter_read> and C<filter_simple>. Better use the
L<Filter> module family, though.

=over 4

=cut

sub filter_simple(&) {
   my $cb = $_[0];
   my $buf;

   sub {
      unless (defined $buf) {
         local $_ = "";
         1 while 0 > ($buf = PApp::Util::filter_read $_[0] + 1, $_, 65536);
         return $buf if $buf < 0;

         &$cb;

bin/papp-admin  view on Meta::CPAN

                              
            --reorganize       reorganize/check various databases, such as the
                               translation messages.

EOF
   exit 0;
}

usage unless @ARGV;

sub call(&@) {
   my ($sub, @args) = @_;
   push @calls, sub { $sub->(@args) };
}

sub clean(&@) {
   my ($sub, @args) = @_;
   push @clean, sub { $sub->(@args) };
}

*verbose = \$PApp::Admin::verbose;

$PApp::SQL::Database = new PApp::SQL::Database "",
                        $PApp::Config{STATEDB},
                        $PApp::Config{STATEDB_USER},
                        $PApp::Config{STATEDB_PASS};