File Coverage

blib/lib/MToken/Util.pm
Criterion Covered Total %
statement 49 113 43.3
branch 5 32 15.6
condition 4 33 12.1
subroutine 15 32 46.8
pod 19 19 100.0
total 92 229 40.1


line stmt bran cond sub pod time code
1             package MToken::Util; # $Id: Util.pm 69 2019-06-09 16:17:44Z minus $
2 3     3   66410 use strict;
  3         13  
  3         89  
3 3     3   592 use utf8;
  3         17  
  3         17  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             MToken::Util - Exported utility functions
10              
11             =head1 VERSION
12              
13             Version 1.01
14              
15             =head1 SYNOPSIS
16              
17             use MToken::Util;
18              
19             =head1 DESCRIPTION
20              
21             Exported utility functions
22              
23             =over
24              
25             =item B
26              
27             my $servername = cleanServerName( "my.server.com" );
28              
29             Clening the specified ServerName value
30              
31             =item B
32              
33             my $filename = cleanServerName( "mtoken.12345678" );
34              
35             Clening the specified FileName value
36              
37             =item B
38              
39             print explain( $object );
40              
41             Returns Data::Dumper dump
42              
43             =item B
44              
45             my $md5 = md5sum( $file );
46              
47             See L
48              
49             =item B
50              
51             my $sha1 = sha1sum( $file );
52              
53             See L
54              
55             =item B
56              
57             my $fsize = filesize( $file );
58              
59             Returns file size
60              
61             =item B
62              
63             print hide_pasword('http://user:password@example.com'); # 'http://user:*****@example.com'
64              
65             Returns specified URL but without password
66              
67             =item B, B, B, B, B
68              
69             print cyan("Format %s", "text");
70              
71             Returns colored string
72              
73             =item B, B, B, B
74              
75             my $status = nope("Format %s", "text");
76              
77             Prints status message and returns status.
78              
79             For nope returns - 0; for skip, wow, yep - 1
80              
81             =item B
82              
83             my ($user, $password) = parse_credentials( 'http://user:password@example.com' );
84             my ($user, $password) = parse_credentials( new URI('http://user:password@example.com') );
85              
86             Returns credentials pair by URL or URI object
87              
88             =item B
89              
90             if (my $text = tcd_load("/my/file.tcd")) {
91             print $text; # Blah-Blah-Blah
92             } else {
93             or die("Oops");
94             }
95              
96             Load text data from TCD04 file
97              
98             =item B
99              
100             tcd_save("/my/file.tcd", "Blah-Blah-Blah") or die("Oops");
101              
102             Save text data to TCD04 file
103              
104             =back
105              
106             =head1 HISTORY
107              
108             See C file
109              
110             =head1 TO DO
111              
112             See C file
113              
114             =head1 BUGS
115              
116             * none noted
117              
118             =head1 SEE ALSO
119              
120             L, L
121              
122             =head1 AUTHOR
123              
124             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
125              
126             =head1 COPYRIGHT
127              
128             Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved
129              
130             =head1 LICENSE
131              
132             This program is free software; you can redistribute it and/or
133             modify it under the same terms as Perl itself.
134              
135             See C file and L
136              
137             =cut
138              
139 3     3   168 use vars qw/ $VERSION @EXPORT_OK @EXPORT /;
  3         6  
  3         189  
140             $VERSION = "1.01";
141              
142 3     3   17 use Carp;
  3         6  
  3         178  
143 3     3   629 use CTK::Util qw/bload bsave/;
  3         164576  
  3         261  
144 3     3   1262 use CTK::Crypt::TCD04;
  3         1645  
  3         104  
145 3     3   1601 use URI;
  3         14803  
  3         120  
146 3     3   21 use URI::Escape qw/uri_unescape/;
  3         8  
  3         174  
147 3     3   32 use Digest::MD5;
  3         10  
  3         94  
148 3     3   1435 use Digest::SHA1;
  3         1907  
  3         128  
149 3     3   1725 use Data::Dumper; #$Data::Dumper::Deparse = 1;
  3         18632  
  3         239  
150 3     3   1210 use Term::ANSIColor qw/colored/;
  3         16459  
  3         1645  
151              
152 3     3   29 use base qw/Exporter/;
  3         5  
  3         3993  
