App-Context
view release on metacpan or search on metacpan
lib/App/Context.pm view on Meta::CPAN
Currently, this is primarily for database connections.
For most databases, the child needs its own connection.
=cut
sub fork {
&App::sub_entry if ($App::trace);
my ($self) = @_;
my $pid = fork();
if (!$pid) { # in the child process
# $self->{is_child} = 1; # I might need to add this sometime, but not now
$self->shutdown_unshareable_resources();
}
else {
$self->log({level=>4},"Child $pid started.\n");
}
&App::sub_exit($pid) if ($App::trace);
return($pid);
}
sub exit {
my ($self, $exitval) = @_;
$self->shutdown();
exit($exitval);
}
#############################################################################
# shutdown_unshareable_resources()
#############################################################################
=head2 shutdown_unshareable_resources()
* Signature: $self->shutdown_unshareable_resources()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$self->shutdown_unshareable_resources();
The shutdown_unshareable_resources() method is called in a child process just after
it has been fork()ed.
This causes connections to databases, etc. to be closed gracefully and new
connections to be created if necessary.
Call this after a fork() in the child process.
It will shutdown_unshareable which cannot be shared between a parent and
a child process.
Currently, this is primarily for database connections.
For most databases, the child needs its own connection.
=cut
sub shutdown_unshareable_resources {
my $self = shift;
my ($conf, $repdef, $repname, $instance);
my ($class, $method, $args, $argidx, $repcache);
$self->dbgprint("Context->shutdown_unshareable_resources()")
if ($App::DEBUG && $self->dbg(1));
$repcache = $self->{session}{cache}{Repository};
if (defined $repcache && ref($repcache) eq "HASH") {
foreach $repname (keys %$repcache) {
$instance = $repcache->{$repname};
$instance->_shutdown_unshareable_resources();
delete $repcache->{$repname};
}
}
}
#############################################################################
# shutdown()
#############################################################################
=head2 shutdown()
The shutdown() method is called when the Context is preparing to exit.
This allows for connections to databases, etc. to be closed gracefully.
* Signature: $self->shutdown()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$self->shutdown();
=cut
sub shutdown {
my ($self, $end_cd) = @_;
my ($conf, $repdef, $repname, $instance);
my ($class, $method, $args, $argidx, $repcache);
if (!$self->{shutdown_complete}) {
my $options = $self->{options};
my $profiler = $options->{"app.Context.profiler"};
if ($profiler) {
$self->profile_stop("main");
$self->finish_profiler_log($end_cd);
}
$self->dbgprint("Context->shutdown()")
if ($App::DEBUG && $self->dbg(1));
$repcache = $self->{session}{cache}{Repository};
if (defined $repcache && ref($repcache) eq "HASH") {
foreach $repname (keys %$repcache) {
$instance = $repcache->{$repname};
$self->dbgprint("Context->shutdown(): $instance->_disconnect()")
if ($App::DEBUG && $self->dbg(1));
$instance->_disconnect();
delete $repcache->{$repname};
}
}
$self->{shutdown_complete} = 1;
}
}
sub DESTROY {
my ($self) = @_;
$self->shutdown("D");
}
#############################################################################
# response()
#############################################################################
=head2 response()
* Signature: $context->response()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->response();
The response() method gets the current Response being handled in the Context.
=cut
sub response {
&App::sub_entry if ($App::trace);
my $self = shift;
my $response = $self->{response};
if (!defined $response) {
lib/App/Context.pm view on Meta::CPAN
# Mem: 525942784 468914176 57028608 0 69124096 51593216
# Swap: 1069268992 56954880 1012314112
# MemTotal: 513616 kB
# MemFree: 55692 kB
# MemShared: 0 kB
# Buffers: 67504 kB
# Cached: 42328 kB
# SwapCached: 8056 kB
# Active: 171720 kB
# ActiveAnon: 88224 kB
# ActiveCache: 83496 kB
# Inact_dirty: 22032 kB
# Inact_laundry: 3120 kB
# Inact_clean: 5572 kB
# Inact_target: 40488 kB
# HighTotal: 0 kB
# HighFree: 0 kB
# LowTotal: 513616 kB
# LowFree: 55692 kB
# SwapTotal: 1044208 kB
# SwapFree: 988588 kB
# /proc/loadavg
# 0.02 0.12 0.15 1/138 30412
# This only works on Linux (as far as I know)
sub get_sys_info {
my ($self) = @_;
my $info = {};
# print "FILE: /proc/meminfo\n";
if (open(App::Context::FILE, "/proc/meminfo")) {
while (<App::Context::FILE>) {
if (/^([A-Za-z]+):\s*([0-9]+)/) {
$info->{lc($1)} = $2;
# print ">>> $1 = $2\n";
}
}
close(App::Context::FILE);
}
# print "FILE: /proc/loadavg\n";
if (open(App::Context::FILE, "/proc/loadavg")) {
while (<App::Context::FILE>) {
if (/^([0-9.]+)\s+([0-9.]+)\s+([0-9.]+)\s+([0-9]+)\/([0-9]+)\s+([0-9]+)/) {
$info->{load} = $1;
$info->{load5} = $2;
$info->{load15} = $3;
$info->{runprocs} = $4;
$info->{nprocs} = $5;
$info->{unknown} = $6;
# print ">>> [$1][$2][$3][$4][$5][$6]\n";
}
}
close(App::Context::FILE);
}
return($info);
}
# /proc/$$/status
# Name: ksh
# State: S (sleeping)
# Tgid: 29147
# Pid: 29147
# PPid: 29146
# TracerPid: 0
# Uid: 102 102 102 102
# Gid: 205 205 205 205
# FDSize: 32
# Groups: 205 201 202 214 3000 203 217
# VmSize: 1624 kB
# VmLck: 0 kB
# VmRSS: 608 kB
# VmData: 124 kB
# VmStk: 12 kB
# VmExe: 176 kB
# VmLib: 1292 kB
# SigPnd: 0000000000000000
# SigBlk: 0000000000000000
# SigIgn: 8000000000380000
# SigCgt: 0000000000016007
# CapInh: 0000000000000000
# CapPrm: 0000000000000000
# CapEff: 0000000000000000
sub get_proc_info {
my ($self, @pids) = @_;
@pids = ($$) if ($#pids == -1);
my ($pid, $proc);
my $procs = {};
foreach $pid (@pids) {
$proc = {};
$procs->{$pid} = $proc;
# print "FILE: /proc/$$/status\n";
if (open(App::Context::FILE, "/proc/$$/status")) {
while (<App::Context::FILE>) {
if (/^Vm([A-Za-z]+):\s*([0-9]+)/) {
$proc->{lc($1)} = $2;
}
}
close(App::Context::FILE);
$proc->{text} = $proc->{exe} + $proc->{lib};
}
else {
$self->log("ERROR: Can't open /proc/$$/status: $!");
}
}
return($procs);
}
# http://www.comptechdoc.org/os/linux/howlinuxworks/linux_hlproc.html
#stat - Status information about the process used by the ps(1) command. Fields are:
# 31137 (bash) S 19885 31137 31137 34841 651 0 1450
# 185030 316 14024 1 3 687 715 14 0 0
# 0 1792102651 4403200 361 4294967295 134512640 135217536 3221217344 3221216648 1074425592
# 0 65536 3686404 1266761467 3222400107 0 0 17 2
# 1. pid - Process id
# 2. comm - The executable filename
# 3. state - R (running), S(sleeping interruptable), D(sleeping), Z(zombie), or T(stopped on a signal).
# 4. ppid - Parent process ID
# 5. pgrp - Process group ID
# 6. session - The process session ID.
# 7. tty - The tty the process is using
# 8. tpgid - The process group ID of the owning process of the tty the current process is connected to.
# 9. flags - Process flags, currently with bugs
# 10. minflt - Minor faults the process has made
# 11. cminflt - Minor faults the process and its children have made.
# 12. majflt
# 13. cmajflt
# 14. utime - The number of jiffies (processor time) that this process has been scheduled in user mode
# 15. stime - in kernel mode
# 16. cutime - This process and its children in user mode
# 17. cstime - in kernel mode
# 18. counter - The maximum time of this processes next time slice.
# 19. priority - The priority of the nice(1) (process priority) value plus fifteen.
# 20. timeout - The time in jiffies of the process's next timeout.
# 21. itrealvalue - The time in jiffies before the next SIGALRM is sent to the process because of an internal timer.
# 22. starttime - Time the process started after system boot
# 23. vsize - Virtual memory size
# 24. rlim - Current limit in bytes of the rss of the process.
# 25. startcode - The address above which program text can run.
# 26. endcode - The address below which program text can run.
# 27. startstack - The address of the start of the stack
# 28. kstkesp - The current value of esp for the process as found in the kernel stack page.
# 29. kstkeip - The current 32 bit instruction pointer, EIP.
# 30. signal - The bitmap of pending signals
# 31. blocked - The bitmap of blocked signals
# 32. sigignore - The bitmap of ignored signals
# 33. sigcatch - The bitmap of catched signals
# 34. wchan - The channel in which the process is waiting. The "ps -l" command gives somewhat of a list.
sub get_proc_info2 {
my ($self, @pids) = @_;
@pids = ($$) if ($#pids == -1);
my ($pid, $proc);
my $procs = {};
foreach $pid (@pids) {
$proc = {};
$procs->{$pid} = $proc;
# print "FILE: /proc/$$/status\n";
if (open(App::Context::FILE, "/proc/$$/stat")) {
my $line = <App::Context::FILE>;
my @f = split(/ +/, $line);
close(App::Context::FILE);
$proc->{cutime} = $f[15];
$proc->{cstime} = $f[16];
$proc->{vsize} = $f[22];
}
else {
$self->log("ERROR: Can't open /proc/$$/stat: $!");
}
}
return($procs);
}
1;
( run in 1.227 second using v1.01-cache-2.11-cpan-ceb78f64989 )