X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUtil.pm;h=500a615023ebdcf3fcf22fd001d715814c9372f2;hb=2462f5e2370ec0bdafe12deea0d131ea3718fb29;hp=bad92927dff99fea8340977746ddd0c8c92792f4;hpb=c3c40fa3708eb08ec5e81dbbff35deec6e2c44e4;p=spider.git diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index bad92927..500a6150 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -13,7 +13,7 @@ use Date::Parse; use IO::File; use File::Copy; use Data::Dumper; - +use Time::HiRes qw(gettimeofday tv_interval); use strict; @@ -27,6 +27,7 @@ require Exporter; print_all_fields cltounix unpad is_callsign is_latlong is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem is_prefix dd is_ipaddr $pi $d2r $r2d localdata localdata_mv + diffms _diffms difft parraydifft ); @@ -140,6 +141,7 @@ sub dd { my $value = shift; my $dd = new Data::Dumper([$value]); + $dd->Sortkeys(1); $dd->Indent(0); $dd->Terse(1); $dd->Quotekeys($] < 5.005 ? 1 : 0); @@ -181,7 +183,7 @@ sub ptimelist my $ref = shift; my $out; for (sort keys %$ref) { - $out .= "$_=$ref->{$_}, "; + $out .= "$_=" . atime($ref->{$_}) . ", "; } chop $out; chop $out; @@ -382,11 +384,11 @@ sub unpad sub is_callsign { return $_[0] =~ m!^ - (?:(?:[A-Z]{1,2}\d* | \d[A-Z]{1,2}\d*)/)? # out of area prefix / - (?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)? # main prefix one - [A-Z]{1,5} # callsign letters - (?:-(?:\d{1,2}|\#))? # - nn possibly (eg G8BPQ-8) or -# (an RBN spot) - (?:/[0-9A-Z]{1,7})? # / another prefix, callsign or special label (including /MM, /P as well as /EURO or /LGT) possibly + (?:\d?[A-Z]{1,2}\d*/)? # out of area prefix / + (?:\d?[A-Z]{1,2}\d+) # main prefix one (required) + [A-Z]{1,5} # callsign letters (required) + (?:-(?:\d{1,2}|\#))? # - nn possibly (eg G8BPQ-8) or -# (an RBN spot) + (?:/[0-9A-Z]{1,7})? # / another prefix, callsign or special label (including /MM, /P as well as /EURO or /LGT) possibly $!x; # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX @@ -440,7 +442,7 @@ sub is_latlong # is it an ip address? sub is_ipaddr { - return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:]+$/; + return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:,]+$/; } # insert an item into a list if it isn't already there returns 1 if there 0 if not @@ -471,15 +473,15 @@ sub deleteitem sub localdata { my $ifn = shift; - my $ofn = "$main::data/$ifn"; + my $ofn = "$main::local_data/$ifn"; my $tfn; if (-e "$main::local_data") { - $tfn = "$main::local_data/$ifn"; - if (-e $tfn && -e $ofn) { - $ofn = $tfn if -M $tfn < -M $ofn; - } elsif (-e $tfn) { - $ofn = $tfn; + $tfn = "$main::data/$ifn"; + if ((-e $tfn) && (-e $ofn)) { + $ofn = $tfn if -M $ofn < -M $tfn; + } else { + $ofn = $tfn if -e $tfn; } } @@ -497,3 +499,67 @@ sub localdata_mv } } +# measure the time taken for something to happen; use Time::HiRes qw(gettimeofday tv_interval); +sub _diffms +{ + my $ta = shift; + my $tb = shift || [gettimeofday]; + my $a = int($ta->[0] * 1000) + int($ta->[1] / 1000); + my $b = int($tb->[0] * 1000) + int($tb->[1] / 1000); + return $b - $a; +} + +sub diffms +{ + my $pkg = shift; + my $call = shift; + my $line = shift; + my $ta = shift; + my $no = shift; + my $tb = shift; + my $msecs = _diffms($ta, $tb); + + $line =~ s|\s+$||; + my $s = "$pkg subprocess stats cmd: '$line' $call ${msecs}mS"; + $s .= " $no lines" if $no; + DXDebug::dbg($s); +} + +# expects either an array reference or two times (in the correct order [start, end]) +sub difft +{ + my $b = shift; + my $t; + if (ref $b eq 'ARRAY') { + $t = $b->[1] - $b->[0]; + } else { + $t = shift() - $b; + } + return '-(ve)' if $t < 0; + my ($d,$h,$m,$s); + my $out = ''; + $d = int $t / 86400; + $out .= "${d}d" if $d; + $t -= $d * 86400; + $h = int $t / 3600; + $out .= "${h}h" if $h || $d; + $t -= $h * 3600; + $m = int $t / 60; + $out .= "${m}m" if $m || $h || $d; + $s = int $t % 60; + $out .= "${s}s"; + return $out; +} + +# print an array ref of difft refs +sub parraydifft +{ + my $r = shift; + my $out = ''; + for (@$r) { + my $s = $_->[2] ? "($_->[2])" : ''; + $out .= sprintf "%s=%s$s, ", atime($_->[0]), difft($_->[0], $_->[1]); + } + $out =~ s/,\s*$//; + return $out; +}