SHARE
TWEET

memcron 0.6.4-Bret

bret_miller Aug 16th, 2011 335 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #!/usr/bin/env perl
  2. our $VERSION = "0.6.4-Bret";
  3.  
  4. #////////////////////////////////////////////////////////////////////////////////////
  5. #
  6. #   memCron - DreamHost PS Memory Manager
  7. #
  8. #   Author     : Yaosan Yeo
  9. #   Version    : 0.6
  10. #   Date       : 22 March 2010
  11. #   URL        : http://memcron.com/
  12. #
  13. #   History  :
  14. #   0.6.4-Bret [2010.08.16 + Replaced get memory routine, more efficient so can run as often as every minute
  15. #                          + Added/fixed code to force downsize (from 0.6.3-Bret)
  16. #                          + Added config: $force_downsize_ratio, defaults to 0.20, 0=disabled
  17. #                          + Added config: $num_samples, defaults to 60; number of samples to average memory usage from
  18. #                                          I set mine to 30 thinking looking at memory 30 times per minute is enough.
  19. #   0.6.2-chris [2010.06.30] - updated sendmail path from /usr/bin/sendmail to |/usr/sbin/sendmail
  20. #                                 |-> neet to place \ before @ in the email address (ex: me\@us.com)
  21. #                            + added random number to unique id
  22. #   0.6.1-ben [2010.03.22] - Added support for HTTP::MHTTP module
  23. #                          + Added a message log in ./logs/memcron.log, new config item $log_level
  24. #                            (0 = no log, 3 = default, 5 = debugging)
  25. #   0.6 [2010.03.22] - Added: Various improvements contributed by memCron's user, Ben and Bret: (thanks guys!)
  26. #                      + Replaced most external calls with built-ins
  27. #                      + Removed dependency on Mail::SendMail
  28. #                      + Replaced LWP (slow and bloated) with system call to curl
  29. #                      + Get memory sizes from /proc/meminfo
  30. #                      + Simplified memory collecting
  31. #                      + Get current size from API rather than OS
  32. #                      + New options to disable updates, alerts
  33. #                      + Include mem target, cache used in csv
  34. #                      + Better error handling on memory resize
  35. #                    - Changed: Z-score function is now internal
  36. #
  37. #   0.4.1 [2009.08.10 ] - Fixed: Memory calculation due to the 2x increase of swap memory by DreamHost
  38. #
  39. #   0.4 [2009.06.28] - Added: New parameter "$max_memory" and "$min_memory" to limit the memory range that memCron should operate within
  40. #                    - Added: New parameter "$mem_threshold" to set a memory threshold, which when exceeded, will send out notification to $email
  41. #                    - Added: 4 new subroutines - round(), get_mem_size(), get_mem_size(), get_mem_target() to simplify the code structure
  42. #                    - Added: Base and swap memory size to function output
  43. #                    - Added: Resize information to function output
  44. #                    - Changed: "$debug" parameter moved from config.cfg to this file
  45. #                    - Removed: "$username" parameter, now DreamHost API only needs API key for authentication
  46. #                    - Fixed: Memory target are now computed more correctly during downsize
  47. #
  48. #   0.3 [2009.05.27] - Added: New parameter "$downsize_resistance" to prevent rapid fluctuations from causing multiple resizes within short period of time
  49. #                    - Changed: 0.3 to 0.7 ratio between "$mem_mean" and "$mem_used instead" of 0.5 to 0.5 when calculating "$mem_free_tolerance"
  50. #                    - Changed: More descriptive error message when log file cannot be opened
  51. #                    - Fixed: "$unix_time" and "$cpu_load" will now be reevaluated until it is defined to ensure data point is always logged (removed in 0.5)
  52. #                    - Fixed: Memory target calculations now correctly accounts max and swap memory, which is capped at 4000 MB and 450MB respectively
  53. #
  54. #   0.2 [2009.05.03] - Fixed: Account for "$num_data" in z-score calculation to ensure number of memory changes is minimized to within daily limits
  55. #                    - Changed: "$use_api" is changed to "$debug", which if set disables all log outputs and API calls
  56. #
  57. #   0.1 [2009.04.30] - Initial release
  58. #
  59. #////////////////////////////////////////////////////////////////////////////////////
  60. #
  61. # Copyright 2009 (c) Yaosan Yao - http://www.memcron.com/
  62. #
  63. # Portions of this product originally from psmanager:                     #
  64. # Copyright 2009 (C) Otto de Voogd - http://www.7is7.com/                 #
  65. #                                                                         #
  66. # This program is free software; you can redistribute it and/or modify    #
  67. # it under the terms of the GNU General Public License as published by    #
  68. # the Free Software Foundation; version 3 of the License.                 #
  69. #                                                                         #
  70. # This program is distributed in the hope that it will be useful,         #
  71. # but WITHOUT ANY WARRANTY; without even the implied warranty of          #
  72. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the           #
  73. # GNU General Public License for more details.                            #
  74. #                                                                         #
  75. # See license: http://www.gnu.org/licenses/gpl.html                       #
  76. #////////////////////////////////////////////////////////////////////////////////////
  77.  
  78. use strict;
  79. use warnings;
  80. no warnings 'uninitialized';
  81.  
  82. use File::Basename;
  83. use Time::Local;
  84. use Sys::Hostname;
  85.  
  86. #////////////////////////////////////////////////// get configurations
  87.  
  88. my $hostname = hostname;
  89. my $unix_time = time();
  90.  
  91.  
  92. # settings from config file
  93. our (
  94.         $key,                 $ps,                  $cron_interval,
  95.         $max_memory,          $min_memory,          $mem_threshold,
  96.         $disable_updates,     $alert_on_change,     $alert_on_error,
  97.         $email,               $mem_free_confidence, $mem_free_to_used_ratio,
  98.         $force_downsize_ratio, $num_samples,
  99.         $downsize_resistance, $num_data,            $num_data_csv,
  100.         $use_mhttp,               $debug,                               $log_level
  101. );
  102.  
  103. $force_downsize_ratio=0.20;
  104. $num_samples=60;
  105.  
  106. my $dir = dirname($0);
  107. do "$dir/config.cfg";
  108.  
  109. $debug ||= $ARGV[0] eq '-d';
  110. if (!defined $log_level) { $log_level = $debug ? 5 : 3 }
  111.  
  112. ## try to use the MHTTP if it's available, set $use_mhttp=0 in config to avoid this.
  113. if ($use_mhttp || !defined($use_mhttp)) {
  114.         eval {
  115.                 require "HTTP/MHTTP.pm";
  116.                 import HTTP::MHTTP;
  117.         };
  118.         $use_mhttp = !$@;
  119. }
  120.  
  121. # Logs
  122. my $log_dir = "$dir/logs";
  123. my $log_csv = "$log_dir/$hostname.csv";
  124. my $log_memory = "$log_dir/$hostname.log";
  125. my $log_downsize = "$log_dir/$hostname-downsize.log";
  126. my $log_message = "$log_dir/memcron.log";
  127.  
  128. startup();
  129. local $SIG{__DIE__} = sub {
  130.         if ($^S) {
  131.                 die @_;
  132.         } else {
  133.                 FATAL("$_[0]");
  134.                 cleanup(-1);
  135.         }
  136. };
  137.  
  138. # DreamHost PS limit
  139. my $daily_change_limit = 30;
  140. my $runs_per_day       = 1440 / $cron_interval;
  141.  
  142. # DreamHost PS defaults
  143. if ( $max_memory > 4000 ) { $max_memory = 4000; }
  144. if ( $min_memory < 300 )  { $min_memory = 300; }
  145.  
  146. # Statistics values
  147. my $SAMPLES = $debug ? 1 : $num_samples;
  148. my $mem_used_zscore = abs( normsinv( ( $daily_change_limit * $num_data / $runs_per_day ) / $runs_per_day ) );    #1.89;
  149. my $mem_free_zscore = abs( normsinv( $mem_free_confidence ) );    #3.09;
  150.  
  151. #////////////////////////////////////////////////// main program starts
  152.  
  153. my ( $mem_total, $mem_used, $mem_free, $mem_cached, $cpu_load );
  154.  
  155. #my $list_ps = call_api('list_ps');
  156. #
  157. #if ( $list_ps->{status} ) {
  158. #       for (@{$list_ps->{data}}){
  159. #               next if $_->{ps} ne $hostname;
  160. #               $mem_total = $_->{memory_mb};
  161. #               last;
  162. #       }
  163. #       if (!$mem_total) {
  164. #               die "Dreamhost PS $hostname not found!";
  165. #       }
  166. #} else {
  167. #       die "$list_ps->{error}";
  168. #}
  169.  
  170. #my $mem = meminfo();
  171.  
  172. #foreach ( 1 .. $SAMPLES ) {
  173. #       $cpu_load += ( cpu_load() )[1];
  174. #       $mem = meminfo();
  175. #       $mem_used += $mem->{MemTotal} - $mem->{MemFree} + $mem->{SwapTotal} - $mem->{SwapFree};
  176. #       $mem_cached += $mem->{Cached};
  177. #       sleep 1 if !$debug;
  178. #}
  179. my $firstpass=1;
  180. foreach ( 1 .. $SAMPLES ) {
  181.         my $mu=0;
  182.         my $mc=0;
  183.         sleep 1 if !$firstpass;
  184.         $firstpass=0;
  185.         $cpu_load += ( cpu_load() )[1];
  186.         ($mem_total,$mu,$mem_free,$mc) = split /\t/, &getMemoryInfo($mem_total,$mu,$mem_free,$mc);
  187.         $mem_used+=$mu;
  188.         $mem_cached+=$mc;
  189. }
  190.  
  191. $mem_used = round( $mem_used / $SAMPLES );
  192. $mem_cached = round( $mem_cached / $SAMPLES );
  193. #$mem_used -= $mem_cached;
  194. $cpu_load = round( $cpu_load / $SAMPLES, 2 );
  195. $mem_free = $mem_total - $mem_used;
  196.  
  197. write_log( $log_memory, $mem_used, $num_data );
  198.  
  199.  
  200. #////////////// calculate the amount of memory to be reserved based on past data
  201.  
  202. my @data = read_log( $log_memory );
  203.  
  204. # construct a short list to be used when downsizing
  205. my @shortlist = @data[ ( scalar(@data) - $downsize_resistance ) .. ( scalar(@data) - 1 ) ];
  206.  
  207. # make sure we have enough data points before proceeding
  208. if ( scalar(@data) < round( $num_data * 0.1 ) ) {
  209.         WARN("need more data points");
  210.         cleanup();
  211. }
  212.  
  213. my ( $mem_stattotal, $mem_mean, $mem_median, $mem_stdev ) = stats(@data);
  214.  
  215. $mem_mean = round($mem_mean);
  216. $mem_stdev = round( $mem_stdev, 2 );
  217.  
  218. my $mem_used_tolerance = round( $mem_used_zscore * $mem_stdev );
  219. my $mem_free_tolerance = round( $mem_free_zscore * $mem_stdev );
  220.  
  221. unless ( $mem_free_tolerance > ( $mem_mean * 0.3 + $mem_used * 0.7 ) * $mem_free_to_used_ratio ) {
  222.         $mem_free_tolerance = round( ( $mem_mean * 0.3 + $mem_used * 0.7 ) * $mem_free_to_used_ratio );
  223. }
  224.  
  225. #////////////// calculate the memory required
  226.  
  227. my $mem_required = $mem_used + $mem_free_tolerance;
  228. my $mem_target   = get_mem_target($mem_required);
  229. my $set = ( abs( $mem_total - $mem_target ) > $mem_used_tolerance );
  230.  
  231. #////////////// resize resistance
  232. my $downsize_count = 0;
  233. if ( $set ) {
  234.         WARN("resize required $mem_target ($mem_total)");
  235.     if ( $mem_target < $mem_total ) {
  236.         $downsize_count = read_status( $log_downsize ) || 0;
  237.                 $downsize_count++;
  238.  
  239.                 if ( $downsize_count >= $downsize_resistance ) {
  240.                         $downsize_count = 0;
  241.                         $mem_required = round( ( stats(@shortlist) )[1] ) + $mem_free_tolerance;
  242.                         $mem_target = get_mem_target($mem_required);
  243.                 } else {
  244.                         $set = 0;
  245.                 }
  246.         }
  247. }
  248.  
  249. write_status( $log_downsize, $downsize_count );
  250.  
  251. #////////////// set memory using DreamHost API, output result
  252.  
  253. my $sendmail;
  254. my $subject;
  255. my $message = <<"MESSAGE";
  256. Total: $mem_total       Used: $mem_used Free: $mem_free
  257. Mean: $mem_mean Stdev: $mem_stdev       Load: $cpu_load
  258. Tolerance: $mem_used_tolerance  Tolerance (free): $mem_free_tolerance
  259.  
  260. Target: $mem_target
  261. MESSAGE
  262.  
  263. $set = 0 if $mem_target == $mem_total || $debug || $disable_updates;
  264.  
  265. if ($set) {
  266.         $message .= "\nMemory was resized from $mem_total MB to $mem_target MB!\n";
  267.  
  268.         # check against memory threshold, send notification email if it is exceeded
  269.         if ( $mem_threshold && $mem_target > $mem_threshold ) {
  270.                 print "\n*** Warning! Threshold exceeded! ***\n";
  271.                 $subject = "Memory threshold exceeded for $hostname";
  272.                 $sendmail = 1 unless $debug;
  273.         }
  274.  
  275.         my $set_response;
  276.         my $with_force=0;
  277.         if ( ($force_downsize_ratio) && ($mem_target < $mem_total) && ((($mem_total-$mem_target)/$mem_total) >= $force_downsize_ratio)) {
  278.                 #If we'll save more than 25%, then force the resize.
  279.                 $set_response = call_api('set_size', (size => $mem_target,force => 'yes'));
  280.                 $with_force=1;
  281.         } else {
  282.                 $set_response = call_api('set_size', size => $mem_target);
  283.         }
  284.         if ( $set_response->{status} ) {
  285.                 $subject = "Resized $hostname from $mem_total MB to $mem_target MB";
  286.                 if ($with_force) { $subject.=", with force"; }
  287.                 $sendmail = 1 if $alert_on_change;
  288.         } else {
  289.                 $subject = "Unable to set memory size for $hostname";
  290.                 $message .= $set_response->{error};
  291.                 $sendmail = 1 if $alert_on_error;
  292.         }
  293.  
  294.         $message .= "\n";
  295.  
  296.         # send notification if necessary
  297.         if ( $sendmail && $email ) {
  298.                 my $top = `top -b -n 1`;
  299.     chomp($top);
  300.                 email_notice( $email, $subject, <<"MESSAGE" );
  301.  
  302. $message
  303. -----
  304.  
  305. List of running processes:
  306.  
  307. $top
  308.  
  309. MESSAGE
  310.  
  311.         }
  312. } else {
  313.                 $message .= "\nNo need to adjust memory" . ( ($downsize_count) ? " yet! ($downsize_count/$downsize_resistance)" : "!" ) . "\n";
  314. }
  315.  
  316. print $message;
  317. print "\n-----\n";
  318.  
  319. #////////////// write memory usage and cpu load to csv file
  320.  
  321. my $log_line = join( ",",
  322.         $unix_time,          $mem_total,          $mem_used,
  323.         $cpu_load,           $mem_mean,           $mem_stdev,
  324.         $mem_used_tolerance, $mem_free_tolerance, $downsize_count,
  325.         $mem_target,         $mem_cached
  326. );
  327.  
  328. write_log($log_csv, $log_line, $num_data_csv);
  329. cleanup();
  330.  
  331.  
  332. #////////////// subroutines
  333.  
  334. sub cpu_load {
  335.         open( LOAD, "/proc/loadavg" ) or die "Unable to open /proc/loadavg";
  336.         my @l = split /\s+/, <LOAD>;
  337.         close(LOAD);
  338.         return @l;
  339. }
  340.  
  341. sub meminfo {
  342.         while (1) {
  343.                 open( MEM, "/proc/meminfo" ) or die "Unable to open /proc/meminfo";
  344.                 my %mem = map { (/(\w+):\s*(\d+)/) } <MEM>;
  345.                 close(MEM);
  346.                 ## kB to MB
  347.                 for ( values %mem ) { $_ = int( $_ / 1024 ) }
  348.                 ## sanity check MemTotal and retry if it's not valid
  349.                 return \%mem if $mem{MemTotal} >= 300 && $mem{MemTotal} <= 4000;
  350.         }
  351. }
  352.  
  353. sub getMemoryInfo {
  354.         my ($tot_mem_avail,$tot_mem_used,$tot_mem_free,$tot_mem_cach) = @_;
  355.  
  356.         my $lines_read = 0;
  357.         my $free_output = `free -m`;
  358.  
  359.         my $mem_avail;
  360.         my $mem_used;
  361.         my $mem_free;
  362.         my $mem_cach;
  363.         my $swap_avail;
  364.         my $swap_used;
  365.         my $swap_free;
  366.  
  367.         foreach my $line (split /\n/, $free_output) {
  368.                 $line =~ s/ +/ /g;
  369.                 my @linepart = split / /, $line;
  370.                 if ($line =~ /^Mem:/i) {
  371.                         $lines_read++;
  372.                         $mem_avail = $linepart[1];
  373.                         $mem_cach = $linepart[5] + $linepart[6];
  374.                         $mem_used = $linepart[2] - $mem_cach;
  375.                         $mem_free = $linepart[3] + $mem_cach;
  376.                 }
  377.                 if ($line =~ /^Swap:/i) {
  378.                         $lines_read++;
  379.                         $swap_avail = $linepart[1];
  380.                         $swap_used = $linepart[2];
  381.                         $swap_free = $linepart[3];
  382.                 }
  383.         }
  384.         if ($lines_read!=2) {
  385.                 &printError(9,"Could not retrieve memory information!");
  386.                 #die "Script terminated!\n";
  387.         }
  388.     # Occasionally excessively high memory values are returned
  389.     # by 'free', hence we check that the values make some sense.
  390.         if ( $mem_avail + $swap_avail < 16 * $max_memory ) {
  391.         $tot_mem_avail = $mem_avail + $swap_avail;
  392.                 if (
  393.                         ($mem_used + $swap_used >= 0) &&
  394.                         ($mem_used + $swap_used <= $tot_mem_avail) &&
  395.                         ($mem_used + $swap_used > $tot_mem_used)
  396.                 ) {
  397.                         $tot_mem_used = $mem_used + $swap_used;
  398.                         $tot_mem_free = $mem_free + $swap_free;
  399.                         $tot_mem_cach = $mem_cach;
  400.                 }
  401.         }
  402.         return "$tot_mem_avail\t$tot_mem_used\t$tot_mem_free\t$tot_mem_cach";
  403. }
  404.  
  405. sub email_notice {
  406.         my ($to, $subject, $message) = @_;
  407.  
  408.         my $date = date_time_string();
  409.         open( MAIL, "|/usr/sbin/sendmail -t" ) or die "Unable to open sendmail: $!";
  410.         print MAIL <<"MESSAGE";
  411. To: $to
  412. From: memCron on $hostname <noreply\@memcron.com>
  413. Date: $date
  414. Subject: $subject
  415.  
  416. $message
  417.  
  418. -----------------------------------
  419. memCron $VERSION at $date
  420. -----------------------------------
  421. MESSAGE
  422.  
  423.         close(MAIL);
  424. }
  425.  
  426.  
  427. ## initialize message log, etc...
  428. sub startup {
  429.     if ( $log_level && !$debug ) {
  430.                 open(LOGINFO, ">>$log_message") or die "Cannot open  system log $log_message!";
  431.         }
  432.         INFO("memcron $VERSION started (pid: $$)");
  433. }
  434.  
  435. sub cleanup {
  436.         INFO("memcron $VERSION complete");
  437.         if ( $log_level && !$debug ) {
  438.                 close(LOGINFO);
  439.         }
  440.         exit $_[0]||0;
  441. }
  442.  
  443. sub log_message {
  444.         my $ts = '['.date_time_string(time).']';
  445.         my $indent;
  446.         for ( split/\n/, $_[0]) {
  447.                 if ($debug) {
  448.                         print "$ts $indent$_\n";
  449.                 } else {
  450.                         print LOGINFO "$ts $indent$_\n";
  451.                 }
  452.                 $indent = "|";
  453.         }
  454. }
  455.  
  456. sub FATAL { &log_message if $log_level >= 1 }
  457. sub ERROR { &log_message if $log_level >= 2 }
  458. sub WARN  { &log_message if $log_level >= 3 }
  459. sub INFO  { &log_message if $log_level >= 4 }
  460. sub DEBUG { &log_message if $log_level >= 5 }
  461.  
  462.  
  463.  
  464. sub write_log {
  465.         my ($file, $line, $truncate) = @_;
  466.         if ($debug) {
  467.                 print "$file:\t$line\n";
  468.                 return;
  469.         }
  470.         open(LOG, ">>$file") or die "Cannot open $file!";
  471.         print LOG $line,"\n";
  472.         close(LOG);
  473.         if ($truncate) {
  474.                 truncate_log( $file, $truncate );
  475.         }
  476. }
  477.  
  478. sub read_log {
  479.         my ($file) = @_;
  480.         if ( ! -e $file ) { return () };
  481.         open(LOG, $file);
  482.         my @lines;
  483.         while (<LOG>) {
  484.                 chomp;
  485.                 push @lines, $_;
  486.         }
  487.         close LOG;
  488.         return @lines;
  489. }
  490.  
  491. sub truncate_log {
  492.         my ($file, $lines) = @_;
  493.         return unless -e $file;
  494.         system("tail -n $lines $file > $file.temp");
  495.         system("mv -f $file.temp $file");
  496. }
  497.  
  498. # single value status files
  499. sub write_status {
  500.         my ($file, $value) = @_;
  501.         if ($debug) {
  502.                 print "$file:\t$value\n";
  503.                 return;
  504.         }
  505.         open(LOG, ">$file") or die "Cannot open $file!";
  506.         print LOG $value,"\n";
  507.         close(LOG);
  508. }
  509.  
  510. sub read_status {
  511.         my ($file) = @_;
  512.         return unless -e $file;
  513.         open(LOG, $file);
  514.         my $value = <LOG>;
  515.         close LOG;
  516.         chomp $value;
  517.         return $value;
  518. }
  519.  
  520. # wraps call to DreamHost API so we can catch errors in a uniform way
  521. sub call_api {
  522.         my ( $command, %params ) = @_;
  523.         ## references globals: ($hostname, $time and $key)
  524.  
  525.         DEBUG("calling api $command");
  526.         my $url = 'https://panel.dreamhost.com/api/';
  527.         my %p = (
  528.                 key       => $key,
  529.                 cmd       => 'dreamhost_ps-' . $command,
  530.                 unique_id => $unix_time . rand() . $$,
  531.                 format    => 'perl',
  532.                 ps        => $hostname,
  533.                 %params
  534.         );
  535.         my $post = join(' ', map( "-d $_=$p{$_}", keys %p ) );
  536.     my $response = eval {
  537.         if ( $use_mhttp ) {
  538.                         DEBUG("using mhttp");
  539.             $post = join('&', map("$_=$p{$_}", keys %p ));
  540.             http_set_protocol(1);
  541.             switch_debug(0);
  542.             http_add_headers(
  543.                     'User-Agent' => "memcron/$VERSION",
  544.                     'Connection' => "Keep-Alive",
  545.                     'Host' => 'panel.dreamhost.com',
  546.                     'Content-Type' => 'application/x-www-form-urlencoded',
  547.                 );
  548.             http_body($post);
  549.             if (http_call('POST', $url)) {
  550.                 if (http_status() == 200) {
  551.                     return http_response();
  552.                 } else {
  553.                     die  http_reason() . "\n";
  554.                 }
  555.             } else {
  556.                 die "Unable to connect to API\n"
  557.             }
  558.         } else {
  559.                         DEBUG("using system curl");
  560.             $post = join(' ', map( "-d $_=$p{$_}", keys %p ) );
  561.             return `curl -s $post $url`;
  562.         }
  563.     }; 
  564.  
  565.         my ( $r, $error );
  566.         if ($@) {
  567.                 $error = "Error: \n" . $@;
  568.         } elsif ( !$response ) {
  569.                 $error = "No response\n";
  570.         } elsif ( $response !~ /^\$result/ ) {
  571.                 $error = "Unknown response format:\n" . $response;
  572.         }
  573.  
  574.         my $result;
  575.         if ( !$error ) {
  576.                 eval "$response";
  577.                 if ( $result->{result} eq 'error' ) {
  578.                         $error = "Error calling $command: $result->{data}\n";
  579.                 } elsif ( $result->{result} ne 'success' ) {
  580.                         $error = "Unknown API response:\n\n$response\n";
  581.                 }
  582.         }
  583.  
  584.         return $error ? { status => 0, error => $error } : { status => 1, data => $result->{data} };
  585. }
  586.  
  587. sub round {
  588.         my ( $val, $places ) = @_;
  589.         $places ||= 0;
  590.         return sprintf( "%.${places}f", $val || 0 );
  591. }
  592.  
  593. sub get_mem_target {
  594.         my $mem_target = shift;
  595.  
  596.         # handle max and min memory limit
  597.         if ( $mem_target < $min_memory ) {
  598.                 DEBUG("need $mem_target, using min_memory($min_memory)");
  599.                 $mem_target = $min_memory;
  600.         } elsif ( $mem_target > $max_memory ) {
  601.                 WARN("need $mem_target, using max_memory($max_memory)");
  602.                 $mem_target = $max_memory;
  603.         }
  604.  
  605.         return ( round($mem_target) );
  606. }
  607.  
  608. sub stats {
  609.         my $total = 0;
  610.         foreach my $v (@_) { $total += $v; }
  611.  
  612.         my $average = $total / @_;
  613.         my $median = @_ % 2
  614.                 ? $_[ ( @_ - 1 ) / 2 ]
  615.                 : ( $_[ @_ / 2 - 1 ] + $_[ @_ / 2 ] ) / 2;
  616.  
  617.         my $sqtotal = 0;
  618.         foreach my $v (@_) {
  619.                 $sqtotal += ( $average - $v )**2;
  620.         }
  621.         my $stdev = ( $sqtotal / @_ )**0.5;
  622.  
  623.         return ( $total, $average, $median, $stdev );
  624. }
  625.  
  626. sub date_time_string {
  627.         # convert a time() value to a date-time string according to RFC 822
  628.  
  629.         my $time = $_[0] || time();    # default to now if no argument
  630.  
  631.         my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  632.         my @wdays  = qw(Sun Mon Tue Wed Thu Fri Sat);
  633.  
  634.         my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime($time);
  635.  
  636.         my $TZ = $ENV{TZ};
  637.         if ( $TZ eq "" ) {
  638.                 # offset in hours
  639.                 my $offset = sprintf "%.1f", ( timegm(localtime) - time ) / 3600;
  640.                 my $minutes = sprintf "%02d", abs( $offset - int($offset) ) * 60;
  641.                 $TZ = sprintf( "%+03d", int($offset) ) . $minutes;
  642.         }
  643.  
  644.         return join( " ",
  645.                 ( $wdays[$wday] . ',' ),
  646.                 $mday, $months[$mon],
  647.                 $year + 1900,
  648.                 sprintf( "%02d:%02d:%02d", $hour, $min, $sec ), $TZ );
  649. }
  650.  
  651. sub normsinv {
  652.     #
  653.     # This function returns an approximation of the inverse cumulative
  654.     # standard normal distribution function.  I.e., given P, it returns
  655.     # an approximation to the X satisfying P = Pr{Z <= X} where Z is a
  656.     # random variable from the standard normal distribution.
  657.     #
  658.     # The algorithm uses a minimax approximation by rational functions
  659.     # and the result has a relative error whose absolute value is less
  660.     # than 1.15e-9.
  661.     #
  662.     # Author:      Peter J. Acklam
  663.     # Time-stamp:  2000-07-19 18:26:14
  664.     # E-mail:      pjacklam@online.no
  665.     # WWW URL:     http://home.online.no/~pjacklam
  666.  
  667.     my $p = shift;
  668.     die "input argument must be in (0,1)\n" unless 0 < $p && $p < 1;
  669.  
  670.     # Coefficients in rational approximations.
  671.     my @a = (-3.969683028665376e+01,  2.209460984245205e+02,
  672.              -2.759285104469687e+02,  1.383577518672690e+02,
  673.              -3.066479806614716e+01,  2.506628277459239e+00);
  674.     my @b = (-5.447609879822406e+01,  1.615858368580409e+02,
  675.              -1.556989798598866e+02,  6.680131188771972e+01,
  676.              -1.328068155288572e+01 );
  677.     my @c = (-7.784894002430293e-03, -3.223964580411365e-01,
  678.              -2.400758277161838e+00, -2.549732539343734e+00,
  679.               4.374664141464968e+00,  2.938163982698783e+00);
  680.     my @d = ( 7.784695709041462e-03,  3.224671290700398e-01,
  681.               2.445134137142996e+00,  3.754408661907416e+00);
  682.  
  683.     # Define break-points.
  684.     my $plow  = 0.02425;
  685.     my $phigh = 1 - $plow;
  686.  
  687.     # Rational approximation for lower region:
  688.     if ( $p < $plow ) {
  689.        my $q  = sqrt(-2*log($p));
  690.        return ((((($c[0]*$q+$c[1])*$q+$c[2])*$q+$c[3])*$q+$c[4])*$q+$c[5]) /
  691.                (((($d[0]*$q+$d[1])*$q+$d[2])*$q+$d[3])*$q+1);
  692.     }
  693.  
  694.     # Rational approximation for upper region:
  695.     if ( $phigh < $p ) {
  696.        my $q  = sqrt(-2*log(1-$p));
  697.        return -((((($c[0]*$q+$c[1])*$q+$c[2])*$q+$c[3])*$q+$c[4])*$q+$c[5]) /
  698.                 (((($d[0]*$q+$d[1])*$q+$d[2])*$q+$d[3])*$q+1);
  699.     }
  700.  
  701.     # Rational approximation for central region:
  702.     my $q = $p - 0.5;
  703.     my $r = $q*$q;
  704.     return ((((($a[0]*$r+$a[1])*$r+$a[2])*$r+$a[3])*$r+$a[4])*$r+$a[5])*$q /
  705.            ((((($b[0]*$r+$b[1])*$r+$b[2])*$r+$b[3])*$r+$b[4])*$r+1);
  706. }
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top