File Coverage

blib/lib/Fsdb/Support.pm
Criterion Covered Total %
statement 18 67 26.8
branch 0 28 0.0
condition 0 3 0.0
subroutine 6 15 40.0
pod 9 9 100.0
total 33 122 27.0


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             #
4             # Support.pm
5             # Copyright (C) 1991-2007 by John Heidemann
6             # $Id: 88483b6ffcd50120552f971d8e96d3f2e82f71dd $
7             #
8             # This program is distributed under terms of the GNU general
9             # public license, version 2. See the file COPYING
10             # in $dblibdir for details.
11             #
12              
13             package Fsdb::Support;
14              
15             =head1 NAME
16              
17             Fsdb::Support - support routines for Fsdb
18              
19             =head1 SYNOPSIS
20              
21             This class contains the bits of Fsdb::Old that needed to be kept.
22              
23             =head1 FUNCTIONS
24              
25             =cut
26              
27             @ISA = ();
28             ($VERSION) = 1.0;
29              
30             ## Module import.
31 2     2   5101 use Exporter 'import';
  2         7  
  2         152  
32             @EXPORT = qw();
33             @EXPORT_OK = qw(
34             shell_quote
35             code_prettify
36             force_numeric
37             fullname_to_sortkey
38             progname
39             $is_numeric_regexp
40             ddmmmyy_to_iso
41             );
42              
43             #
44             # our libaries
45             #
46 2     2   15 use IO::Handle;
  2         6  
  2         116  
47 2     2   16 use IO::File;
  2         6  
  2         356  
48 2     2   18 use Carp qw(croak);
  2         6  
  2         391  
49              
50 2     2   370 use Fsdb::IO::Reader;
  2         5  
  2         72  
51 2     2   330 use Fsdb::IO::Writer;
  2         6  
  2         2119  
