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