153             @EXPORT = qw(
154             yep nope skip wow
155             blue green red yellow cyan
156             );
157             @EXPORT_OK = (qw(
158             cleanServerName cleanFileName
159             filesize md5sum sha1sum
160             parse_credentials hide_pasword
161             tcd_save tcd_load
162             explain
163             ), @EXPORT);
164              
165             sub cleanServerName {
166 0   0 0 1 0 my $sn = shift // 'localhost';
167 0         0 $sn =~ s/[^a-z0-9_\-.]//ig;
168 0         0 return $sn;
169             }
170             sub cleanFileName {
171 0   0 0 1 0 my $f = shift // '';
172 0         0 $f =~ s/[^a-z0-9_\-.]//ig;
173 0         0 return $f;
174             }
175             sub sha1sum {
176 0     0 1 0 my $f = shift;
177 0         0 my $sha1 = new Digest::SHA1;
178 0         0 my $sum = '';
179 0 0       0 return $sum unless -e $f;
180 0 0 0     0 open( my $sha1_fh, '<', $f) or (carp("Can't open '$f': $!") && return $sum);
181 0 0       0 if ($sha1_fh) {
182 0         0 binmode($sha1_fh);
183 0         0 $sha1->addfile($sha1_fh);
184 0         0 $sum = $sha1->hexdigest;
185 0         0 close($sha1_fh);
186             }
187 0         0 return $sum;
188             }
189             sub md5sum {
190 0     0 1 0 my $f = shift;
191 0         0 my $md5 = new Digest::MD5;
192 0         0 my $sum = '';
193 0 0       0 return $sum unless -e $f;
194 0 0 0     0 open( my $md5_fh, '<', $f) or (carp("Can't open '$f': $!") && return $sum);
195 0 0       0 if ($md5_fh) {
196 0         0 binmode($md5_fh);
197 0         0 $md5->addfile($md5_fh);
198 0         0 $sum = $md5->hexdigest;
199 0         0 close($md5_fh);
200             }
201 0         0 return $sum;
202             }
203             sub filesize {
204 0     0 1 0 my $f = shift;
205 0         0 my $filesize = 0;
206 0 0       0 $filesize = (stat $f)[7] if -e $f;
207 0         0 return $filesize;
208             }
209             sub parse_credentials {
210 0   0 0 1 0 my $url = shift || return ();
211 0 0       0 my $uri = (ref($url) eq 'URI') ? $url : URI->new($url);
212 0   0     0 my $info = $uri->userinfo() // "";
213 0         0 my $user = $info;
214 0         0 my $pass = $info;
215 0         0 $user =~ s/:.*//;
216 0         0 $pass =~ s/^[^:]*://;
217 0   0     0 return (uri_unescape($user // ''), uri_unescape($pass // ''));
      0        
218             }
219             sub hide_pasword {
220 0   0 0 1 0 my $url = shift || return "";
221 0   0     0 my $full = shift || 0;
222 0         0 my $uri = new URI($url);
223 0         0 my ($u,$p) = parse_credentials($uri);
224 0 0 0     0 return $url unless defined($p) && length($p);
225 0 0       0 $uri->userinfo($full ? undef : sprintf("%s:*****", $u));
226 0         0 return $uri->canonical->as_string;
227             }
228             sub tcd_save {
229 1     1 1 13296 my $fn = shift;
230 1   50     7 my $text = shift // '';
231 1 50       5 carp("No file specified") unless $fn;
232 1 50       4 return unless length $text;
233 1 50       15 bsave($fn, CTK::Crypt::TCD04->new()->encrypt($text))
234             or carp("Can't save file \"$fn\"");
235 1         427 return 1;
236             }
237             sub tcd_load {
238 1     1 1 3 my $fn = shift;
239 1 50       4 carp("No file specified") unless $fn;
240 1 50 33     29 return unless -f $fn and -r _ and -s _;
      33        
241 1   50     7 return CTK::Crypt::TCD04->new()->decrypt(bload($fn) // '');
242             }
243             sub explain {
244 0     0 1   my $dumper = new Data::Dumper( [shift] );
245 0           $dumper->Indent(1)->Terse(1);
246 0 0         $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
247 0           return $dumper->Dump;
248             }
249              
250             ################
251             # Colored says
252             ################
253             sub yep {
254 0     0 1   print(green('[ OK ]'), ' ', sprintf(shift, @_), "\n");
255 0           return 1;
256             }
257             sub nope {
258 0     0 1   print(red('[ FAIL ]'), ' ', sprintf(shift, @_), "\n");
259 0           return 0;
260             }
261             sub skip {
262 0     0 1   print(yellow('[ SKIP ]'), ' ', sprintf(shift, @_), "\n");
263 0           return 1;
264             }
265             sub wow {
266 0     0 1   print(blue('[ INFO ]'), ' ', sprintf(shift, @_), "\n");
267 0           return 1;
268             }
269             # Colored helper functions
270 0     0 1   sub green { colored(['bright_green'], sprintf(shift, @_)) }
271 0     0 1   sub red { colored(['bright_red'], sprintf(shift, @_)) }
272 0     0 1   sub yellow { colored(['bright_yellow'], sprintf(shift, @_)) }
273 0     0 1   sub cyan { colored(['bright_cyan'], sprintf(shift, @_)) }
274 0     0 1   sub blue { colored(['bright_blue'], sprintf(shift, @_)) }
275              
276             1;