package Smokeping::probes::Curl; =head1 301 Moved Permanently This is a Smokeping probe module. Please use the command C to view the documentation or the command C to generate the POD document. =cut use strict; use base qw(Smokeping::probes::basefork); use Carp; my $DEFAULTBIN = "/usr/bin/curl"; sub pod_hash { return { name => "Smokeping::probes::Curl - a curl(1) probe for SmokePing", overview => "Fetches an HTTP or HTTPS URL using curl(1).", description => "(see curl(1) for details of the options below)", authors => <<'DOC', Gerald Combs Niko Tyni DOC notes => < variable than the default 20, as repetitive URL fetching may be quite heavy on the server. The URL to be tested used to be specified by the variable 'url' in earlier versions of Smokeping, and the 'host' setting did not influence it in any way. The variable name has now been changed to 'urlformat', and it can (and in most cases should) contain a placeholder for the 'host' variable. DOC see_also => "curl(1), L", } } sub probevars { my $class = shift; my $h = $class->SUPER::probevars; delete $h->{timeout}; return $class->_makevars($h, { binary => { _doc => "The location of your curl binary.", _default => $DEFAULTBIN, _sub => sub { my $val = shift; return "ERROR: Curl 'binary' $val does not point to an executable" unless -f $val and -x _; return undef; }, }, }); } sub targetvars { my $class = shift; return $class->_makevars($class->SUPER::targetvars, { _mandatory => [ 'urlformat' ], agent => { _doc => < 'User-Agent: Lynx/2.8.4rel.1 libwww-FM/2.14 SSL-MM/1.4.1 OpenSSL/0.9.6c', _sub => sub { my $val = shift; return "The Curl 'agent' string does not need any quotes around it anymore." if $val =~ /^["']/ or $val =~ /["']$/; return undef; }, }, timeout => { _doc => qq{The "-m" curl(1) option. Maximum timeout in seconds.}, _re => '\d+', _example => 20, _default => 10, }, interface => { _doc => < 'eth0', }, ssl2 => { _doc => qq{The "-2" curl(1) option. Force SSL2.}, _example => 1, }, urlformat => { _doc => < "http://%host%/", }, insecure_ssl => { _doc => < 1, }, extrare=> { _doc => < "/ /", _example => "/ /", _sub => sub { my $val = shift; return "extrare should be specified in the /regexp/ notation" unless $val =~ m,^/.*/$,; return undef; }, }, follow_redirects => { _doc => < "no", _re => "(yes|no)", _example => "yes", }, include_redirects => { _doc => < "no", _re => "(yes|no)", _example => "yes", }, extraargs => { _doc => <. DOC _example => "-6 --head --user user:password", }, }); } # derived class will mess with this through the 'features' method below my $featurehash = { agent => "-A", timeout => "-m", interface => "--interface", }; sub features { my $self = shift; my $newval = shift; $featurehash = $newval if defined $newval; return $featurehash; } sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->SUPER::new(@_); $self->_init if $self->can('_init'); # no need for this if running as a CGI $self->test_usage unless $ENV{SERVER_SOFTWARE}; return $self; } # warn about unsupported features sub test_usage { my $self = shift; my $bin = $self->{properties}{binary}; my @unsupported; my $arghashref = $self->features; my %arghash = %$arghashref; for my $feature (keys %arghash) { system("$bin $arghash{$feature} 1 0.0.0.1 >/dev/null 2>&1"); if ($? == 2) { push @unsupported, $feature; $self->do_log("Note: your curl doesn't support the $feature feature (option $arghash{$feature}), disabling it"); } } map { delete $arghashref->{$_} } @unsupported; if (`$bin -o /dev/null -w '<%{time_redirect}>\n' 0.0.0.1 2>&1` =~ /^<>/m) { $self->do_log("Note: your curl doesn't support the 'time_redirect' output variable; 'include_redirects' will not function."); } return; } sub ProbeDesc($) { return "URLs using curl(1)"; } # other than host, count and protocol-specific args come from here sub make_args { my $self = shift; my $target = shift; my @args; my %arghash = %{$self->features}; for (keys %arghash) { my $val = $target->{vars}{$_}; push @args, ($arghash{$_}, $val) if defined $val; } return @args; } # This is what derived classes will override sub proto_args { my $self = shift; my $target = shift; # XXX - It would be neat if curl had a "time_transfer". For now, # we take the total time minus the DNS lookup time. my @args = ("-w", "Time: %{time_total} DNS time: %{time_namelookup} Redirect time: %{time_redirect}\\n"); my $ssl2 = $target->{vars}{ssl2}; push (@args, "-2") if $ssl2; my $insecure_ssl = $target->{vars}{insecure_ssl}; push (@args, '-k') if $insecure_ssl; my $follow = $target->{vars}{follow_redirects}; push (@args, '-L') if $follow eq "yes"; return(@args); } sub extra_args { my $self = shift; my $target = shift; my $args = $target->{vars}{extraargs}; return () unless defined $args; my $re = $target->{vars}{extrare}; ($re =~ m,^/(.*)/$,) and $re = qr{$1}; return split($re, $args); } sub make_commandline { my $self = shift; my $target = shift; my $count = shift; my @args = $self->make_args($target); my $url = $target->{vars}{urlformat}; my $host = $target->{addr}; $url =~ s/%host%/$host/g; my @urls = split(/\s+/, $url); push @args, ("-o", "/dev/null") for (@urls); push @args, $self->proto_args($target); push @args, $self->extra_args($target); return ($self->{properties}{binary}, @args, @urls); } sub pingone { my $self = shift; my $t = shift; my @cmd = $self->make_commandline($t); $self->do_debug("executing command list " . join(",", map { qq('$_') } @cmd)); my @times; my $count = $self->pings($t); for (my $i = 0 ; $i < $count; $i++) { open(P, "-|") or exec @cmd; my $val; while (

) { chomp; /^Time: (\d+\.\d+) DNS time: (\d+\.\d+) Redirect time: (\d+\.\d+)?/ and do { $val += $1 - $2; if ($t->{vars}{include_redirects} eq "yes" and defined $3) { $val += $3; } $self->do_debug("curl output: '$_', result: $val"); }; } close P and defined $val and push @times, $val; } # carp("Got @times") if $self->debug; return sort { $a <=> $b } @times; } 1;