X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUtil.pm;h=e3056e95e05a59cc78c81adaa058428bc34d497b;hb=b9dffeff7239952814342dad19db3a51def6fab7;hp=07e3f4cb3bede190e80ae629259be3b8df7da646;hpb=ca18864d1264fadfe9869b630f05c950876c2169;p=spider.git

diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm
index 07e3f4cb..e3056e95 100644
--- a/perl/DXUtil.pm
+++ b/perl/DXUtil.pm
@@ -9,15 +9,32 @@
 package DXUtil;
 
 use Date::Parse;
-use Carp;
+use IO::File;
+use File::Copy;
+use Data::Dumper;
+
+use strict;
+
+use vars qw(@month %patmap @ISA @EXPORT);
 
 require Exporter;
 @ISA = qw(Exporter);
-@EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf parray parraypairs
-             print_all_fields cltounix 
+@EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf 
+			 parray parraypairs phex 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
             );
 
+
 @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+%patmap = (
+		   '*' => '.*',
+		   '?' => '.',
+		   '[' => '[',
+		   ']' => ']'
+);
 
 # a full time for logging and other purposes
 sub atime
@@ -33,18 +50,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;
@@ -54,8 +73,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";
 }
 
@@ -72,7 +92,9 @@ sub cltounix
 	$date = "$1 $2 $3";
 	return 0 unless $time =~ /^([012]\d)([012345]\d)Z$/;
 	$time = "$1:$2 +0000";
-	return str2time("$date $time");
+	my $r = str2time("$date $time");
+	return $r unless $r;
+	return $r == -1 ? undef : $r;
 }
 
 # turn a latitude in degrees into a string
@@ -106,6 +128,22 @@ 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
 {
@@ -116,16 +154,38 @@ sub promptf
 	if ($action) {
 		my $q = qq{\$value = $action(\$value)};
 		eval $q;
+	} elsif (ref $value) {
+		$value = dd($value);
 	}
 	$prompt = sprintf "%15s: %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 .= "$_=$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(', ', @{$ref}) : $ref;
 }
 
 # take the arg as an array reference and print as a list of pairs
@@ -145,6 +205,14 @@ sub parraypairs
 	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>'
@@ -157,13 +225,212 @@ sub print_all_fields
 	my @out;
 	my @fields = $ref->fields;
 	my $field;
+	my $width = $self->width - 1;
+	$width ||= 80;
 
-	foreach $field (sort @fields) {
+	foreach $field (sort {_sort_fields($ref, $a, $b)} @fields) {
 		if (defined $ref->{$field}) {
 			my ($priv, $ans) = promptf($ref->field_prompt($field), $ref->{$field});
-			push @out, $ans if ($self->priv >= $priv);
+			my @tmp;
+			if (length $ans > $width) {
+				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;
+			} else {
+				push @tmp, $ans;
+			}
+			push @out, @tmp if ($self->priv >= $priv);
 		}
 	}
 	return @out;
 }
 
+# generate a regex from a shell type expression 
+# see 'perl cookbook' 6.9
+sub shellregex
+{
+	my $in = shift;
+	$in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge;
+	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!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)        # basic prefix
+                       (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))?  # / another one (possibly)
+					   [A-Z]{1,3}                                 # callsign letters
+					   (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))?  # / another prefix possibly
+                       (?:/[0-9A-Z]{1,2})?                        # /0-9A-Z+ possibly
+					   (?:-\d{1,2})?                              # - nn possibly
+					 $!x;
+}
+
+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 $_[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*$/;
+}
+
+# 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;
+}