lib/FCGI/ProcManager/Constrained.pm

   1 package FCGI::ProcManager::Constrained;
   2 use strict;
   3 use warnings;
   4 use Carp qw/ confess /;
   5 use base 'FCGI::ProcManager';
   6 use Config;
   7
   8 sub new {
   9     my $proto = shift;
  10     my $self = $proto->SUPER::new(@_);
  11     $self->{max_requests} = $ENV{PM_MAX_REQUESTS} || 0 unless defined $self->{max_requests};
  12     $self->{sizecheck_num_requests} = $ENV{PM_SIZECHECK_NUM_REQUESTS} || 0 unless defined $self->{sizecheck_num_requests};
  13     $self->{max_size} = $ENV{PM_MAX_SIZE} || 0 unless defined $self->{max_size};
  14     if ($self->{sizecheck_num_requests} && ! _can_check_size()) {
  15         confess "Cannot load size check modules for your platform: sizecheck_num_requests > 0 unsupported";
  16     }
  17     return $self;
  18 }
  19
  20 sub max_requests { shift->pm_parameter('max_requests', @_); }
  21
  22 sub sizecheck_num_requests { shift->pm_parameter('sizecheck_num_requests', @_); }
  23
  24 sub max_size { shift->pm_parameter('max_size', @_); }
  25
  26 sub handling_init {
  27     my $self = shift;
  28     $self->SUPER::handling_init();
  29     $self->{_request_counter} = 0;
  30 }
  31
  32 sub pm_post_dispatch {
  33     my $self = shift;
  34     if ($self->max_requests > 0 && ++$self->{_request_counter} == $self->max_requests) {
  35         $self->pm_exit("safe exit after max_requests (" . $self->{_request_counter} . ")");
  36     }
  37     if ($self->sizecheck_num_requests
  38         and $self->{_request_counter} # Not the first request
  39         and $self->{_request_counter} % $self->sizecheck_num_requests == 0
  40     ) {
  41         $self->pm_exit("safe exit due to memory limits exceeded after " . $self->{_request_counter} . " requests")
  42             if $self->_limits_are_exceeded;
  43     }
  44     $self->SUPER::pm_post_dispatch();
  45 }
  46
  47 sub _limits_are_exceeded {
  48     my $self = shift;
  49
  50     my ($size, $share, $unshared) = $self->_check_size();
  51
  52     return 1 if $self->max_size  && $size > $self->max_size;
  53     return 0 unless $share;
  54 # FIXME
  55 #    return 1 if $self->min_share_size    && $share < $self->min_share_size;
  56 #    return 1 if $self->max_unshared_size && $unshared > $self->max_unshared_size;
  57
  58     return 0;
  59 }
  60
  61 # The following code is wholesale is nicked from Apache::SizeLimit::Core
  62
  63 sub _check_size {
  64     my $class = shift;
  65
  66     my ($size, $share) = $class->_platform_check_size();
  67
  68     return ($size, $share, $size - $share);
  69 }
  70
  71 sub _load {
  72     my $mod = shift;
  73     $mod =~ s/::/\//g;
  74     $mod .= '.pm';
  75     eval { require($mod); 1; }
  76 }
  77 our $USE_SMAPS;
  78 BEGIN {
  79     my ($major,$minor) = split(/\./, $Config{'osvers'});
  80     if ($Config{'osname'} eq 'solaris' &&
  81         (($major > 2) || ($major == 2 && $minor >= 6))) {
  82         *_can_check_size = sub () { 1 };
  83         *_platform_check_size   = \&_solaris_2_6_size_check;
  84         *_platform_getppid = \&_perl_getppid;
  85     }
  86     elsif ($Config{'osname'} eq 'linux' && _load('Linux::Pid')) {
  87         *_platform_getppid = \&_linux_getppid;
  88         *_can_check_size = sub () { 1 };
  89         if (_load('Linux::Smaps') && Linux::Smaps->new($$)) {
  90             $USE_SMAPS = 1;
  91             *_platform_check_size = \&_linux_smaps_size_check;
  92         }
  93         else {
  94             $USE_SMAPS = 0;
  95             *_platform_check_size = \&_linux_size_check;
  96         }
  97     }
  98     elsif ($Config{'osname'} =~ /(?:bsd|aix)/i && _load('BSD::Resource')) {
  99         # on OSX, getrusage() is returning 0 for proc & shared size.
 100         *_can_check_size = sub () { 1 };
 101         *_platform_check_size   = \&_bsd_size_check;
 102         *_platform_getppid = \&_perl_getppid;
 103     }
 104     else {
 105         *_can_check_size = sub () { 0 };
 106     }
 107 }
 108
 109 sub _linux_smaps_size_check {
 110     my $class = shift;
 111
 112     return $class->_linux_size_check() unless $USE_SMAPS;
 113
 114     my $s = Linux::Smaps->new($$)->all;
 115     return ($s->size, $s->shared_clean + $s->shared_dirty);
 116 }
 117
 118 sub _linux_size_check {
 119     my $class = shift;
 120
 121     my ($size, $share) = (0, 0);
 122     if (open my $fh, '<', '/proc/self/statm') {
 123         ($size, $share) = (split /\s/, scalar <$fh>)[0,2];
 124         close $fh;
 125     }
 126     else {
 127         $class->_error_log("Fatal Error: couldn't access /proc/self/status");
 128     }
 129
 130     # linux on intel x86 has 4KB page size...
 131     return ($size * 4, $share * 4);
 132 }
 133
 134 sub _solaris_2_6_size_check {
 135     my $class = shift;
 136
 137     my $size = -s "/proc/self/as"
 138         or $class->_error_log("Fatal Error: /proc/self/as doesn't exist or is empty");
 139     $size = int($size / 1024);
 140
 141     # return 0 for share, to avoid undef warnings
 142     return ($size, 0);
 143 }
 144
 145 # rss is in KB but ixrss is in BYTES.
 146 # This is true on at least FreeBSD, OpenBSD, & NetBSD
 147 sub _bsd_size_check {
 148
 149     my @results = BSD::Resource::getrusage();
 150     my $max_rss   = $results[2];
 151     my $max_ixrss = int ( $results[3] / 1024 );
 152
 153     return ($max_rss, $max_ixrss);
 154 }
 155
 156 sub _win32_size_check {
 157     my $class = shift;
 158
 159     # get handle on current process
 160     my $get_current_process = Win32::API->new(
 161         'kernel32',
 162         'get_current_process',
 163         [],
 164         'I'
 165     );
 166         my $proc = $get_current_process->Call();
 167
 168     # memory usage is bundled up in ProcessMemoryCounters structure
 169     # populated by GetProcessMemoryInfo() win32 call
 170     my $DWORD  = 'B32';    # 32 bits
 171     my $SIZE_T = 'I';      # unsigned integer
 172
 173     # build a buffer structure to populate
 174     my $pmem_struct = "$DWORD" x 2 . "$SIZE_T" x 8;
 175     my $mem_counters
 176         = pack( $pmem_struct, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );
 177
 178     # GetProcessMemoryInfo is in "psapi.dll"
 179     my $get_process_memory_info = new Win32::API(
 180         'psapi',
 181         'GetProcessMemoryInfo',
 182         [ 'I', 'P', 'I' ],
 183         'I'
 184     );
 185
 186     my $bool = $get_process_memory_info->Call(
 187         $proc,
 188         $mem_counters,
 189         length $mem_counters,
 190     );
 191
 192     # unpack ProcessMemoryCounters structure
 193     my $peak_working_set_size =
 194         (unpack($pmem_struct, $mem_counters))[2];
 195
 196     # only care about peak working set size
 197     my $size = int($peak_working_set_size / 1024);
 198
 199     return ($size, 0);
 200 }
 201
 202 sub _perl_getppid { return getppid }
 203 sub _linux_getppid { return Linux::Pid::getppid() }
 204
 205 1;
 206