FCGI::ProcManager::Constrained

diff --git a/lib/FCGI/ProcManager/Constrained.pm b/lib/FCGI/ProcManager/Constrained.pm
new file mode 100644 (file)
index 0000000..7bda92e
--- /dev/null
+++ b/lib/FCGI/ProcManager/Constrained.pm
@@ -0,0 +1,205 @@
+package FCGI::ProcManager::Constrained;
+use strict;
+use warnings;
+use Carp qw/ confess /;
+use base 'FCGI::ProcManager';
+use Config;
+our $VERSION = '0.02';
+
+sub new {
+    my $proto = shift;
+    my $self = $proto->SUPER::new(@_);
+    $self->{max_requests} = $ENV{PM_MAX_REQUESTS} || 0 unless defined $self->{max_requests};
+    $self->{sizecheck_num_requests} = $ENV{PM_SIZECHECK_NUM_REQUESTS} || 0 unless defined $self->{sizecheck_num_requests};
+    $self->{max_size} = $ENV{PM_MAX_SIZE} || 0 unless defined $self->{max_size};
+    if ($self->{sizecheck_num_requests} && ! _can_check_size()) {
+        confess "Cannot load size check modules for your platform: sizecheck_num_requests > 0 unsupported";
+    }
+    return $self;
+}
+
+sub max_requests { shift->pm_parameter('max_requests', @_); }
+
+sub sizecheck_num_requests { shift->pm_parameter('sizecheck_num_requests', @_); }
+
+sub max_size { shift->pm_parameter('max_size', @_); }
+
+sub handling_init {
+    my $self = shift;
+    $self->SUPER::handling_init();
+    $self->{_request_counter} = 0;
+}
+
+sub pm_post_dispatch {
+    my $self = shift;
+    if ($self->max_requests > 0 && ++$self->{_request_counter} == $self->max_requests) {
+        $self->pm_exit("safe exit after max_requests");
+    }
+    if ($self->sizecheck_num_requests
+        and $self->{_request_counter} # Not the first request
+        and $self->{_request_counter} % $self->sizecheck_num_requests == 0
+    ) {
+        $self->exit("safe exit due to memory limits exceeded after " . $self->request_count . " requests")
+            if $self->_limits_are_exceeded;
+    }
+    $self->SUPER::pm_post_dispatch();
+}
+
+sub _limits_are_exceeded {
+    my $self = shift;
+
+    my ($size, $share, $unshared) = $self->_check_size();
+
+    return 1 if $self->max_size  && $size > $self->max_size;
+    return 0 unless $share;
+# FIXME
+#    return 1 if $self->min_share_size    && $share < $self->min_share_size;
+#    return 1 if $self->max_unshared_size && $unshared > $self->max_unshared_size;
+
+    return 0;
+}
+
+# The following code is wholesale is nicked from Apache::SizeLimit::Core
+
+sub _check_size {
+    my $class = shift;
+
+    my ($size, $share) = $class->_platform_check_size();
+
+    return ($size, $share, $size - $share);
+}
+
+sub _load {
+    my $mod = shift;
+    eval { require($mod); 1; }
+}
+our $USE_SMAPS;
+BEGIN {
+    my ($major,$minor) = split(/\./, $Config{'osvers'});
+    if ($Config{'osname'} eq 'solaris' &&
+        (($major > 2) || ($major == 2 && $minor >= 6))) {
+        *_can_check_size = sub () { 1 };
+        *_platform_check_size   = \&_solaris_2_6_size_check;
+        *_platform_getppid = \&_perl_getppid;
+    }
+    elsif ($Config{'osname'} eq 'linux' && _load('Linux::Pid')) {
+        *_platform_getppid = \&_linux_getppid;
+        *_can_check_size = sub () { 1 };
+        if (_load('Linux::Smaps') && Linux::Smaps->new($$)) {
+            $USE_SMAPS = 1;
+            *_platform_check_size = \&_linux_smaps_size_check;
+        }
+        else {
+            $USE_SMAPS = 0;
+            *_platform_check_size = \&_linux_size_check;
+        }
+    }
+    elsif ($Config{'osname'} =~ /(?:bsd|aix)/i && _load('BSD::Resource')) {
+        # on OSX, getrusage() is returning 0 for proc & shared size.
+        *_can_check_size = sub () { 1 };
+        *_platform_check_size   = \&_bsd_size_check;
+        *_platform_getppid = \&_perl_getppid;
+    }
+    else {
+        *_can_check_size = sub () { 0 };
+    }
+}
+
+sub _linux_smaps_size_check {
+    my $class = shift;
+
+    return $class->_linux_size_check() unless $USE_SMAPS;
+
+    my $s = Linux::Smaps->new($$)->all;
+    return ($s->size, $s->shared_clean + $s->shared_dirty);
+}
+
+sub _linux_size_check {
+    my $class = shift;
+
+    my ($size, $share) = (0, 0);
+    if (open my $fh, '<', '/proc/self/statm') {
+        ($size, $share) = (split /\s/, scalar <$fh>)[0,2];
+        close $fh;
+    }
+    else {
+        $class->_error_log("Fatal Error: couldn't access /proc/self/status");
+    }
+
+    # linux on intel x86 has 4KB page size...
+    return ($size * 4, $share * 4);
+}
+
+sub _solaris_2_6_size_check {
+    my $class = shift;
+
+    my $size = -s "/proc/self/as"
+        or $class->_error_log("Fatal Error: /proc/self/as doesn't exist or is empty");
+    $size = int($size / 1024);
+
+    # return 0 for share, to avoid undef warnings
+    return ($size, 0);
+}
+
+# rss is in KB but ixrss is in BYTES.
+# This is true on at least FreeBSD, OpenBSD, & NetBSD
+sub _bsd_size_check {
+
+    my @results = BSD::Resource::getrusage();
+    my $max_rss   = $results[2];
+    my $max_ixrss = int ( $results[3] / 1024 );
+
+    return ($max_rss, $max_ixrss);
+}
+
+sub _win32_size_check {
+    my $class = shift;
+
+    # get handle on current process
+    my $get_current_process = Win32::API->new(
+        'kernel32',
+        'get_current_process',
+        [],
+        'I'
+    );
+        my $proc = $get_current_process->Call();
+
+    # memory usage is bundled up in ProcessMemoryCounters structure
+    # populated by GetProcessMemoryInfo() win32 call
+    my $DWORD  = 'B32';    # 32 bits
+    my $SIZE_T = 'I';      # unsigned integer
+
+    # build a buffer structure to populate
+    my $pmem_struct = "$DWORD" x 2 . "$SIZE_T" x 8;
+    my $mem_counters
+        = pack( $pmem_struct, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );
+
+    # GetProcessMemoryInfo is in "psapi.dll"
+    my $get_process_memory_info = new Win32::API(
+        'psapi',
+        'GetProcessMemoryInfo',
+        [ 'I', 'P', 'I' ],
+        'I'
+    );
+
+    my $bool = $get_process_memory_info->Call(
+        $proc,
+        $mem_counters,
+        length $mem_counters,
+    );
+
+    # unpack ProcessMemoryCounters structure
+    my $peak_working_set_size =
+        (unpack($pmem_struct, $mem_counters))[2];
+
+    # only care about peak working set size
+    my $size = int($peak_working_set_size / 1024);
+
+    return ($size, 0);
+}
+
+sub _perl_getppid { return getppid }
+sub _linux_getppid { return Linux::Pid::getppid() }
+
+1;
+

