X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?p=spider.git;a=blobdiff_plain;f=perl%2FDXUtil.pm;h=f0e7a8ae00a341f04b5d35153b3a39a363a9b73f;hp=1291db3943ff07b75dd1fcd99377d35a6482b342;hb=d8d7d25e92a56847754a237166ca926adc2199ca;hpb=69e2746d46e5f6095530e76297aeddc1f359d4fb

diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm
index 1291db39..f0e7a8ae 100644
--- a/perl/DXUtil.pm
+++ b/perl/DXUtil.pm
@@ -3,21 +3,36 @@
 #
 # Copyright (c) 1998 - Dirk Koopman G1TLH
 #
-# $Id$
+#
 #
 
 package DXUtil;
 
+
 use Date::Parse;
-use Carp;
+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);
 
 require Exporter;
 @ISA = qw(Exporter);
 @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf 
-			 parray parraypairs shellregex
-             print_all_fields cltounix 
+			 parray parraypairs phex phash shellregex readfilestr writefilestr
+			 filecopy ptimelist
+             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 _diffus difft parraydifft is_ztime basecall
+			 normalise_call is_numeric
             );
 
+
 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 %patmap = (
 		   '*' => '.*',
@@ -26,6 +41,11 @@ require Exporter;
 		   ']' => ']'
 );
 
+$pi = 3.141592653589;
+$d2r = ($pi/180);
+$r2d = (180/$pi);
+
+
 # a full time for logging and other purposes
 sub atime
 {
@@ -40,18 +60,20 @@ sub atime
 sub ztime
 {
 	my $t = shift;
-	my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time);
-	$year += 1900;
-	my $buf = sprintf "%02d%02dZ", $hour, $min;
+	$t = defined $t ? $t : time;
+	my $dst = shift;
+	my ($sec,$min,$hour) = $dst ? localtime($t): gmtime($t);
+	my $buf = sprintf "%02d%02d%s", $hour, $min, ($dst) ? '' : 'Z';
 	return $buf;
-
 }
 
 # get a cluster format date (23-Jun-1998)
 sub cldate
 {
 	my $t = shift;
-	my ($sec,$min,$hour,$mday,$mon,$year) = gmtime((defined $t) ? $t : time);
+	$t = defined $t ? $t : time;
+	my $dst = shift;
+	my ($sec,$min,$hour,$mday,$mon,$year) = $dst ? localtime($t) : gmtime($t);
 	$year += 1900;
 	my $buf = sprintf "%2d-%s-%04d", $mday, $month[$mon], $year;
 	return $buf;
@@ -61,8 +83,9 @@ sub cldate
 sub cldatetime
 {
 	my $t = shift;
-	my $date = cldate($t);
-	my $time = ztime($t);
+	my $dst = shift;
+	my $date = cldate($t, $dst);
+	my $time = ztime($t, $dst);
 	return "$date $time";
 }
 
@@ -115,26 +138,65 @@ sub yesno
 	return $n ? $main::yes : $main::no;
 }
 
+# provide a data dumpered version of the object passed
+sub dd
+{
+	my $value = shift;
+	my $dd = new Data::Dumper([$value]);
+	$dd->Indent(0);
+	$dd->Terse(1);
+    $dd->Quotekeys($] < 5.005 ? 1 : 0);
+	$value = $dd->Dumpxs;
+	$value =~ s/([\r\n\t])/sprintf("%%%02X", ord($1))/eg;
+	$value =~ s/^\s*\[//;
+    $value =~ s/\]\s*$//;
+	
+	return $value;
+}
+
 # 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
 	if ($action) {
 		my $q = qq{\$value = $action(\$value)};
 		eval $q;
+	} elsif (ref $value) {
+		$value = dd($value);
 	}
-	$prompt = sprintf "%15s: %s", $prompt, $value;
+	$promptl ||= 15;
+	$prompt = sprintf "%${promptl}s: %s", $prompt, $value;
 	return ($priv, $prompt);
 }
 
