API tools faq
paste
Advertisement
bret_miller

memcron 0.6.5-Bret

bret_miller
Oct 10th, 2011
82
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Perl 23.64 KB | None | 0 0
raw download clone embed print report
  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.  
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
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
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!