1package FCGI::ProcManager::Constrained;
2use strict;
3use warnings;
4use Carp qw/ confess /;
5use base 'FCGI::ProcManager';
6use Config;
7
8sub 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
20sub max_requests { shift->pm_parameter('max_requests', @_); }
21
22sub sizecheck_num_requests { shift->pm_parameter('sizecheck_num_requests', @_); }
23
24sub max_size { shift->pm_parameter('max_size', @_); }
25
26sub handling_init {
27    my $self = shift;
28    $self->SUPER::handling_init();
29    $self->{_request_counter} = 0;
30}
31
32sub 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
47sub _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
63sub _check_size {
64    my $class = shift;
65
66    my ($size, $share) = $class->_platform_check_size();
67
68    return ($size, $share, $size - $share);
69}
70
71sub _load {
72    my $mod = shift;
73    $mod =~ s/::/\//g;
74    $mod .= '.pm';
75    eval { require($mod); 1; }
76}
77our $USE_SMAPS;
78BEGIN {
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
109sub _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
118sub _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
134sub _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
147sub _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
156sub _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
202sub _perl_getppid { return getppid }
203sub _linux_getppid { return Linux::Pid::getppid() }
204
2051;
206
207=head1 NAME
208
209FCGI::ProcManager::Constrained - Process manager with constraints
210
211=head1 SYNOPSIS
212
213    $ENV{PM_MAX_REQUESTS} = 1000;
214    $ENV{PM_SIZECHECK_NUM_REQUESTS} = 10;
215    $ENV{PM_MAX_SIZE} = 4096;
216
217=head1 DESCRIPTION
218
219Subclass of L<FCGI::ProcManager> which adds checks for memory limits
220like L<Apache::SizeLimit>.
221
222=head1 AUTHORS, COPYRIGHT AND LICENSE
223
224See L<FCGI::ProcManager>.
225
226=cut
227
228