SHARE
TWEET

memcron 0.6.5-Bret

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