+# turn a hex field into printed hex
+sub phex
+{
+	my $val = shift;
+	return sprintf '%X', $val;
+}
+
+# take an arg as a hash of call=>time pairs and print it
+sub ptimelist
+{
+	my $ref = shift;
+	my $out;
+	for (sort keys %$ref) {
+		$out .= "$_=" . atime($ref->{$_}) . ", ";
+	}
+	chop $out;
+	chop $out;
+	return $out;	
+}
+
 # take an arg as an array list and print it
 sub parray
 {
 	my $ref = shift;
-	return join(', ', @{$ref});
+	return ref $ref ? join(', ', sort @{$ref}) : $ref;
 }
 
 # take the arg as an array reference and print as a list of pairs
@@ -143,7 +205,7 @@ sub parraypairs
 	my $ref = shift;
 	my $i;
 	my $out;
-  
+
 	for ($i = 0; $i < @$ref; $i += 2) {
 		my $r1 = @$ref[$i];
 		my $r2 = @$ref[$i+1];
@@ -154,6 +216,27 @@ sub parraypairs
 	return $out;
 }
 
+# take the arg as a hash reference and print it out as such
+sub phash
+{
+	my $ref = shift;
+	my $out;
+
+	foreach my $k (sort keys %$ref) {
+		$out .= "${k}=>$ref->{$k}, ";
+	}
+	$out =~ s/, $// if $out;
+	return $out;
+}
+
+sub _sort_fields
+{
+	my $ref = shift;
+	my @a = split /,/, $ref->field_prompt(shift); 
+	my @b = split /,/, $ref->field_prompt(shift); 
+	return lc $a[1] cmp lc $b[1];
+}
+
 # print all the fields for a record according to privilege
 #
 # The prompt record is of the format '<priv>,<prompt>[,<action>'
@@ -166,11 +249,31 @@ sub print_all_fields
 	my @out;
 	my @fields = $ref->fields;
 	my $field;
+	my $width = $self->width - 1;
+	my $promptl = 0;
+	$width ||= 80;
 
-	foreach $field (sort @fields) {
+	# find the maximum length of the prompt
+	foreach $field (@fields) {
 		if (defined $ref->{$field}) {
-			my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
-			push @out, $ans if ($self->priv >= $priv);
+			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}, $promptl);
+			my @tmp;
+			if (length $ans > $width) {
+				$Text::Wrap::columns = $width-2;
+				my ($p, $a) = split /: /, $ans, 2;
+				@tmp = split/\n/, Text::Wrap::wrap("$p: ", (' ' x $promptl) . ': ', $a);
+			} else {
+				push @tmp, $ans;
+			}
+			push @out, @tmp if ($self->priv >= $priv);
 		}
 	}
 	return @out;
