mirror of
https://github.com/imapsync/imapsync.git
synced 2025-06-12 15:34:52 +02:00
1356 lines
45 KiB
Perl
Executable file
1356 lines
45 KiB
Perl
Executable file
#!/usr/bin/perl -T
|
|
|
|
use strict ;
|
|
use warnings ;
|
|
use Getopt::Long ( ) ;
|
|
use LWP::UserAgent ( ) ;
|
|
use English qw( -no_match_vars ) ;
|
|
use Readonly ;
|
|
use Data::Dumper ;
|
|
use Test::More ;
|
|
use Digest::HMAC_SHA1 qw( hmac_sha1_hex ) ;
|
|
use Sys::Hostname ;
|
|
use Sys::MemInfo ;
|
|
use IPC::Open3 ( ) ;
|
|
|
|
Readonly my $RCS = q{$Id: proximapsync,v 1.9 2018/05/06 12:16:00 gilles Exp gilles $} ;
|
|
Readonly our $VERSION = version_from_rcs( $RCS ) ;
|
|
|
|
Readonly my $EX_OK => 0 ; #/* successful termination */
|
|
Readonly my $EX_USAGE => 64 ; #/* command line usage error */
|
|
|
|
Readonly my $KIBI => 1024 ;
|
|
Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API
|
|
|
|
Readonly my $nb_attempts_max => 5 ;
|
|
|
|
main( @ARGV ) ;
|
|
|
|
|
|
sub main {
|
|
my @options = @ARG ;
|
|
|
|
|
|
my $sync = init( @options ) ;
|
|
|
|
#
|
|
cgibuildheader( $sync ) ;
|
|
myprint( output( $sync ) ) ;
|
|
output_reset_with( $sync ) ;
|
|
# Header is printed so now we can use myprint
|
|
presentation( $sync ) ;
|
|
# Unit tests if asked, then exit.
|
|
testsexit( $sync ) ;
|
|
# The real stuff
|
|
loop_until_done_or_abort( $sync ) ;
|
|
|
|
|
|
myprint( debugmemory( $sync, ' after' ) ) ;
|
|
return ;
|
|
}
|
|
|
|
sub loop_until_done_or_abort{
|
|
my $mysync = shift ;
|
|
|
|
$mysync->{ nb_attempts_max } = $nb_attempts_max ;
|
|
$mysync->{ nb_attempts } = 0 ;
|
|
|
|
while ( can_and_have_to_sync( $mysync ) ) {
|
|
# ideas:
|
|
# * Warn if http instead of https
|
|
|
|
my $url = choose_remote( $mysync ) ;
|
|
myprint( "\nGonna delegate the imap sync to $url\n" ) ;
|
|
my $response = proximapsync( $mysync, $url ) ;
|
|
|
|
if ( ! $response->is_success ) {
|
|
myprint( "Failure with $url\n" ) ;
|
|
my $removed = remove_remote( $mysync ) ;
|
|
myprint( "Removed $removed from list of proxies\n" ) ;
|
|
#$mysync->{ sync_done } = 1 ;
|
|
}else{
|
|
myprint( "Success with $url\n" ) ;
|
|
$mysync->{ sync_done } = 1 ;
|
|
}
|
|
}
|
|
myprint( "No more things to do\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
sub tests_can_and_have_to_sync {
|
|
note( 'Entering tests_can_and_have_to_sync()' ) ;
|
|
is( undef, can_and_have_to_sync( ), 'can_and_have_to_sync: no args => undef' ) ;
|
|
my $mysync ;
|
|
is( undef, can_and_have_to_sync( $mysync ), 'can_and_have_to_sync: undef => undef' ) ;
|
|
$mysync = { } ;
|
|
is( undef, can_and_have_to_sync( $mysync ), 'can_and_have_to_sync: undef => undef' ) ;
|
|
|
|
$mysync->{ nb_attempts_max } = 1 ;
|
|
$mysync->{ nb_attempts } = 1 ;
|
|
$mysync->{ remote } = [ ] ;
|
|
is( 0, can_and_have_to_sync( $mysync ), 'can_and_have_to_sync: nb_attempts_max reached => 0' ) ;
|
|
|
|
|
|
|
|
|
|
note( 'Leaving tests_can_and_have_to_sync()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub can_and_have_to_sync {
|
|
my $mysync = shift ;
|
|
|
|
if ( ! defined( $mysync ) ) { return ; }
|
|
|
|
if ( ! all_defined(
|
|
$mysync->{ nb_attempts },
|
|
$mysync->{ nb_attempts_max },
|
|
$mysync->{ remote },
|
|
)
|
|
) {
|
|
myprint( "One or more parameters are missing: nb_attempts nb_attempts_max remote\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
if ( $mysync->{ nb_attempts } >= $mysync->{ nb_attempts_max } ) {
|
|
# stop
|
|
myprint( "Max attempts " . $mysync->{ nb_attempts } . " reached!\n" ) ;
|
|
return 0 ;
|
|
}
|
|
|
|
my $nb_proxies = scalar( @{ $mysync->{ remote } } ) ;
|
|
|
|
if ( $nb_proxies <= 0 ) {
|
|
myprint( "No more remote to delegate the sync to!\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
# It will be more elaborate later
|
|
if ( $mysync->{ sync_done } ) {
|
|
# stop
|
|
return 0 ;
|
|
}else{
|
|
# try again
|
|
return 1 ;
|
|
}
|
|
}
|
|
|
|
# This filter_param sub is here just during the development process
|
|
# in order to find and modify it along the way
|
|
sub filter_param {
|
|
my $mysync = shift ;
|
|
|
|
# copy the $mysync elements needed for the remote
|
|
|
|
my $remote = {} ;
|
|
for my $key ( qw(
|
|
host1 user1 password1
|
|
host2 user2 password2
|
|
abort
|
|
testslive tests
|
|
simulong
|
|
)
|
|
) {
|
|
if ( exists( $mysync->{ $key } )
|
|
and defined( $mysync->{ $key } ) ) {
|
|
$remote->{ $key } = $mysync->{ $key } ;
|
|
}
|
|
}
|
|
|
|
return $remote ;
|
|
}
|
|
|
|
sub presentation {
|
|
my $mysync = shift ;
|
|
|
|
my( $infos ) = join( q{},
|
|
"Here is proximapsync ", software_version( $mysync ),
|
|
" on host ", hostname(),
|
|
", a $OSNAME system with ",
|
|
ram_memory_info( ),
|
|
"\n",
|
|
) ;
|
|
|
|
myprint( $infos ) ;
|
|
myprint( debugmemory( $mysync, ' before' ) ) ;
|
|
myprint( "PID is $PROCESS_ID\n" ) ;
|
|
myprint( "cookie_jar file: " . $mysync->{ cookie_jar } . "\n" ) ;
|
|
|
|
#my $uri = new URI ;
|
|
#$uri->query_form( [ qw( remote https://lamiral.info/cgi-bin/imapsync ) ] ) ;
|
|
#myprint( "uri: $uri\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
sub init {
|
|
my @options = @ARG ;
|
|
my $mysync = { } ;
|
|
|
|
$mysync->{ timestart } = time ; # Is a float because of use Time::HiRres
|
|
$mysync->{ rcs } = $RCS ;
|
|
$mysync->{ memory_consumption_at_start } = memory_consumption( ) || 0 ;
|
|
|
|
my @loadavg = loadavg( ) ;
|
|
|
|
$mysync->{ cpu_number } = cpu_number( ) ;
|
|
$mysync->{ loaddelay } = load_and_delay( $mysync->{ cpu_number }, @loadavg ) ;
|
|
$mysync->{ loadavg } = join( q{ }, $loadavg[ 0 ] )
|
|
. " on $mysync->{cpu_number} cores and "
|
|
. ram_memory_info( ) ;
|
|
|
|
# Just create a CGI object if under cgi context only. Needed for get_options() call
|
|
cgibegin( $mysync ) ;
|
|
|
|
my $options_good = get_options( $mysync, @options ) ;
|
|
|
|
if ( ! defined $options_good ) { exit $EX_USAGE ; }
|
|
|
|
$mysync->{ debugmemory } = 1 ;
|
|
|
|
set_cookie_jar( $mysync ) ;
|
|
|
|
#set_default_remote( $mysync ) ;
|
|
|
|
#myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
|
|
return $mysync ;
|
|
}
|
|
|
|
sub set_default_remote {
|
|
my $mysync = shift ;
|
|
|
|
$mysync->{ remote } = ( $mysync->{ remote } )
|
|
? $mysync->{ remote }
|
|
: [ 'http://lamiral.info/cgi-bin/imapsync',
|
|
'http://lamiral.info/cgi-bin/imapsyncQQ',
|
|
'http://lamiral.info/cgi-bin/imapsyncXX',
|
|
'http://lamiral.info/cgi-bin/imapsyncKK',
|
|
] ;
|
|
|
|
return ;
|
|
}
|
|
|
|
sub set_cookie_jar {
|
|
my $mysync = shift ;
|
|
|
|
if ( -d -w "$ENV{HOME}/" ) {
|
|
$mysync->{ cookie_jar } = "$ENV{HOME}/.imapsync_cookies.txt" ;
|
|
return ;
|
|
}
|
|
|
|
if ( -d -w "/var/tmp/euid_$EFFECTIVE_USER_ID" ) {
|
|
$mysync->{ cookie_jar } = "/var/tmp/euid_$EFFECTIVE_USER_ID/imapsync_cookies.txt" ;
|
|
return ;
|
|
}
|
|
|
|
if ( -d -w '/var/tmp' ) {
|
|
mkdir "/var/tmp/euid_$EFFECTIVE_USER_ID" || return ;
|
|
$mysync->{ cookie_jar } = "/var/tmp/euid_$EFFECTIVE_USER_ID/imapsync_cookies.txt" ;
|
|
}
|
|
|
|
return ;
|
|
}
|
|
|
|
sub proximapsync {
|
|
my $mysync = shift ;
|
|
my $url = shift || return ;
|
|
my $response = post_to_url( $mysync, $url ) ;
|
|
$mysync->{ nb_attempts } += 1 ;
|
|
return $response ;
|
|
}
|
|
|
|
{
|
|
# This block is because of the lexical variable
|
|
# $status_printed that has to be initialized
|
|
# each time, even in mod_perl perl-registry context
|
|
# (the sub-function issue)
|
|
|
|
my $status_printed ;
|
|
sub post_to_url {
|
|
my $mysync = shift ;
|
|
my $url = shift ;
|
|
|
|
my $sync_remote = filter_param( $mysync ) ;
|
|
|
|
my $ua = LWP::UserAgent->new ;
|
|
push @{ $ua->requests_redirectable }, 'POST' ;
|
|
|
|
my $agent = 'proximapsync/' . software_version( $mysync ) ;
|
|
$ua->agent("$agent ") ; # append the default to the end
|
|
$ua->protocols_allowed( [ 'http', 'https'] ) ;
|
|
$ua->timeout( 10 ) ; # secondes
|
|
$ua->max_redirect( 7 ) ;
|
|
$ua->env_proxy; # Load proxy settings from *_proxy environment variables.
|
|
$ua->cookie_jar( { file => $mysync->{ cookie_jar }, autosave => 1, } ) ;
|
|
#myprint( Data::Dumper->Dump( [ $sync_remote ] ) ) ;
|
|
|
|
$status_printed = 0 ;
|
|
my $response = $ua->post( $url, ':content_cb' => \&post_callback, $sync_remote ) ;
|
|
myprint( "Remote request on $url is now finished using " . $response->redirects . " redirects by following this reverse history:\n" ) ;
|
|
myprint( response_results( $response ) ) ;
|
|
return $response ;
|
|
}
|
|
|
|
sub post_callback {
|
|
my ( $chunk, $response, $protocol ) = @_ ;
|
|
if ( ! $status_printed ) {
|
|
myprint( $response->status_line, " in post_callback\n" ) ;
|
|
$status_printed = 1 ;
|
|
}
|
|
#Do whatever you like with $chunk
|
|
myprint( $chunk ) ;
|
|
return ;
|
|
}
|
|
|
|
}
|
|
|
|
sub response_results {
|
|
my $response = shift ;
|
|
|
|
my $string = q{} ;
|
|
|
|
while ( $response ) {
|
|
$string .= $response->base . ' => ' . $response->status_line . "\n" ;
|
|
$response = $response->previous ;
|
|
}
|
|
return "$string" ;
|
|
}
|
|
|
|
sub cgibuildheader {
|
|
my $mysync = shift ;
|
|
if ( ! under_cgi_context( $mysync ) ) { return ; }
|
|
|
|
my $proximapsync_runs = $mysync->{cgi}->cookie( 'proximapsync_runs' ) || 0 ;
|
|
my $cookie = $mysync->{cgi}->cookie(
|
|
-name => 'proximapsync_runs',
|
|
-value => 1 + $proximapsync_runs,
|
|
-expires => '+20y',
|
|
-path => '/cgi-bin/proximapsync',
|
|
) ;
|
|
my $httpheader ;
|
|
if( $mysync->{ loaddelay } ) {
|
|
$httpheader = $mysync->{cgi}->header(
|
|
-type => 'text/plain',
|
|
-status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load on " . hostname() . " is $mysync->{ loadavg }",
|
|
) ;
|
|
}else{
|
|
$httpheader = $mysync->{cgi}->header(
|
|
-type => 'text/plain',
|
|
-status => '200 OK to proximapsync. ' . "Load on " . hostname() . " is $mysync->{ loadavg }",
|
|
-cookie => $cookie,
|
|
) ;
|
|
}
|
|
output_start( $mysync, $httpheader ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub tests_remote_from_credentials {
|
|
note( 'Entering tests_remote_from_credentials()' ) ;
|
|
|
|
is( undef, remote_from_credentials( ) , 'remote_from_credentials: no args => undef' ) ;
|
|
my $mysync = {} ;
|
|
|
|
is( undef, remote_from_credentials( $mysync ) , 'remote_from_credentials: undef => undef' ) ;
|
|
|
|
$mysync->{ remote } = [ 'http://def/xxx' ] ;
|
|
is( 'http://def/xxx', remote_from_credentials( $mysync ) , 'remote_from_credentials: http://def/xxx => http://def/xxx' ) ;
|
|
|
|
$mysync->{ remote } = [ 'http://abc/xxx' ] ;
|
|
is( 'http://abc/xxx', remote_from_credentials( $mysync ) , 'remote_from_credentials: http://abc/xxx => http://abc/xxx' ) ;
|
|
|
|
$mysync->{ remote } = [ 'http://abc/xxx', 'http://def/xxx' ] ;
|
|
is( 'http://def/xxx', remote_from_credentials( $mysync ) , 'remote_from_credentials: http://abc/xxx http://def/xxx => http://def/xxx' ) ;
|
|
|
|
note( 'Leaving tests_remote_from_credentials()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub remote_from_credentials {
|
|
my $mysync = shift ;
|
|
|
|
my $index = remote_index_from_credentials( $mysync ) ;
|
|
my $remote = $mysync->{ remote }->[ $index ] || undef ;
|
|
return( $remote ) ;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub tests_remote_index_from_credentials {
|
|
note( 'Entering tests_remote_index_from_credentials()' ) ;
|
|
|
|
is( 0, remote_index_from_credentials( ) , 'remote_index_from_credentials: no args => 0' ) ;
|
|
my $mysync = {} ;
|
|
|
|
is( 0, remote_index_from_credentials( $mysync ) , 'remote_index_from_credentials: undef => 0' ) ;
|
|
|
|
$mysync->{ remote } = [ 'http://def/xxx' ] ;
|
|
is( 0, remote_index_from_credentials( $mysync ) , 'remote_index_from_credentials: http://def/xxx => http://def/xxx' ) ;
|
|
|
|
$mysync->{ remote } = [ 'http://abc/xxx' ] ;
|
|
is( 0, remote_index_from_credentials( $mysync ) , 'remote_index_from_credentials: http://abc/xxx => http://abc/xxx' ) ;
|
|
|
|
$mysync->{ remote } = [ 'http://abc/xxx', 'http://def/xxx' ] ;
|
|
is( 1, remote_index_from_credentials( $mysync ) , 'remote_index_from_credentials: http://abc/xxx http://def/xxx => http://def/xxx' ) ;
|
|
|
|
note( 'Leaving tests_remote_index_from_credentials()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub remote_index_from_credentials {
|
|
my $mysync = shift ;
|
|
|
|
my $num_proxies ;
|
|
if ( 'ARRAY' eq ref( $mysync->{ remote } ) ) {
|
|
$num_proxies = scalar( @{ $mysync->{ remote } } ) ;
|
|
}else{
|
|
$num_proxies = 0 ;
|
|
}
|
|
|
|
my $string = join( q{},
|
|
$mysync->{ host1 } || q{},
|
|
$mysync->{ user1 } || q{},
|
|
$mysync->{ password1 } || q{},
|
|
$mysync->{ host2 } || q{},
|
|
$mysync->{ user2 } || q{},
|
|
$mysync->{ password2 } || q{},
|
|
) ;
|
|
|
|
my $index = index_from_string_mod( $string, $num_proxies ) ;
|
|
#my $remote = $mysync->{ remote }->[ $index ] || undef ;
|
|
return( $index ) ;
|
|
|
|
}
|
|
|
|
sub tests_remote_remove_index {
|
|
note( 'Entering tests_remote_remove_index()' ) ;
|
|
my $mysync = {} ;
|
|
is_deeply( [ ], [ remote_remove_index( $mysync, 0) ], 'remote_remove_index: [ ] 0 => [ ]' ) ;
|
|
is_deeply( [ ], $mysync->{ remote }, 'remote_remove_index: undef 0 => remote = [ ]' ) ;
|
|
|
|
$mysync->{ remote } = [ ] ;
|
|
is_deeply( [ ], [ remote_remove_index( $mysync, 0) ], 'remote_remove_index: [ ] 0 => [ ]' ) ;
|
|
is_deeply( [ ], $mysync->{ remote }, 'remote_remove_index: [ ] 0 => remote = [ ]' ) ;
|
|
|
|
$mysync->{ remote } = [ 'ABC' ] ;
|
|
is_deeply( [ 'ABC' ], [ remote_remove_index( $mysync, 0) ], 'remote_remove_index: [ ABC ] 0 => [ ABC ]' ) ;
|
|
is_deeply( [ ], $mysync->{ remote }, 'remote_remove_index: [ ABC ] 0 => remote = [ ]' ) ;
|
|
|
|
$mysync->{ remote } = [ 'ABC' ] ;
|
|
is_deeply( [ ], [ remote_remove_index( $mysync, 1) ], 'remote_remove_index: [ ABC ] 1 => [ ]' ) ;
|
|
is_deeply( [ 'ABC' ], $mysync->{ remote }, 'remote_remove_index: [ ABC ] 1 => remote = [ ABC ]' ) ;
|
|
|
|
$mysync->{ remote } = [ 'ABC', 'DEF' ] ;
|
|
is_deeply( [ 'ABC' ], [ remote_remove_index( $mysync, 0) ], 'remote_remove_index: [ ABC DEF ] 0 => [ ABC ]' ) ;
|
|
is_deeply( [ 'DEF' ], $mysync->{ remote }, 'remote_remove_index: [ ABC DEF ] 0 => remote = [ DEF ]' ) ;
|
|
|
|
$mysync->{ remote } = [ 'ABC', 'DEF' ] ;
|
|
is_deeply( [ 'DEF' ], [ remote_remove_index( $mysync, 1) ], 'remote_remove_index: [ ABC DEF ] 0 => [ DEF ]' ) ;
|
|
is_deeply( [ 'ABC' ], $mysync->{ remote }, 'remote_remove_index: [ ABC DEF ] 0 => remote = [ ABC ]' ) ;
|
|
|
|
note( 'Leaving tests_remote_remove_index()' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub remote_remove_index {
|
|
my $mysync = shift ;
|
|
my $index = shift ;
|
|
|
|
splice @{ $mysync->{ remote } }, $index, 1 ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub tests_index_from_string_mod {
|
|
note( 'Entering tests_index_from_string_mod()' ) ;
|
|
is( 0, index_from_string_mod( ), 'index_from_string_mod: no args => 0' ) ;
|
|
is( 0, index_from_string_mod( 'ABC' ), 'index_from_string_mod: ABC but no modulo (=> modulo 1) => 0' ) ;
|
|
is( 0, index_from_string_mod( 'DEF' ), 'index_from_string_mod: DEF but no modulo (=> modulo 1) => 0' ) ;
|
|
is( 0, index_from_string_mod( 'ABC', 1 ), 'index_from_string_mod: ABC modulo 1 => 0' ) ;
|
|
is( 0, index_from_string_mod( 'DEF', 1 ), 'index_from_string_mod: DEF modulo 1 => 0' ) ;
|
|
is( 0, index_from_string_mod( 'ABC', 2 ), 'index_from_string_mod: ABC modulo 2 => 0' ) ;
|
|
is( 1, index_from_string_mod( 'DEF', 2 ), 'index_from_string_mod: DEF modulo 2 => 1' ) ;
|
|
|
|
is( 2, index_from_string_mod( 'ABC', 3 ), 'index_from_string_mod: ABC modulo 3 => 2' ) ;
|
|
is( 0, index_from_string_mod( 'ABC', 4 ), 'index_from_string_mod: ABC modulo 4 => 0' ) ;
|
|
is( 2, index_from_string_mod( 'ABC', 5 ), 'index_from_string_mod: ABC modulo 5 => 2' ) ;
|
|
is( 2, index_from_string_mod( 'ABC', 6 ), 'index_from_string_mod: ABC modulo 6 => 2' ) ;
|
|
is( 3, index_from_string_mod( 'ABC', 7 ), 'index_from_string_mod: ABC modulo 7 => 3' ) ;
|
|
|
|
my $str = q{} ;
|
|
foreach my $int ( 1 .. 31 ) { $str .= '_' . index_from_string_mod( 'ABC', $int ) ; }
|
|
is( '_0_0_2_0_2_2_3_4_2_2_4_8_1_10_2_12_9_2_1_12_17_4_16_20_7_14_2_24_13_2_21',
|
|
$str, 'index_from_string_mod: ABC modulo 1 .. 31 => ' ) ;
|
|
|
|
$str = q{} ;
|
|
foreach my $int ( 1 .. 31 ) { $str .= '_' . index_from_string_mod( 'DEF', $int ) ; }
|
|
is( '_0_1_0_1_0_3_5_1_0_5_1_9_9_5_0_1_5_9_17_5_12_1_3_9_15_9_18_5_13_15_7',
|
|
$str, 'index_from_string_mod: DEF modulo 1 .. 31 => ' ) ;
|
|
|
|
$str = q{} ;
|
|
foreach my $int ( 1 .. 31 ) { $str .= '' . index_from_string_mod( $str, 8 ) ; }
|
|
is( '3141012455013656157247430216425', $str, 'index_from_string_mod: 1 .. 31 modulo 8 => 3141012455013656157247430216425' ) ;
|
|
|
|
note( 'Leaving tests_index_from_string_mod()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub index_from_string_mod {
|
|
my $string = shift || q{} ;
|
|
my $modulo = shift || 1 ;
|
|
# from the $string, do a hash in hexa, keep the first 8 hexa "chars",
|
|
# convert this to a decimal in the range 0 2^32-1,
|
|
# and return the rest of division by $modulo
|
|
my $index = hex( substr( hmac_sha1_hex( $string ), 0, 8 ) ) % $modulo ;
|
|
#myprint( "[$index] from [$string] modulo [$modulo]\n" ) ;
|
|
|
|
return( $index ) ;
|
|
}
|
|
|
|
|
|
|
|
sub tests_choose_remote {
|
|
note( 'Entering tests_choose_remote()' ) ;
|
|
|
|
is( undef, choose_remote( ), 'choose_remote: no args => undef' ) ;
|
|
|
|
my $mysync ;
|
|
is( undef, choose_remote( $mysync ), 'choose_remote: undef => undef' ) ;
|
|
|
|
$mysync->{ remote } = [] ;
|
|
is( undef, choose_remote( $mysync ), 'choose_remote: [] => undef' ) ;
|
|
|
|
$mysync->{ remote } = [ 'A' ] ;
|
|
is( 'A', choose_remote( $mysync ), 'choose_remote: [ "A" ] => "A"' ) ;
|
|
|
|
$mysync->{ remote } = [qw(A B C)] ;
|
|
is( 'B', choose_remote( $mysync ), 'choose_remote: [ A B C ] => B' ) ;
|
|
|
|
$mysync->{ remote } = [qw(C A B)] ;
|
|
is( 'A', choose_remote( $mysync ), 'choose_remote: [ C A B ] => A' ) ;
|
|
|
|
$mysync->{ remote } = [qw(B C A)] ;
|
|
is( 'C', choose_remote( $mysync ), 'choose_remote: [ B C A ] => C' ) ;
|
|
|
|
note( 'Leaving tests_choose_remote()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub choose_remote {
|
|
# This intermediate function is there for allowing
|
|
# different way to choose a remote
|
|
my $mysync = shift ;
|
|
|
|
# anyone at random
|
|
# A preferable way could be to get a random index
|
|
# and inform of it (for an abort later)
|
|
# my $elected_index = randindex( @{ $mysync->{ remote } } ) ;
|
|
#
|
|
#my $elected = randelem( @{ $mysync->{ remote } } ) ;
|
|
|
|
# same credentials => same remote (if all proxies are presented in same number and order)
|
|
# The aim is to be able to send an abort request later to the same remote
|
|
my $elected = remote_from_credentials( $mysync ) ;
|
|
|
|
return( $elected ) ;
|
|
|
|
}
|
|
|
|
|
|
sub tests_remove_remote {
|
|
note( 'Entering tests_remove_remote()' ) ;
|
|
|
|
is( undef, remove_remote( ), 'remove_remote: no args => undef' ) ;
|
|
|
|
my $mysync ;
|
|
is( undef, remove_remote( $mysync ), 'remove_remote: undef => undef' ) ;
|
|
|
|
$mysync->{ remote } = [] ;
|
|
is( undef, remove_remote( $mysync ), 'remove_remote: [] => undef' ) ;
|
|
is_deeply( [ ], $mysync->{ remote }, 'remove_remote: [] => remote = []' ) ;
|
|
|
|
$mysync->{ remote } = [ 'A' ] ;
|
|
is( 'A', remove_remote( $mysync ), 'remove_remote: [ A ] => A' ) ;
|
|
is_deeply( [ ], $mysync->{ remote }, 'remove_remote: [ A ] => remote = [ ]' ) ;
|
|
|
|
$mysync->{ remote } = [qw(A B C)] ;
|
|
is( 'B', remove_remote( $mysync ), 'remove_remote: [ A B C ] => B' ) ;
|
|
is_deeply( [ qw(A C) ], $mysync->{ remote }, 'remove_remote: [ A B C ] => remote = [ A C ]' ) ;
|
|
|
|
$mysync->{ remote } = [qw(C A B)] ;
|
|
is( 'A', remove_remote( $mysync ), 'remove_remote: [ C A B ] => A' ) ;
|
|
is_deeply( [ qw(C B) ], $mysync->{ remote }, 'remove_remote: [ C A B ] => remote = [ C B ]' ) ;
|
|
|
|
$mysync->{ remote } = [qw(B C A)] ;
|
|
is( 'C', remove_remote( $mysync ), 'remove_remote: [ B C A ] => C' ) ;
|
|
is_deeply( [ qw(B A) ], $mysync->{ remote }, 'remove_remote: [B C A ] => remote = [ B A ]' ) ;
|
|
|
|
note( 'Leaving tests_remove_remote()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub remove_remote {
|
|
my $mysync = shift ;
|
|
|
|
my $index = remote_index_from_credentials( $mysync ) ;
|
|
my ( $removed ) = remote_remove_index( $mysync, $index ) ;
|
|
return $removed ;
|
|
}
|
|
|
|
sub tests_randelem {
|
|
note( 'Entering tests_randelem()' ) ;
|
|
is( undef, randelem( ), 'randelem: no args => undef' ) ;
|
|
is( 1, randelem( 1 ), 'randelem: 1 => 1' ) ;
|
|
is( 0, randelem( 0 ), 'randelem: 0 => 0' ) ;
|
|
is( '', randelem( '' ), 'randelem: "" => ""' ) ;
|
|
is( 'A', randelem( 'A' ), 'randelem: "A" => "A"' ) ;
|
|
my $AorB = randelem( 'A', 'B' ) ;
|
|
ok( (('A' eq $AorB) or ('B' eq $AorB)), 'randelem: "A" "B" => "A" or "B"' ) ;
|
|
|
|
note( 'Leaving tests_randelem()' ) ;
|
|
return ;
|
|
}
|
|
|
|
sub randelem {
|
|
return( $ARG[ rand( @ARG ) ] ) ;
|
|
}
|
|
|
|
# from imapsync
|
|
|
|
sub myprint { return print @ARG ; }
|
|
sub myprintf { return printf @ARG ; }
|
|
sub mysprintf {
|
|
my( $format, @list ) = @ARG ;
|
|
return sprintf $format, @list ;
|
|
}
|
|
|
|
sub firstline {
|
|
# extract the first line of a file (without \n)
|
|
|
|
my( $file ) = @_ ;
|
|
my $line = q{} ;
|
|
|
|
if ( ! -e $file ) {
|
|
myprint( "Cannot open file $file since it does not exist\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
open my $FILE, '<', $file or do {
|
|
myprint( "Error opening file $file : $OS_ERROR\n" ) ;
|
|
return ;
|
|
} ;
|
|
$line = <$FILE> || q{} ;
|
|
close $FILE ;
|
|
chomp $line ;
|
|
return $line ;
|
|
}
|
|
|
|
|
|
sub memory_consumption {
|
|
# memory consumed by imapsync until now in bytes
|
|
return( ( memory_consumption_of_pids( ) )[0] );
|
|
}
|
|
|
|
sub debugmemory {
|
|
my $mysync = shift ;
|
|
if ( ! $mysync->{debugmemory} ) { return q{} ; }
|
|
|
|
my $precision = shift ;
|
|
return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ) ;
|
|
}
|
|
|
|
sub memory_consumption_of_pids {
|
|
|
|
my @pid = @_;
|
|
@pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ;
|
|
|
|
my @val ;
|
|
if ( 'MSWin32' eq $OSNAME ) {
|
|
# MSWin32 later...
|
|
# @val = memory_consumption_of_pids_win32( @pid ) ;
|
|
}else{
|
|
# Unix
|
|
local $ENV{PATH} = '/bin';
|
|
# Use IPC::Open3 from perlcrit -3
|
|
my @ps = backtick( "ps -o vsz -p @pid" ) ;
|
|
shift @ps; # First line is column name "VSZ"
|
|
chomp @ps;
|
|
# convert to octets
|
|
@val = map { $_ * $KIBI } @ps ;
|
|
}
|
|
return( @val ) ;
|
|
}
|
|
|
|
sub backtick {
|
|
my $command = shift ;
|
|
|
|
if ( ! $command ) { return ; }
|
|
|
|
my ( $writer, $reader, $err ) ;
|
|
my @output ;
|
|
my $pid ;
|
|
my $eval = eval {
|
|
$pid = IPC::Open3::open3( $writer, $reader, $err, $command ) ;
|
|
} ;
|
|
if ( $EVAL_ERROR ) {
|
|
myprint( $EVAL_ERROR ) ;
|
|
return ;
|
|
}
|
|
if ( ! $eval ) { return ; }
|
|
if ( ! $pid ) { return ; }
|
|
waitpid( $pid, 0 ) ;
|
|
@output = <$reader>; # Output here
|
|
#
|
|
#my @errors = <$err>; #Errors here, instead of the console
|
|
if ( not @output ) { return ; }
|
|
#myprint( @output ) ;
|
|
|
|
if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; }
|
|
if ( wantarray ) {
|
|
return( @output ) ;
|
|
} else {
|
|
return( join( q{}, @output) ) ;
|
|
}
|
|
}
|
|
|
|
|
|
sub cgibegin {
|
|
if ( ! under_cgi_context( ) ) { return ; }
|
|
my $mysync = shift ;
|
|
require CGI ;
|
|
CGI->import( qw( -no_debug ) ) ;
|
|
require CGI::Carp ;
|
|
CGI::Carp->import( qw( fatalsToBrowser ) ) ;
|
|
$mysync->{cgi} = CGI->new( ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub myGetOptions {
|
|
|
|
# Started as a copy of Luke Ross Getopt::Long::CGI
|
|
# https://metacpan.org/release/Getopt-Long-CGI
|
|
# So this sub function is under the same license as Getopt-Long-CGI Luke Ross wants it,
|
|
# which was Perl 5.6 or later licenses at the date of the copy.
|
|
|
|
my $mysync = shift @ARG ;
|
|
my $arguments_ref = shift @ARG ;
|
|
my %options = @ARG ;
|
|
|
|
if ( not under_cgi_context( $mysync ) ) {
|
|
# Not CGI - pass upstream for normal command line handling
|
|
return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ;
|
|
}
|
|
|
|
my $mycgi = $mysync->{cgi} ;
|
|
|
|
# We must be in CGI context now
|
|
if ( !defined( $mycgi ) ) { return ; }
|
|
|
|
my $badthings = 0 ;
|
|
foreach my $key ( sort keys %options ) {
|
|
my $val = $options{$key} ;
|
|
|
|
if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) {
|
|
$badthings++ ;
|
|
next ; # Unknown item
|
|
}
|
|
|
|
my $name = [ split '|', $1, 1 ]->[0] ;
|
|
|
|
if ( ( $3 || q{} ) eq '+' ) {
|
|
${$val} = $mycgi->param( $name ) ; # "Incremental" integer
|
|
}
|
|
elsif ( $2 ) {
|
|
my @values = $mycgi->multi_param( $name ) ;
|
|
my $type = $2 ;
|
|
|
|
#myprint( "type[$type]values[@values]\$3[", $3 || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ;
|
|
if ( ( $3 || q{} ) eq '%' or ref( $val ) eq 'HASH' ) {
|
|
my %values = map { split /=/mxs, $_ } @values ;
|
|
|
|
if ( $type =~ m/i$/mxs ) {
|
|
foreach my $k ( keys %values ) {
|
|
$values{$k} = int $values{$k} ;
|
|
}
|
|
}
|
|
elsif ( $type =~ m/f$/mxs ) {
|
|
foreach my $k ( keys %values ) {
|
|
$values{$k} = 0 + $values{$k};
|
|
}
|
|
}
|
|
if ( 'REF' eq ref $val ) {
|
|
%{ ${$val} } = %values ;
|
|
}
|
|
else {
|
|
%{$val} = %values ;
|
|
}
|
|
}
|
|
else {
|
|
if ( $type =~ m/i$/mxs ) {
|
|
@values = map { q{} ne $_ ? int $_ : undef } @values ;
|
|
}
|
|
elsif ( $type =~ m/f$/mxs ) {
|
|
@values = map { 0 + $_ } @values ;
|
|
}
|
|
if ( ( $3 || q{} ) eq '@' ) {
|
|
@{ ${$val} } = @values ;
|
|
}
|
|
elsif ( ref( $val ) eq 'ARRAY' ) {
|
|
@{$val} = @values ;
|
|
}
|
|
else {
|
|
${$val} = $values[0] ;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
# Checkbox
|
|
# Considers only --name
|
|
# Should consider also --no-name and --noname
|
|
${$val} = $mycgi->param( $name ) ? 1 : undef ;
|
|
}
|
|
}
|
|
if ( $badthings ) {
|
|
return ;
|
|
}
|
|
else {
|
|
return ( 1 ) ;
|
|
}
|
|
}
|
|
|
|
|
|
sub tests_get_options_cgi {
|
|
note( 'Entering tests_get_options_cgi()' ) ;
|
|
|
|
# Temporary, have to think harder about testing CGI context in command line --tests
|
|
# API:
|
|
# * input arguments: two ways, command line or CGI
|
|
# * the program arguments
|
|
# * QUERY_STRING env variable
|
|
# * return
|
|
# * QUERY_STRING length
|
|
|
|
# CGI context
|
|
local $ENV{SERVER_SOFTWARE} = 'Votre serviteur' ;
|
|
|
|
# Real full test
|
|
# = 'host1=test1.lamiral.info&user1=test1&password1=secret1&host2=test2.lamiral.info&user2=test2&password2=secret2&debugenv=on'
|
|
my $mysync ;
|
|
is( undef, get_options_cgi( $mysync ), 'get_options_cgi: no CGI module => undef' ) ;
|
|
|
|
require CGI ;
|
|
CGI->import( qw( -no_debug ) ) ;
|
|
|
|
is( undef, get_options_cgi( $mysync ), 'get_options_cgi: no CGI param => undef' ) ;
|
|
# Testing boolean
|
|
$mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ;
|
|
local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ;
|
|
is( 22, get_options_cgi( $mysync ), 'get_options_cgi: QUERY_STRING => 22' ) ;
|
|
is( 1, $mysync->{ version }, 'get_options_cgi: --version => 1' ) ;
|
|
# debugenv is not allowed in cgi context
|
|
is( undef, $mysync->{debugenv}, 'get_options_cgi: $mysync->{debugenv} => undef' ) ;
|
|
|
|
# QUERY_STRING in this test is only for return value of get_options_cgi
|
|
# Have to think harder, GET/POST context, is this return value a good thing?
|
|
local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ;
|
|
$mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ;
|
|
is( 36, get_options_cgi( $mysync, ), 'get_options_cgi: QUERY_STRING => 36' ) ;
|
|
is( 'test1', $mysync->{user1}, 'get_options_cgi: $mysync->{user1} => test1' ) ;
|
|
#local $ENV{'QUERY_STRING'} = undef ;
|
|
|
|
|
|
# Testing s@ as ref
|
|
$mysync->{cgi} = CGI->new( 'folder=fd1' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is_deeply( [ 'fd1' ], $mysync->{folder}, 'get_options_cgi: $mysync->{folder} => fd1' ) ;
|
|
$mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is_deeply( [ 'fd1', 'fd2' ], $mysync->{folder}, 'get_options_cgi: $mysync->{folder} => fd1, fd2' ) ;
|
|
|
|
|
|
# Testing boolean ! with --noxxx, does not work
|
|
$mysync->{cgi} = CGI->new( 'nodry=on' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is( undef, $mysync->{dry}, 'get_options_cgi: --nodry => $mysync->{dry} => undef' ) ;
|
|
|
|
$mysync->{cgi} = CGI->new( 'host1=example.com' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is( 'example.com', $mysync->{host1}, 'get_options_cgi: --host1=example.com => $mysync->{host1} => example.com' ) ;
|
|
|
|
|
|
$mysync->{cgi} = CGI->new( 'simulong=' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is( undef, $mysync->{simulong}, 'get_options_cgi: --simulong= => $mysync->{simulong} => undef' ) ;
|
|
|
|
$mysync->{cgi} = CGI->new( 'simulong' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is( undef, $mysync->{simulong}, 'get_options_cgi: --simulong => $mysync->{simulong} => undef' ) ;
|
|
|
|
$mysync->{cgi} = CGI->new( 'simulong=4' ) ;
|
|
get_options_cgi( $mysync ) ;
|
|
is( 4, $mysync->{simulong}, 'get_options_cgi: --simulong=4 => $mysync->{simulong} => 4' ) ;
|
|
|
|
note( 'Leaving tests_get_options_cgi()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub get_options_cgi {
|
|
# In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET).
|
|
my $mysync = shift @ARG ;
|
|
my $mycgi ;
|
|
if ( under_cgi_context( ) ) {
|
|
$mycgi = $mysync->{cgi} ;
|
|
}
|
|
my @arguments = @ARG ;
|
|
# final 0 is used to print usage when no option is given
|
|
my $numopt = length $ENV{'QUERY_STRING'} || 1 ;
|
|
my $opt_ret = myGetOptions(
|
|
$mysync,
|
|
\@arguments,
|
|
'abort!' => \$mysync->{abort},
|
|
'host1=s' => \$mysync->{host1},
|
|
'host2=s' => \$mysync->{host2},
|
|
'user1=s' => \$mysync->{user1},
|
|
'user2=s' => \$mysync->{user2},
|
|
'password1=s' => \$mysync->{password1},
|
|
'password2=s' => \$mysync->{password2},
|
|
'dry!' => \$mysync->{dry},
|
|
'version' => \$mysync->{version},
|
|
'ssl1!' => \$mysync->{ssl1},
|
|
'ssl2!' => \$mysync->{ssl2},
|
|
'tls1!' => \$mysync->{tls1},
|
|
'tls2!' => \$mysync->{tls2},
|
|
'justlogin!' => \$mysync->{justlogin},
|
|
'justconnect!' => \$mysync->{justconnect},
|
|
'addheader!' => \$mysync->{addheader},
|
|
'automap!' => \$mysync->{automap},
|
|
'justautomap!' => \$mysync->{justautomap},
|
|
'gmail1' => \$mysync->{gmail1},
|
|
'gmail2' => \$mysync->{gmail2},
|
|
'office1' => \$mysync->{office1},
|
|
'office2' => \$mysync->{office2},
|
|
'exchange1' => \$mysync->{exchange1},
|
|
'exchange2' => \$mysync->{exchange2},
|
|
'domino1' => \$mysync->{domino1},
|
|
'domino2' => \$mysync->{domino2},
|
|
'f1f2=s@' => \$mysync->{f1f2},
|
|
'folder=s@' => \$mysync->{folder},
|
|
'testslive!' => \$mysync->{testslive},
|
|
'testslive6!' => \$mysync->{testslive6},
|
|
'releasecheck!' => \$mysync->{releasecheck},
|
|
'simulong=i' => \$mysync->{simulong},
|
|
'remote=s@' => \$mysync->{remote},
|
|
'debugmemory!' => \$mysync->{debugmemory},
|
|
'debug!' => \$mysync->{debug},
|
|
'tests' => \$mysync->{tests},
|
|
'testsunit=s@' => \$mysync->{testsunit},
|
|
) ;
|
|
|
|
$mysync->{debug} and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
|
|
my $numopt_after = scalar @arguments ;
|
|
|
|
if ( $numopt_after ) {
|
|
myprint( "Extra arguments found: @arguments\n", "It usually means a quoting issue in the command line\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
if ( ! $opt_ret ) {
|
|
return ;
|
|
}
|
|
return $numopt ;
|
|
}
|
|
|
|
sub tests_get_options {
|
|
note( 'Entering tests_get_options()' ) ;
|
|
|
|
# API:
|
|
# * input arguments: two ways, command line or CGI
|
|
# * the program arguments
|
|
# * QUERY_STRING env variable
|
|
# * return
|
|
# * undef if bad things happened like
|
|
# * options not known
|
|
# * number of arguments or QUERY_STRING length
|
|
my $mysync3 = { } ;
|
|
is( undef, get_options( $mysync3, qw( --noexist ) ), 'get_options: --noexist => undef' ) ;
|
|
is( undef, $mysync3->{ noexist }, 'get_options: --noexist => undef' ) ;
|
|
is( undef, get_options( $mysync3, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ;
|
|
is( 1, $mysync3->{ version }, 'get_options: --version => 1' ) ;
|
|
is( undef, $mysync3->{ noexist }, 'get_options: --noexist => undef' ) ;
|
|
$mysync3 = { } ;
|
|
get_options( $mysync3, qw( --host1 HOST_01) ) ;
|
|
is( 'HOST_01', $mysync3->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ;
|
|
is( undef, $mysync3->{ version }, 'get_options: --version => 1' ) ;
|
|
get_options( $mysync3, "--version" ) ;
|
|
is( 1, $mysync3->{ version }, 'get_options: --version => 1' ) ;
|
|
is( undef, get_options( $mysync3, qw( --help --noexist --version ) ), 'get_options: --help --noexist --version => undef' ) ;
|
|
is( undef, get_options( $mysync3, qw( extra ) ), 'get_options: extra => undef' ) ;
|
|
is( undef, get_options( $mysync3, qw( --help extra1 --version extra2 ) ), 'get_options: --help extra1 --version extra2 => undef' ) ;
|
|
#myprint( Data::Dumper->Dump( [ $mysync3 ] ) ) ;
|
|
note( 'Leaving tests_get_options()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
sub get_options {
|
|
my $mysync = shift @ARG ;
|
|
my @arguments = @ARG ;
|
|
|
|
my $ret = get_options_cgi( $mysync, @arguments ) ;
|
|
foreach my $key ( sort keys %{ $mysync } ) {
|
|
if ( ! defined $mysync->{$key} ) {
|
|
delete $mysync->{$key} ;
|
|
next ;
|
|
}
|
|
if ( 'ARRAY' eq ref( $mysync->{$key} )
|
|
and 0 == scalar( @{ $mysync->{$key} } ) ) {
|
|
delete $mysync->{$key} ;
|
|
}
|
|
}
|
|
return $ret ;
|
|
}
|
|
|
|
|
|
sub output {
|
|
my $mysync = shift @ARG ;
|
|
|
|
if ( not $mysync ) { return ; }
|
|
|
|
my @output = @ARG ;
|
|
$mysync->{ output } .= join( q{}, @output ) ;
|
|
return $mysync->{ output } ;
|
|
}
|
|
|
|
sub output_start {
|
|
my $mysync = shift @ARG ;
|
|
|
|
if ( not $mysync ) { return ; }
|
|
|
|
my @output = @ARG ;
|
|
$mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ;
|
|
return $mysync->{ output } ;
|
|
}
|
|
|
|
|
|
sub output_reset_with {
|
|
my $mysync = shift @ARG ;
|
|
|
|
if ( not $mysync ) { return ; }
|
|
|
|
my @output = @ARG ;
|
|
$mysync->{ output } = join( q{}, @output ) ;
|
|
return $mysync->{ output } ;
|
|
}
|
|
|
|
|
|
|
|
|
|
sub under_cgi_context {
|
|
|
|
# Under cgi context
|
|
if ( $ENV{SERVER_SOFTWARE} ) {
|
|
return 1 ;
|
|
}
|
|
# Not in cgi context
|
|
return ;
|
|
}
|
|
|
|
sub loadavg {
|
|
if ( 'linux' eq $OSNAME ) {
|
|
return ( loadavg_linux( @ARG ) ) ;
|
|
}
|
|
return( 'unknown' ) ;
|
|
|
|
}
|
|
|
|
sub loadavg_linux {
|
|
my $line = shift ;
|
|
|
|
if ( ! $line ) {
|
|
$line = firstline( '/proc/loadavg' ) or return ;
|
|
}
|
|
|
|
my ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) = split /\s/mxs, $line ;
|
|
if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) {
|
|
#myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ;
|
|
return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub all_defined {
|
|
if ( not @ARG ) {
|
|
return 0 ;
|
|
}
|
|
foreach my $elem ( @ARG ) {
|
|
if ( not defined $elem ) {
|
|
return 0 ;
|
|
}
|
|
}
|
|
return 1 ;
|
|
}
|
|
|
|
|
|
sub load_and_delay {
|
|
# Basically return 0 if load is not heavy, ie <= 1 per processor
|
|
|
|
if ( 4 > scalar @ARG ) { return ; }
|
|
|
|
my ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ;
|
|
|
|
if ( 0 == $cpu_num ) { return ; }
|
|
|
|
# Let divide by number of cores
|
|
( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
|
|
# One of avg ok => ok, for now it is a OR
|
|
if ( $avg_1_min <= 1 ) { return 0 ; }
|
|
if ( $avg_5_min <= 1 ) { return 1 ; } # Retry in 1 minute
|
|
if ( $avg_15_min <= 1 ) { return 5 ; } # Retry in 5 minutes
|
|
return 15 ; # Retry in 15 minutes
|
|
}
|
|
|
|
sub ram_memory_info {
|
|
# In GigaBytes so division by 1024 * 1024 * 1024
|
|
#
|
|
return(
|
|
sprintf( "%.1f/%.1f free GiB of RAM",
|
|
Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ),
|
|
Sys::MemInfo::get("totalmem") / ( $KIBI ** 3 ),
|
|
)
|
|
) ;
|
|
}
|
|
|
|
sub cpu_number {
|
|
|
|
my $cpu_number_forced = shift ;
|
|
# Well, here 1 is better than 0 or undef
|
|
my $cpu_number = 1 ; # Default value, erased if better found
|
|
|
|
my @cpuinfo ;
|
|
if ( $ENV{"NUMBER_OF_PROCESSORS"} ) {
|
|
# might be under a Windows system
|
|
$cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ;
|
|
#$debug and myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ;
|
|
}elsif ( 'darwin' eq $OSNAME ) {
|
|
$cpu_number = backtick( "sysctl -n hw.ncpu" ) ;
|
|
chomp( $cpu_number ) ;
|
|
#$debug and myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ;
|
|
}elsif ( ! -e '/proc/cpuinfo' ) {
|
|
#$debug and myprint( "Number of processors not found so I might assume there is only 1\n" ) ;
|
|
$cpu_number = 1 ;
|
|
}elsif( @cpuinfo = file_to_array( '/proc/cpuinfo' ) ) {
|
|
$cpu_number = grep { /^processor/mxs } @cpuinfo ;
|
|
#$debug and myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ;
|
|
}
|
|
|
|
if ( defined $cpu_number_forced ) {
|
|
$cpu_number = $cpu_number_forced ;
|
|
}
|
|
return( integer_or_1( $cpu_number ) ) ;
|
|
}
|
|
|
|
sub integer_or_1 {
|
|
my $number = shift ;
|
|
if ( is_an_integer( $number ) ) {
|
|
return $number ;
|
|
}
|
|
# else
|
|
return 1 ;
|
|
}
|
|
|
|
|
|
sub is_an_integer {
|
|
my $number = shift ;
|
|
if ( ! defined $number ) { return ; }
|
|
return( $number =~ m{^\d+$}xo ) ;
|
|
}
|
|
|
|
sub file_to_array {
|
|
|
|
my( $file ) = shift ;
|
|
my @string ;
|
|
|
|
open my $FILE, '<', $file or do {
|
|
myprint( "Error reading file $file : $OS_ERROR" ) ;
|
|
return ;
|
|
} ;
|
|
@string = <$FILE> ;
|
|
close $FILE ;
|
|
return( @string ) ;
|
|
}
|
|
|
|
sub software_version {
|
|
my $mysync = shift ;
|
|
my $rcs = $mysync->{rcs} ;
|
|
my $version ;
|
|
|
|
$version = version_from_rcs( $rcs ) ;
|
|
return( $version ) ;
|
|
}
|
|
|
|
|
|
sub version_from_rcs {
|
|
|
|
my $rcs = shift ;
|
|
if ( ! $rcs ) { return ; }
|
|
|
|
my $version = 'UNKNOWN' ;
|
|
|
|
if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) {
|
|
$version = $1
|
|
}
|
|
|
|
return( $version ) ;
|
|
}
|
|
|
|
|
|
|
|
sub testsexit {
|
|
my $mysync = shift ;
|
|
if ( ! ( $mysync->{ tests } or $mysync->{ testsunit } ) ) {
|
|
return ;
|
|
}
|
|
my $test_builder = Test::More->builder ;
|
|
tests( $mysync ) ;
|
|
testunitsession( $mysync ) ;
|
|
|
|
my @summary = $test_builder->summary() ;
|
|
my @details = $test_builder->details() ;
|
|
my $nb_tests_run = scalar( @summary ) ;
|
|
my $nb_tests_expected = $test_builder->expected_tests() ;
|
|
my $nb_tests_failed = count_0s( @summary ) ;
|
|
my $tests_failed = report_failures( @details ) ;
|
|
if ( $nb_tests_failed or ( $nb_tests_run != $nb_tests_expected ) ) {
|
|
#$test_builder->reset( ) ;
|
|
myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n",
|
|
"List of failed tests:\n", $tests_failed ) ;
|
|
exit $EXIT_TESTS_FAILED ;
|
|
}
|
|
exit ;
|
|
}
|
|
|
|
|
|
sub testunitsession {
|
|
my $mysync = shift ;
|
|
|
|
if ( ! $mysync ) { return ; }
|
|
if ( ! $mysync->{ testsunit } ) { return ; }
|
|
|
|
my @functions = @{ $mysync->{ testsunit } } ;
|
|
|
|
if ( ! @functions ) { return ; }
|
|
|
|
SKIP: {
|
|
if ( ! @functions ) { skip( 'No test in normal run' ) ; }
|
|
testsunit( @functions ) ;
|
|
done_testing( ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
|
|
sub count_0s {
|
|
my @array = @ARG ;
|
|
|
|
if ( ! @array ) { return 0 ; }
|
|
my $nb_zeros = 0 ;
|
|
map { $_ == 0 and $nb_zeros += 1 } @array ;
|
|
return $nb_zeros ;
|
|
}
|
|
|
|
|
|
sub report_failures {
|
|
my @details = @ARG ;
|
|
|
|
if ( ! @details ) { return ; }
|
|
|
|
my $counter = 1 ;
|
|
my $report = q{} ;
|
|
foreach my $details ( @details ) {
|
|
if ( ! $details->{ 'ok' } ) {
|
|
my $name = $details->{ 'name' } || 'NONAME' ;
|
|
$report .= "nb $counter - $name\n" ;
|
|
}
|
|
$counter += 1 ;
|
|
}
|
|
return $report ;
|
|
|
|
}
|
|
|
|
|
|
sub testsunit {
|
|
my @functions = @ARG ;
|
|
|
|
if ( ! @functions ) { #
|
|
myprint( "testsunit warning: no argument given\n" ) ;
|
|
return ;
|
|
}
|
|
|
|
foreach my $function ( @functions ) {
|
|
if ( ! $function ) {
|
|
myprint( "testsunit warning: argument is empty\n" ) ;
|
|
next ;
|
|
}
|
|
if ( ! exists &$function ) {
|
|
myprint( "testsunit warning: function $function does not exist\n" ) ;
|
|
next ;
|
|
}
|
|
if ( ! defined &$function ) {
|
|
myprint( "testsunit warning: function $function is not defined\n" ) ;
|
|
next ;
|
|
}
|
|
my $function_ref = \&{ $function } ;
|
|
&$function_ref() ;
|
|
}
|
|
return ;
|
|
}
|
|
|
|
sub tests_template {
|
|
note( 'Entering tests_template()' ) ;
|
|
is( undef, undef, 'template: undef is undef' ) ;
|
|
like( 'aBCd', qr/BC/, 'template: aBCd is like BC' ) ;
|
|
unlike( 'aCBd', qr/BC/, 'template: aCBd is not like BC' ) ;
|
|
is_deeply( {}, {}, 'template: a hash is a hash' ) ;
|
|
is_deeply( [], [], 'template: an array is an array' ) ;
|
|
note( 'Leaving tests_template()' ) ;
|
|
return ;
|
|
}
|
|
|
|
|
|
|
|
sub tests {
|
|
my $mysync = shift ;
|
|
if ( ! $mysync->{ tests } ) { return ; }
|
|
|
|
SKIP: {
|
|
if ( ! $mysync->{ tests } ) {
|
|
skip( 'No test in normal run' )
|
|
}
|
|
note( 'Entering tests()' ) ;
|
|
tests_get_options( ) ;
|
|
tests_get_options_cgi( ) ;
|
|
tests_randelem( ) ;
|
|
tests_index_from_string_mod( ) ;
|
|
tests_remote_from_credentials( ) ;
|
|
tests_choose_remote( ) ;
|
|
tests_remote_index_from_credentials( ) ;
|
|
tests_remote_remove_index( ) ;
|
|
tests_remove_remote( ) ;
|
|
tests_can_and_have_to_sync( ) ;
|
|
done_testing( 91 ) ;
|
|
note( 'Leaving tests()' ) ;
|
|
}
|
|
return ;
|
|
}
|
|
|