52              
53             =head1 LOGGING REALTED FUNCTIONS
54              
55             =head2 progname
56              
57             Generate the name of our program for error messages.
58              
59             =cut
60             sub progname () {
61 0     0 1   my($prog) = ($0);
62 0           $prog =~ s@^.*/@@g;
63 0           return $prog;
64             }
65              
66             =head1 IO SETUP FUNCTIONS
67              
68             =head2 default_in(@READER_OPTIONS)
69              
70             Generate a default Fsdb::Reader object with the given READER_OPTIONS
71              
72             =cut
73             sub default_in ($@) {
74 0     0 1   my $in_fh = new IO::Handle;
75 0 0         $in_fh->fdopen(fileno(STDIN), "r") or croak progname . ": cannot open input as fsdb.\n";
76 0           my $in = new Fsdb::IO::Reader(-fh => $in_fh, @_);
77 0           return $in;
78             # $in->error and croak progname . ": cannot open input as fsdb.\n";
79             }
80              
81             =head2 default_out(@WRITER_OPTIONS)
82              
83             Generate a default Fsdb::Writer object with the given READER_OPTIONS
84              
85             =cut
86             sub default_out ($@) {
87 0     0 1   my $out_fh = new IO::Handle;
88 0 0         $out_fh->fdopen(fileno(STDOUT), "w+") or croak progname . ": cannot open stdout.\n";
89 0           my $out = new Fsdb::IO::Writer(-fh => $out_fh, @_);
90 0           return $out;
91             # $out->error and croak progname . ": cannot open STDOUT as fsdb.\n";
92             }
93              
94             =head1 CONVERSION FUNCTIONS
95              
96             =head2 code_prettify
97              
98             Convert db-code into "pretty code".
99              
100             =cut
101             sub code_prettify (@) {
102 0     0 1   my($prettycode) = join(";", @_);
103 0           $prettycode =~ s/\n/ /g; # newlines will break commenting
104 0           return $prettycode;
105             }
106              
107             =head2 shell_quote
108              
109             Convert output to shell-like quoting
110              
111             =cut
112             sub shell_quote(@) {
113 0     0 1   my($s) = @_;
114 0 0         if ($s =~ /\s/) {
115             # should use String::ShellQuote, but don't want the dpeendency
116 0           $s =~ s/\'/'\\\''/g;
117 0           $s = "'" . $s . "'";
118             };
119 0           return $s;
120             }
121              
122             =head1 CONVERSION FUNCTIONS
123              
124             =head2 number_prettify
125              
126             Add-thousands-separators to numbers.
127              
128             xxx: should consider locale.
129              
130             (This code is from F,
131             contributed by Andrew Johnson from University of Alberta.)
132              
133             =cut
134             sub number_prettify($) {
135 0     0 1   my $input = shift;
136 0           $input = reverse $input;
137 0           $input =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g;
138 0           return reverse $input;
139             }
140              
141             =head2 force_numeric
142              
143             my $x = force_numeric($s, $include_non_numeric)
144              
145             Return C<$S> if it's numeric, or C if not.
146             If C<$INCLUDE_NON_NUMERIC>, then non-numeric values register as zero.
147              
148             =cut
149             # note that we tolerate spaces before and after,
150             # since field splitting doesn't always kill them
151             # (see TEST/dbcolstats_trailing_spaces.in)
152             our $is_numeric_regexp = '^\s*[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?\s*$';
153             sub force_numeric {
154 0     0 1   my($value, $zero_non_numeric) = @_;
155             # next re is almost copied from L
156 0 0         if ($value =~ /$is_numeric_regexp/) {
157 0           return $value + 0.0; # force numeric
158             } else {
159 0 0         if ($ignore_non_numeric) {
160 0           return undef;
161 0           next;
162             } else {
163 0           return 0.0;
164             };
165             };
166             }
167              
168              
169             =head2 fullname_to_sortkey
170              
171             my $sortkey = fullname_to_sortkey("John Smith");
172              
173             Convert "Firstname Lastname" to sort key "lastname, firstname".
174              
175             =cut
176             sub fullname_to_sortkey {
177 0     0 1   my($sort) = @_;
178 0           $sort = lc($sort);
179 0           my($first, $last) = ($sort =~ /^(.*)\s+(\S+)$/);
180 0 0         $last = $sort if (!defined($last));
181 0 0         $first = '' if (!defined($first));
182 0           return "$last, $first";
183             }
184              
185              
186             =head2 ddmmmyy_to_iso
187              
188             my $iso_date = ddmmmyy_to_iso('1-Jan-10')
189              
190             Converts a date in the form dd-mmm-yy to ISO-style yyyy-mm-dd.
191             Examples:
192              
193             2-Jan-70 to 1970-01-02
194             2-Jan-99 to 1999-01-02
195             2-Jan-10 to 2010-01-02
196             2-Jan-69 to 2069-01-02
197             Jan-10 to 2010-01-00
198             99 to 1999-00-00
199              
200             =cut
201             sub ddmmmyy_to_iso {
202 0     0 1   my($orig) = @_;
203 0 0         return $orig if ($orig eq '-');
204 0           my(@parts) = split('-', $orig);
205 0 0         unshift(@parts, '00') if ($#parts == 0);
206 0 0         unshift(@parts, '00') if ($#parts == 1);
207 0           my($dd, $mm, $yyyy) = @parts;
208 0 0         $dd = '0' if ($dd eq '?');
209 0           my(%map) = qw(jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8 sep 9 oct 10 nov 11 dec 12);
210 0 0         $mm = $map{lc($mm)}; $mm = 0 if (!defined($mm)); # sigh, for 5.008
  0            
211 0 0 0       $yyyy += 1900 if ($yyyy >= 70 && $yyyy < 100);
212 0 0         $yyyy += 2000 if ($yyyy < 70);
213 0           return sprintf("%04d-%02d-%02d", $yyyy, $mm, $dd);
214             }
215              
216             1;