X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUtil.pm;h=b60b0b0b1de4c444e301f86aa04404ed3d666b61;hb=a13f69ce9f26ea2b95be1e6de1f14f50ab7065d8;hp=d23cb92ea7daa952d57c1deacaa843aa6b329f19;hpb=bf3eac0fc8e37e0dcd9631051c838d0dbb1d33e6;p=spider.git diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index d23cb92e..b60b0b0b 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -14,7 +14,7 @@ use IO::File; use File::Copy; use Data::Dumper; use Time::HiRes qw(gettimeofday tv_interval); - +use Text::Wrap; use strict; use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT); @@ -27,7 +27,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 difft parraydifft is_ztime + diffms _diffms _diffus difft parraydifft is_ztime basecall + normalise_call is_numeric ); @@ -44,6 +45,24 @@ $d2r = ($pi/180); $r2d = (180/$pi); +# BEGIN { +# our $enable_ptonok = 0; +# our $ptonok; + + +# if ($enable_ptonok && !$main::is_win) { +# eval {require Socket; Socket->import(qw(AF_INET6 AF_INET inet_pton)); }; +# unless ($@) { +# $ptonok = !defined inet_pton(AF_INET, '016.17.184.1') +# && !defined inet_pton(AF_INET6, '2067::1:') +# # Some old versions of Socket are hopelessly broken +# && length(inet_pton(AF_INET, '1.1.1.1')) == 4; +# } +# } +# } + + + # a full time for logging and other purposes sub atime { @@ -155,7 +174,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 +184,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); } @@ -193,7 +213,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 +239,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 +267,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 +302,7 @@ sub shellregex { my $in = shift; $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge; + $in =~ s|\\/|/|g; return '^' . $in . "\$"; } @@ -374,8 +397,8 @@ sub filecopy sub unpad { my $s = shift; - $s =~ s/\s+$//; - $s =~ s/^\s+//; + $s =~ s/^\s*//; + $s =~ s/\s*$//; return $s; } @@ -385,12 +408,13 @@ sub is_callsign return $_[0] =~ m!^ (?:\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,5} # callsign letters (required) + [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 +465,25 @@ sub is_latlong # is it an ip address? sub is_ipaddr { - return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:,]+$/; + $_[0] =~ s|/\d+$||; + # if ($ptonok) { + # if ($_[0] =~ /:/) { + # if (inet_pton(AF_INET6, $_[0])) { + # return ($_[0] =~ /([:0-9a-f]+)/); + # } + # } else { + # if (inet_pton(AF_INET, $_[0])) { + # return ($_[0] =~ /([\.\d]+)/); + # } + # } + # } else { + if ($_[0] =~ /:/) { + return ($_[0] =~ /^((?:\:?\:?[0-9a-f]{0,4}){1,8}\:?\:?)$/i); + } else { + return ($_[0] =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/); + } +# } + return undef; } # is it a zulu time hhmmZ @@ -478,19 +520,20 @@ sub deleteitem sub localdata { my $ifn = shift; - my $ofn = "$main::local_data/$ifn"; - my $tfn; + my $lfn = "$main::local_data/$ifn"; + my $dfn = "$main::data/$ifn"; if (-e "$main::local_data") { - $tfn = "$main::data/$ifn"; - if ((-e $tfn) && (-e $ofn)) { - $ofn = $tfn if -M $ofn < -M $tfn; + if ((-e $dfn) && (-e $lfn)) { + $lfn = $dfn if -M $dfn < -M $lfn; } else { - $ofn = $tfn if -e $tfn; + $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 @@ -514,6 +557,16 @@ sub _diffms 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; @@ -533,13 +586,13 @@ sub diffms sub difft { my $b = shift; - my $adds = shift; + my $adds = shift // 0; my $t; if (ref $b eq 'ARRAY') { $t = $b->[1] - $b->[0]; } else { - if ($adds >= $b) { + if ($adds && $adds =~ /^\d+$/ && $adds >= $b) { $t = $adds - $b; $adds = shift; } else { @@ -547,8 +600,11 @@ sub difft } } return '-(ve)' if $t < 0; - my ($d,$h,$m,$s); + 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; @@ -557,11 +613,12 @@ sub difft $t -= $h * 3600; $m = int $t / 60; $out .= sprintf ("%s${m}m", $adds?' ':'') if $m; - if ($d == 0 && $adds || $adds == 2) { + 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; } @@ -577,3 +634,25 @@ sub parraydifft $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]+$/; +} + +1;