diff --git a/t/procmanager_constrained.pm b/t/procmanager_constrained.pm
new file mode 100644 (file)
index 0000000..e9c75eb
--- /dev/null
+++ b/t/procmanager_constrained.pm
@@ -0,0 +1,62 @@
+# -*- perl -*-
+# Copyright (c) 2000, FundsXpress Financial Network, Inc.
+# This library is free software released "AS IS WITH ALL FAULTS"
+# and WITHOUT ANY WARRANTIES under the terms of the GNU Lesser
+# General Public License, Version 2.1, a copy of which can be
+# found in the "COPYING" file of this distribution.
+
+# $Id: procmanager.t,v 1.9 2001/04/23 16:13:45 muaddie Exp $
+
+use strict;
+use Test;
+
+BEGIN { plan tests => 5; }
+
+use FCGI::ProcManager::Constrained;
+
+my $m;
+
+ok $m = FCGI::ProcManager::Constrained->new();
+
+ok $m->n_processes(100) == 100;
+ok $m->n_processes(2) == 2;
+ok $m->n_processes(0) == 0;
+
+ok !$m->pm_manage();
+
+#ok $m->n_processes(-3);
+#eval { $m->pm_manage(); };
+#ok $@ =~ /dying from number of processes exception: -3/;
+#undef $@;
+
+if ($ENV{PM_N_PROCESSES}) {
+  $m->n_processes($ENV{PM_N_PROCESSES});
+  $m->pm_manage();
+  sample_request_loop($m);
+}
+
+exit 0;
+
+sub sample_request_loop {
+  my ($m) = @_;
+
+  while (1) {
+    # Simulate blocking for a request.
+    my $t1 = int(rand(2)+2);
+    print "TEST: simulating blocking for request: $t1 seconds.\n";
+    sleep $t1;
+    # (Here is where accept-fail-on-intr would exit request loop.)
+
+    $m->pm_pre_dispatch();
+
+    # Simulate a request dispatch.
+    my $t = int(rand(3)+2);
+    print "TEST: simulating new request: $t seconds.\n";
+    while (my $nslept = sleep $t) {
+      $t -= $nslept;
+      last unless $t;
+    }
+
+    $m->pm_post_dispatch();
+  }
+}