@@ -182,5 +285,337 @@ sub shellregex
 {
 	my $in = shift;
 	$in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
-	return '^' . $in . '$';
+	$in =~ s|\\/|/|g;
+	return '^' . $in . "\$";
+}
+
+# read in a file into a string and return it. 
+# the filename can be split into a dir and file and the 
+# file can be in upper or lower case.
+# there can also be a suffix
+sub readfilestr
+{
+	my ($dir, $file, $suffix) = @_;
+	my $fn;
+	my $f;
+	if ($suffix) {
+		$f = uc $file;
+		$fn = "$dir/$f.$suffix";
+		unless (-e $fn) {
+			$f = lc $file;
+			$fn = "$dir/$file.$suffix";
+		}
+	} elsif ($file) {
+		$f = uc $file;
+		$fn = "$dir/$file";
+		unless (-e $fn) {
+			$f = lc $file;
+			$fn = "$dir/$file";
+		}
+	} else {
+		$fn = $dir;
+	}
+
+	my $fh = new IO::File $fn;
+	my $s = undef;
+	if ($fh) {
+		local $/ = undef;
+		$s = <$fh>;
+		$fh->close;
+	}
+	return $s;
+}
+
+# write out a file in the format required for reading
+# in via readfilestr, it expects the same arguments 
+# and a reference to an object
+sub writefilestr
+{
+	my $dir = shift;
+	my $file = shift;
+	my $suffix = shift;
+	my $obj = shift;
+	my $fn;
+	my $f;
+	
+	confess('no object to write in writefilestr') unless $obj;
+	confess('object not a reference in writefilestr') unless ref $obj;
+	
+	if ($suffix) {
+		$f = uc $file;
+		$fn = "$dir/$f.$suffix";
+		unless (-e $fn) {
+			$f = lc $file;
+			$fn = "$dir/$file.$suffix";
+		}
+	} elsif ($file) {
+		$f = uc $file;
+		$fn = "$dir/$file";
+		unless (-e $fn) {
+			$f = lc $file;
+			$fn = "$dir/$file";
+		}
+	} else {
+		$fn = $dir;
+	}
+
+	my $fh = new IO::File ">$fn";
+	if ($fh) {
+		my $dd = new Data::Dumper([ $obj ]);
+		$dd->Indent(1);
+		$dd->Terse(1);
+		$dd->Quotekeys(0);
+		#	$fh->print(@_) if @_ > 0;     # any header comments, lines etc
+		$fh->print($dd->Dumpxs);
+		$fh->close;
+	}
+}
+
+sub filecopy
+{
+	copy(@_) or return $!;
+}
+
+# remove leading and trailing spaces from an input string
+sub unpad
+{
+	my $s = shift;
+	$s =~ s/\s+$//;
+	$s =~ s/^\s+//;
+	return $s;
+}
+
+# check that a field only has callsign characters in it
+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,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
+					  (?:/(?:AM?|MM?|P))?       # finally /A /AM /M /MM /P 
+					  $!xo;
+
+	# longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX/MM
+}
+
+sub is_prefix
+{
+	return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}}\d+)!x        # basic prefix
+}
+	
+
+# check that a PC protocol field is valid text
+sub is_pctext
+{
+	return undef unless length $_[0];
+	return undef if $_[0] =~ /[\x00-\x08\x0a-\x1f\x80-\x9f]/;
+	return 1;
+}
+
+# check that a PC prot flag is fairly valid (doesn't check the difference between 1/0 and */-)
+sub is_pcflag
+{
+	return $_[0] =~ /^[01\*\-]+$/;
+}
+
+# check that a thing is a frequency
+sub is_freq
+{
+	return $_[0] =~ /^\d+(?:\.\d+)?$/;
+}
+
+# check that a thing is just digits
+sub is_digits
+{
+	return $_[0] =~ /^[\d]+$/;
+}
+
+# does it look like a qra locator?
+sub is_qra
+{
+	return unless length $_[0] == 4 || length $_[0] == 6;
+	return $_[0] =~ /^[A-Ra-r][A-Ra-r]\d\d(?:[A-Xa-x][A-Xa-x])?$/;
+}
+
+# does it look like a valid lat/long
+sub is_latlong
+{
+	return $_[0] =~ /^\s*\d{1,2}\s+\d{1,2}\s*[NnSs]\s+1?\d{1,2}\s+\d{1,2}\s*[EeWw]\s*$/;
+}
+
+# is it an ip address?
+sub is_ipaddr
+{
+    return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~  /^(?:[\da-f]{1,4}:|:)(?:\:[0-9a-f]{1,4}){1,6}/i ;
+}
+
+# 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
+sub insertitem
+{
+	my $list = shift;
+	my $item = shift;
+	
+	return 1 if grep {$_ eq $item } @$list;
+	push @$list, $item;
+	return 0;
+}
+
+# delete an item from a list if it is there returns no deleted 
+sub deleteitem
+{
+	my $list = shift;
+	my $item = shift;
+	my $n = @$list;
+	
+	@$list = grep {$_ ne $item } @$list;
+	return $n - @$list;
+}
+
+# find the correct local_data directory
+# basically, if there is a local_data directory with this filename and it is younger than the
+# equivalent one in the (system) data directory then return that name rather than the system one
+sub localdata
+{
+	my $ifn = shift;
+	my $lfn = "$main::local_data/$ifn";
+	my $dfn =  "$main::data/$ifn";
+	
+	if (-e "$main::local_data") {
+		if ((-e $dfn) && (-e $lfn)) {
+			$lfn = $dfn if -M $dfn < -M $lfn;
+		} else {
+			$lfn = $dfn if -e $dfn;
+		}
+	} else {
+		$lfn = $dfn;
+	}
+
+	return $lfn;
+}
+
+# move a file or a directory from data -> local_data if isn't there already
+sub localdata_mv
+{
+	my $ifn = shift;
+	if (-e "$main::data/$ifn" ) {
+		unless (-e "$main::local_data/$ifn") {
+			move("$main::data/$ifn", "$main::local_data/$ifn") or die "localdata_mv: cannot move $ifn from '$main::data' -> '$main::local_data' $!\n";
+		}
+	}
+}
+
+# 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;
+	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 || $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+$/;
 }