X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUtil.pm;h=b01c234b80bfeea0bf1f60b25cf1679f546b8af0;hb=d0b21f21559a63d84086b549bb7570e2e16b75cd;hp=157ff609534515009faf6ff07914e690784fd349;hpb=ed993b76a84e36b22efd1fc762d6a466497bcf7e;p=spider.git diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 157ff609..b01c234b 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -14,6 +14,8 @@ use IO::File; use File::Copy; use Data::Dumper; use Time::HiRes qw(gettimeofday tv_interval); +use Text::Wrap; +use Socket qw(AF_INET6 AF_INET inet_pton); use strict; @@ -27,7 +29,8 @@ 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 _diffms _diffus difft parraydifft is_ztime basecall + normalise_call is_numeric ); @@ -155,7 +158,7 @@ sub dd # format a prompt with its current value and return it with its privilege sub promptf { - my ($line, $value) = @_; + my ($line, $value, $promptl) = @_; my ($priv, $prompt, $action) = split ',', $line; # if there is an action treat it as a subroutine and replace $value @@ -165,7 +168,8 @@ sub promptf } elsif (ref $value) { $value = dd($value); } - $prompt = sprintf "%15s: %s", $prompt, $value; + $promptl ||= 15; + $prompt = sprintf "%${promptl}s: %s", $prompt, $value; return ($priv, $prompt); } @@ -182,7 +186,7 @@ sub ptimelist my $ref = shift; my $out; for (sort keys %$ref) { - $out .= "$_=$ref->{$_}, "; + $out .= "$_=" . atime($ref->{$_}) . ", "; } chop $out; chop $out; @@ -193,7 +197,7 @@ sub ptimelist sub parray { my $ref = shift; - return ref $ref ? join(', ', @{$ref}) : $ref; + return ref $ref ? join(', ', sort @{$ref}) : $ref; } # take the arg as an array reference and print as a list of pairs @@ -219,11 +223,10 @@ sub phash my $ref = shift; my $out; - while (my ($k,$v) = each %$ref) { - $out .= "${k}=>$v, "; + foreach my $k (sort keys %$ref) { + $out .= "${k}=>$ref->{$k}, "; } - chop $out; # remove last space - chop $out; # remove last comma + $out =~ s/, $// if $out; return $out; } @@ -248,23 +251,26 @@ sub print_all_fields my @fields = $ref->fields; my $field; my $width = $self->width - 1; + my $promptl = 0; $width ||= 80; + # find the maximum length of the prompt + foreach $field (@fields) { + if (defined $ref->{$field}) { + my (undef, $prompt, undef) = split ',', $ref->field_prompt($field); + $promptl = length $prompt if length $prompt > $promptl; + } + } + + # now do print foreach $field (sort {_sort_fields($ref, $a, $b)} @fields) { if (defined $ref->{$field}) { - my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field}); + my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field}, $promptl); my @tmp; if (length $ans > $width) { + $Text::Wrap::columns = $width-2; my ($p, $a) = split /: /, $ans, 2; - my $l = (length $p) + 2; - my $al = ($width - 1) - $l; - my $bit; - while (length $a > $al ) { - ($bit, $a) = unpack "A$al A*", $a; - push @tmp, "$p: $bit"; - $p = ' ' x ($l - 2); - } - push @tmp, "$p: $a" if length $a; + @tmp = split/\n/, Text::Wrap::wrap("$p: ", (' ' x $promptl) . ': ', $a); } else { push @tmp, $ans; } @@ -280,6 +286,7 @@ sub shellregex { my $in = shift; $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge; + $in =~ s|\\/|/|g; return '^' . $in . "\$"; } @@ -374,8 +381,8 @@ sub filecopy sub unpad { my $s = shift; - $s =~ s/\s+$//; - $s =~ s/^\s+//; + $s =~ s/^\s*//; + $s =~ s/\s*$//; return $s; } @@ -383,14 +390,15 @@ sub unpad sub is_callsign { return $_[0] =~ m!^ - (?:\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) + (?:\d?[A-Z]{1,2}\d{0,2}/)? # out of area prefix / + (?:\d?[A-Z]{1,2}\d{1,5}) # main prefix one (required) - lengthened for special calls + [A-Z]{1,8} # callsign letters (required) + (?:-(?:\d{1,2}))? # - nn possibly (eg G8BPQ-8) (?:/[0-9A-Z]{1,7})? # / another prefix, callsign or special label (including /MM, /P as well as /EURO or /LGT) possibly - $!x; + (?:/(?:AM?|MM?|P))? # finally /A /AM /M /MM /P + $!xo; - # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX + # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX/MM } sub is_prefix @@ -441,7 +449,24 @@ sub is_latlong # is it an ip address? sub is_ipaddr { - return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:,]+$/; + + if ($_[0] =~ /:/) { + if (inet_pton(AF_INET6, $_[0])) { + return ($_[0] =~ /([:0-9a-f]+)/); + } +# use re 'debug'; +# return ($1) if $_[0] =~ /^(\:?(?:\:?[0-9a-f]{1,4}){1,8}?)$/i; +# no re 'debug'; + } else { + return ($_[0] =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/); + } + return undef; +} + +# is it a zulu time hhmmZ +sub is_ztime +{ + return $_[0] =~ /^(?:(?:2[0-3])|(?:[01][0-9]))[0-5][0-9]Z$/; } # insert an item into a list if it isn't already there returns 1 if there 0 if not @@ -472,19 +497,20 @@ sub deleteitem sub localdata { my $ifn = shift; - my $ofn = "$main::data/$ifn"; - my $tfn; + my $lfn = "$main::local_data/$ifn"; + my $dfn = "$main::data/$ifn"; 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; + if ((-e $dfn) && (-e $lfn)) { + $lfn = $dfn if -M $dfn < -M $lfn; + } else { + $lfn = $dfn if -e $dfn; } + } else { + $lfn = $dfn; } - return $ofn; + return $lfn; } # move a file or a directory from data -> local_data if isn't there already @@ -499,20 +525,109 @@ 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; +} + +# and in microseconds +sub _diffus +{ + my $ta = shift; + my $tb = shift || [gettimeofday]; + my $a = int($ta->[0] * 1000000) + int($ta->[1]); + my $b = int($tb->[0] * 1000000) + int($tb->[1]); + return $b - $a; +} + sub diffms { my $call = shift; my $line = shift; my $ta = shift; my $no = 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); - my $msecs = $b - $a; + my $tb = shift; + my $msecs = _diffms($ta, $tb); $line =~ s|\s+$||; my $s = "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 $adds = shift; + + my $t; + if (ref $b eq 'ARRAY') { + $t = $b->[1] - $b->[0]; + } else { + if ($adds && $adds =~ /^\d+$/ && $adds >= $b) { + $t = $adds - $b; + $adds = shift; + } else { + $t = $main::systime - $b; + } + } + return '-(ve)' if $t < 0; + my ($y,$d,$h,$m,$s); + my $out = ''; + $y = int $t / (86400*365); + $out .= sprintf ("%s${y}y", $adds?' ':'') if $y; + $t -= $y * 86400 * 365; + $d = int $t / 86400; + $out .= sprintf ("%s${d}d", $adds?' ':'') if $d; + $t -= $d * 86400; + $h = int $t / 3600; + $out .= sprintf ("%s${h}h", $adds?' ':'') if $h; + $t -= $h * 3600; + $m = int $t / 60; + $out .= sprintf ("%s${m}m", $adds?' ':'') if $m; + if (($d == 0 && $adds) || (int $adds && $adds == 2)) { + $s = int $t % 60; + $out .= sprintf ("%s${s}s", $adds?' ':'') if $s; + $out ||= sprintf ("%s0s", $adds?' ':''); + } + $out = '0s' unless length $out; + 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; +} + +sub basecall +{ + my ($r) = $_[0] =~ m{^((?:[\w\d]+/)?[\w\d]+(?:/[\w\d]+)*)(?:-\d+)?(?:-\#)?$}; + return $r; +} + +sub normalise_call +{ + my ($c, $ssid) = $_[0] =~ m|^((?:[\w\d]+/)?[\d\w]+(?:/[\w\d]+)*)(?:-(\d+))?(?:-\#)?$|; + my $ncall = $c; + $ssid += 0; + $ncall .= "-$ssid" if $ssid; + return $ncall; +} + +sub is_numeric +{ + return $_[0] =~ /^[\.\d]+$/; +}