package FCGI::Engine::ProcManager::Constrained; use Moose; use Config; use Try::Tiny; extends 'FCGI::Engine::ProcManager'; sub BUILD { my $self = shift; if ($self->sizecheck_num_requests && ! _can_check_size()) { confess "Cannot load size check modules for your platform: sizecheck_num_requests > 0 unsupported"; } } has max_requests => ( isa => 'Int', is => 'ro', # FIXME - This is fuck ugly. default => sub { $ENV{PM_MAX_REQUESTS} || 0 }, ); has request_count => ( isa => 'Int', is => 'ro', traits => ['Counter'], handles => { _reset_request_counter => 'reset', _inc_request_counter => 'inc', }, init_arg => undef, default => 0, ); has [qw/ sizecheck_num_requests max_process_size min_share_size max_unshared_size /] => ( isa => 'Int', is => 'ro', default => 0, ); augment server_init => sub { my $self = shift; $self->_reset_request_counter(); }; augment post_dispatch => sub { my $self = shift; $self->exit("safe exit after max_requests (" . $self->max_requests . ")") if ($self->max_requests and $self->_inc_request_counter == $self->max_requests); if ($self->sizecheck_num_requests and $self->request_count # Not the first request and $self->request_count % $self->sizecheck_num_requests == 0 ) { $self->exit("safe exit due to memory limits exceeded after " . $self->request_count . " requests") if $self->_limits_are_exceeded; } }; sub _limits_are_exceeded { my $self = shift; my ($size, $share, $unshared) = $self->_check_size(); return 1 if $self->max_process_size && $size > $self->max_process_size; return 0 unless $share; 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; try { Class::MOP::load_class($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() } no Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =pod =head1 NAME FCGI::Engine::ProcManager::Constrained - FastCGI applications with memory and number of request limits. =head1 DESCRIPTION A constrained process manager that restarts child workers after a number of requests or if they use too much memory. Most of the memory usage code is stolen from L<Apache2::SizeLimit>. =head1 ATTRIBUTES =head2 max_requests The number of requests a child process can handle before being terminated. 0 (the default) means let child processes do an infinite number of requests =head2 sizecheck_num_requests The number of requests between a check on the process size taking place. 0 (the default) means never attempt to check the process size. =head2 max_process_size The maximum size of the process (both shared and unshared memory) in KB. 0 (the default) means unlimited. =head2 max_unshared_size The maximum amount of memory in KB this process can have that isn't Copy-On-Write shared with other processes. 0 (the default) means unlimited. =head2 min_share_size The minimum amount of memory in KB this process can have Copy-On-Write from it's parent process before it is terminate. =head1 METHODS I will fill this in more eventually, but for now if you really wanna know, read the source. =head1 SEE ALSO =over =item L<FCGI::Engine::ProcManager> =item L<Apache2::SizeLimit>. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 AUTHOR Tomas Doran E<lt>bobtfish@bobtfish.netE<gt> =head1 COPYRIGHT AND LICENSE Code sections copied from L<Apache2::SizeLimit> are Copyright their respective authors. Copyright 2007-2010 by Infinity Interactive, Inc. L<http://www.iinteractive.com> This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut