File Coverage

blib/lib/CTK/Util.pm
Criterion Covered Total %
statement 160 710 22.5
branch 42 356 11.8
condition 15 312 4.8
subroutine 41 114 35.9
pod 88 88 100.0
total 346 1580 21.9


line stmt bran cond sub pod time code
1             package CTK::Util;
2 20     20   236954 use strict;
  20         67  
  20         950  
3 20     20   1596 use utf8;
  20         63  
  20         98  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::Util - CTK Utilities
10              
11             =head1 VERSION
12              
13             Version 2.83
14              
15             =head1 SYNOPSIS
16              
17             use CTK::Util;
18             use CTK::Util qw( :BASE ); # Export only BASE subroutines. See TAGS section
19              
20             my @ls = ls(".");
21              
22             =head1 DESCRIPTION
23              
24             Public utility functions. No function is not exported by default!
25              
26             =head2 FUNCTIONS
27              
28             All subroutines are listed in alphabetical order
29              
30             =head3 basetime
31              
32             $secs = basetime();
33              
34             The time at which the program began running, in seconds.
35             This function returns result of expression:
36              
37             time() - $^T
38              
39             Tags: BASE, DATE
40              
41             =head3 bload, file_load
42              
43             $bindata = bload( $file_or_fh, $onutf8 );
44              
45             Reading file in binary mode as ':raw:utf8' layer (if $onutf8 is true) or regular binary layer.
46              
47             Tags: BASE, FILE, ATOM
48              
49             =head3 bsave, file_save
50              
51             $status = bsave( $file_or_fh, $bindata, $onutf8 );
52              
53             Saving file in binary mode as ':raw:utf8' layer (if $onutf8 is true) or regular binary layer.
54              
55             Tags: BASE, FILE, ATOM
56              
57             =head3 cachedir
58              
59             my $value = cachedir();
60              
61             For example value can be set as: /var/cache
62              
63             /var/cache is intended for cached data from applications. Such data is locally generated as a result of
64             time-consuming I/O or calculation. The application must be able to regenerate or restore the data. Unlike
65             /var/spool, the cached files can be deleted without data loss. The data must remain valid between invocations
66             of the application and rebooting the system.
67              
68             Files located under /var/cache may be expired in an application specific manner, by the system administrator,
69             or both. The application must always be able to recover from manual deletion of these files (generally because of
70             a disk space shortage). No other requirements are made on the data format of the cache directories.
71              
72             See L
73              
74             Tags: CORE, BASE, FILE
75              
76             =head3 cdata
77              
78             $cdatatext = cdata( $text );
79              
80             Returns a string "" for plain XML documents.
81              
82             Tags: BASE, FORMAT
83              
84             =head3 correct_date
85              
86             $mydate = correct_date( $date );
87              
88             Returns date in format dd.mm.yyyy or null ('') if $date is wrongly.
89              
90             Tags: BASE, DATE
91              
92             =head3 correct_dig
93              
94             $mydig = correct_dig( $string );
95              
96             Returns digits only from string or 0 if string is not correctly.
97              
98             Tags: BASE, FORMAT
99              
100             =head3 correct_number
101              
102             $mynumber = correct_number( $string, $sep );
103              
104             Placement of separators discharges among digits. For example 1`234`567 if $sep is char "`" (default)
105              
106             Tags: BASE, FORMAT
107              
108             =head3 current_date
109              
110             $date = current_date();
111              
112             Returns current date in format dd.mm.yyyy
113              
114             Tags: BASE, DATE
115              
116             =head3 current_date_time
117              
118             $datetime = current_date_time();
119              
120             Returns current date in format dd.mm.yyyy hh.mm.ss
121              
122             Tags: BASE, DATE
123              
124             =head3 date2dig
125              
126             $dd = date2dig( $date );
127              
128             Returns $date (or current) in format yyyymmdd
129              
130             Tags: BASE, DATE
131              
132             =head3 date2localtime
133              
134             $time = date2localtime( $date );
135              
136             Returns time from date format dd.mm.yyyy in time() value in seconds since the system epoch
137             (Midnight, January 1, 1970 GMT on Unix, for example).
138              
139             See L
140              
141             Tags: BASE, DATE
142              
143             =head3 datef
144              
145             See L
146              
147             Tags: BASE, DATE
148              
149             =head3 date_time2dig
150              
151             $dtd = date_time2dig( $datetime );
152              
153             Returns $datetime (or current) in format yyyymmddhhmmss
154              
155             Tags: BASE, DATE
156              
157             =head3 datetime2localtime
158              
159             $time = datetime2localtime( $datetime );
160              
161             Returns time from datetime format dd.mm.yyyy hh.mm.ss in time() value in seconds since the system epoch
162             (Midnight, January 1, 1970 GMT on Unix, for example).
163              
164             See L
165              
166             Tags: BASE, DATE
167              
168             =head3 datetimef
169              
170             See L
171              
172             Tags: BASE, DATE
173              
174             =head3 dformat
175              
176             $string = dformat( $mask, \%replacehash );
177              
178             Replace substrings "[...]" in mask and
179             returns replaced result. Data for replacing get from \%replacehash
180              
181             For example:
182              
183             # -> 01-foo-bar.baz.tgz
184             $string = dformat( "01-[NAME]-bar.[EXT].tgz", {
185             NAME => 'foo',
186             EXT => 'baz',
187             } );
188              
189             See also L for working with files
190              
191             Tags: BASE, FORMAT
192              
193             =head3 dig2date
194              
195             $date = dig2date_time( $dd );
196              
197             Returns date (or current) from format yyyymmdd in format dd.mm.yyyy
198              
199             Tags: BASE, DATE
200              
201             =head3 dig2date_time
202              
203             $datetime = dig2date_time( $dtd );
204              
205             Returns date (or current) from format yyyymmddhhmmss in format dd.mm.yyyy hh.mm.ss
206              
207             Tags: BASE, DATE
208              
209             =head3 docdir
210              
211             my $value = docdir();
212              
213             For example value can be set as: /usr/share/doc
214              
215             See L
216              
217             Tags: CORE, BASE, FILE
218              
219             =head3 dtf
220              
221             $datetime = dtf( $format, $time );
222             $datetime = dtf( $format, $time, 1 ); # in GMT context
223             $datetime = dtf( $format, $time, 'MSK' ); # TimeZone (Z) = MSK
224             $datetime = dtf( $format, $time, 'GMT' ); # TimeZone (Z) = GMT
225              
226             Returns time in your format.
227             Each conversion specification is replaced by appropriate characters as described in the following list.
228              
229             s, ss, _s - Seconds
230             m, mm, _m - Minutes
231             h, hh, _h - Hours
232             D, DD, _D - Day of month
233             M, MM, _M - Month
234             Y, YY, YYY, YYYY - Year
235             w - Short form of week day (Sat, Tue and etc)
236             W - Week day (Saturdat, Tuesday and etc)
237             MON, mon - Short form of month (Apr, May and etc)
238             MONTH, month - Month (April, May and etc)
239             Z - short name of local TimeZone
240             G - short name of TimeZone GMT (for GMT context only)
241             U - short name of TimeZone UTC (for GMT context only)
242              
243             Examples:
244              
245             # RFC822 (RSS)
246             $dt = dtf("%w, %D %MON %YY %hh:%mm:%ss %G", time(), 1); # Tue, 3 Sep 2013 12:31:40 GMT
247              
248             # RFC850
249             $dt = dtf("%W, %DD-%MON-%YY %hh:%mm:%ss %G", time(), 1); # Tuesday, 03-Sep-13 12:38:41 GMT
250              
251             # RFC1036
252             $dt = dtf("%w, %D %MON %YY %hh:%mm:%ss %G", time(), 1); # Tue, 3 Sep 13 12:44:08 GMT
253              
254             # RFC1123
255             $dt = dtf("%w, %D %MON %YYYY %hh:%mm:%ss %G", time(), 1); # Tue, 3 Sep 2013 12:50:42 GMT
256              
257             # RFC2822
258             $dt = dtf("%w, %DD %MON %YYYY %hh:%mm:%ss +0400"); # Tue, 12 Feb 2013 16:07:05 +0400
259             $dt = dtf("%w, %DD %MON %YYYY %hh:%mm:%ss ".tz_diff());
260              
261             # W3CDTF, ATOM (Same as RFC 3339/ISO 8601) -- Mail format
262             $dt = dtf("%YYYY-%MM-%DDT%hh:%mm:%ss+04:00"); # 2013-02-12T16:10:28+04:00
263              
264             # CTIME
265             $dt = dtf("%w %MON %_D %hh:%mm:%ss %YYYY"); # Tue Feb 2 16:15:18 2013
266              
267             # CTIME with TimeZone
268             $dt = dtf("%w %MON %_D %hh:%mm:%ss %YYYY %Z", time(), 'MSK'); # Tue Feb 12 17:21:50 2013 MSK
269              
270             # Russian date and time format
271             $dt = dtf("%DD.%MM.%YYYY %hh:%mm:%ss"); # 12.02.2013 16:16:53
272              
273             # DIG form
274             $dt = dtf("%YYYY%MM%DD%hh%mm%ss"); # 20130212161844
275              
276             # HTTP headers format (See CGI::Util::expires)
277             $dt = dtf("%w, %DD %MON %YYYY %hh:%mm:%ss %G", time, 1); # Tue, 12 Feb 2013 13:35:04 GMT
278              
279             # HTTP/cookie format (See CGI::Util::expires)
280             $dt = dtf("%w, %DD-%MON-%YYYY %hh:%mm:%ss %G", time, 1); # Tue, 12-Feb-2013 13:35:04 GMT
281              
282             # COOKIE (RFC2616 as rfc1123-date)
283             $dt = dtf("%w, %DD %MON %YYYY %hh:%mm:%ss %G", time, 1); # Tue, 12 Feb 2013 13:35:04 GMT
284              
285             For more features please use L, L and L
286              
287             Tags: BASE, DATE
288              
289             =head3 eqtime
290              
291             eqtime("source/file", "destination/file");
292              
293             Sets modified time of destination to that of source.
294              
295             Tags: BASE, FILE, ATOM
296              
297             =head3 escape
298              
299             $safe = escape("10% is enough\n");
300              
301             Replaces each unsafe character in the string "10% is enough\n" with the corresponding
302             escape sequence and returns the result. The string argument should
303             be a string of bytes.
304              
305             See also L
306              
307             Tags: BASE, FORMAT
308              
309             =head3 execute, exe
310              
311             $out = execute( "ls -la" );
312             $out = execute( "ls -la", $in, \$err, $binmode );
313              
314             Executing external (system) command with IPC::Open3 using.
315              
316             Variables $in, $err and $binmode is OPTIONAL.
317              
318             $binmode set up binary mode layer as ':raw:utf8' layer (if $binmode is ':raw:utf8', for example) or
319             regular binary layer (if $binmode is true).
320              
321             See also L
322              
323             Tags: UTIL, EXT, ATOM
324              
325             =head3 fformat
326              
327             $file = fformat( $mask, $filename );
328              
329             Replace substrings "[FILENAME]", "[NAME]", "[FILEEXT]", "[EXT]" and "[FILE]" in mask and
330             returns replaced result. Data for replacing get from filename:
331              
332             [FILENAME] -- Fileneme only
333             [NAME] -- Fileneme only
334             [FILEEXT] -- Extension only
335             [EXT] -- Extension only
336             [FILE] -- = "[FILENAME].[FILEEXT]" ($filename)
337              
338             For example:
339              
340             $file = fformat( "01-[NAME]-bar.[EXT].tgz", "foo.baz" ); # -> 01-foo-bar.baz.tgz
341              
342             See also L
343              
344             Tags: BASE, FORMAT
345              
346             =head3 file_lf_normalize, file_nl_normalize
347              
348             file_lf_normalize( "file.txt" ) or die("Can't normalize file");
349              
350             Runs C<"lf_normalize"> for every string of the file and save result to this file
351              
352             Tags: BASE, FORMAT
353              
354             =head3 fload, load_file
355              
356             $textdata = fload( $file );
357              
358             Reading file in regular text mode
359              
360             Tags: BASE, FILE, ATOM
361              
362             =head3 from_utf8
363              
364             $win1251_text = from_utf8( $utf8_text )
365             $win1251_text = from_utf8( $utf8, "Windows-1251" )
366              
367             Encodes a string from Perl's internal form into I and returns
368             a sequence of octets. ENCODING can be either a canonical name or
369             an alias. For encoding names and aliases, see L.
370              
371             Tags: BASE, FORMAT
372              
373             =head3 fsave, save_file
374              
375             $status = fsave( $file, $textdata );
376              
377             Saving file in regular text mode
378              
379             Tags: BASE, FILE, ATOM
380              
381             =head3 ftp
382              
383             %ftpct = (
384             ftphost => '192.168.1.1',
385             ftpuser => 'login',
386             ftppassword => 'password',
387             ftpdir => '~/',
388             voidfile => './void.txt',
389             #ftpattr => {}, # See Net::FTP
390             );
391              
392             $ftpct = ftp( \%ftpct, 'connect' ); # Returns the connect's object
393             $rfiles = ftp( \%ftpct, 'ls' ); # Returns reference to array of directory listing
394             @remotefiles = $rfiles ? grep {!(/^\./)} @$rfiles : ();
395              
396             ftp( \%ftpct, 'delete', $rfile ); # Delete remote file
397             ftp( \%ftpct, 'get', $rfile, $lfile ); # Get remote file to local file
398             ftp( \%ftpct, 'put', $lfile, $rfile ); # Put local file to remote file
399              
400             Simple working with FTP.
401              
402             See also L
403              
404             Tags: UTIL, EXT, ATOM
405              
406             =head3 ftpgetlist
407              
408             $rfiles = ftpgetlist( \%ftpct, $mask);
409              
410             Returns reference to array of remote source listing by mask (as regexp, optional)
411              
412             See L
413              
414             Tags: UTIL, EXT, ATOM
415              
416             =head3 ftptest
417              
418             $status = ftptest( \%ftpct );
419              
420             FTP connect testing.
421              
422             See L
423              
424             Tags: UTIL, EXT, ATOM
425              
426             =head3 getdirlist
427              
428             $listref = getdirlist( $dir, $mask );
429              
430             Returns reference to array directories of directory $dir by $mask (regexp or scalar string).
431              
432             See also L
433              
434             Tags: BASE, FILE, ATOM
435              
436             =head3 getfilelist, getlist
437              
438             $listref = getlist( $dir, $mask );
439              
440             Returns reference to array files of directory $dir by $mask (regexp or scalar string).
441              
442             See also L
443              
444             Tags: BASE, FILE, ATOM
445              
446             =head3 getsyscfg, syscfg
447              
448             Returns all hash %Config from system module L or one value of this hash
449              
450             my %syscfg = syscfg();
451             my $prefix = syscfg( "prefix" );
452              
453             See L module for details
454              
455             Tags: API, BASE
456              
457             =head3 isos
458              
459             Returns true or false if the OS name is of the current value of C<$^O>
460              
461             isos('mswin32') ? "OK" : "NO";
462              
463             See L for details
464              
465             Tags: API, BASE
466              
467             =head3 isostype
468              
469             Given an OS type and OS name, returns true or false if the OS name is of the
470             given type.
471              
472             isostype('Windows') ? "OK" : "NO";
473             isostype('Unix', 'dragonfly') ? "OK" : "NO";
474              
475             See L
476              
477             Tags: API, BASE
478              
479             =head3 isFalseFlag
480              
481             print "Disabled" if isFalseFlag("off");
482              
483             If specified argument value is set to false then will be normalised to 1.
484              
485             The following values will be considered as false:
486              
487             no, off, 0, false, disable
488              
489             This effect is case-insensitive, i.e. both "No" or "no" will result in 1.
490              
491             Tags: BASE, UTIL
492              
493             =head3 isTrueFlag
494              
495             print "Enabled" if isTrueFlag("on");
496              
497             If specified argument value is set to true then will be normalised to 1.
498              
499             The following values will be considered as true:
500              
501             yes, on, 1, true, enable
502              
503             This effect is case-insensitive, i.e. both "Yes" or "yes" will result in 1.
504              
505             Tags: BASE, UTIL
506              
507             =head3 lf_normalize, nl_normalize
508              
509             my $normalized_string = lf_normalize( $string );
510              
511             Returns CR/LF normalized string
512              
513             Tags: BASE, FORMAT
514              
515             =head3 localedir
516              
517             my $value = localedir();
518              
519             For example value can be set as: /usr/share/locale
520              
521             See L
522              
523             Tags: CORE, BASE, FILE
524              
525             =head3 localstatedir
526              
527             my $value = localstatedir();
528              
529             For example value can be set as: /var
530              
531             /var - $Config::Config{'prefix'}
532              
533             /var contains variable data files. This includes spool directories and files, administrative and logging data, and
534             transient and temporary files.
535             Some portions of /var are not shareable between different systems. For instance, /var/log, /var/lock, and
536             /var/run. Other portions may be shared, notably /var/mail, /var/cache/man, /var/cache/fonts, and
537             /var/spool/news.
538              
539             /var is specified here in order to make it possible to mount /usr read-only. Everything that once went into /usr
540             that is written to during system operation (as opposed to installation and software maintenance) must be in /var.
541             If /var cannot be made a separate partition, it is often preferable to move /var out of the root partition and into
542             the /usr partition. (This is sometimes done to reduce the size of the root partition or when space runs low in the
543             root partition.) However, /var must not be linked to /usr because this makes separation of /usr and /var
544             more difficult and is likely to create a naming conflict. Instead, link /var to /usr/var.
545              
546             Applications must generally not add directories to the top level of /var. Such directories should only be added if
547             they have some system-wide implication, and in consultation with the FHS mailing list.
548              
549             See L
550              
551             Tags: CORE, BASE, FILE
552              
553             =head3 localtime2date
554              
555             $date = localtime2date( time() )
556              
557             Returns time in format dd.mm.yyyy
558              
559             Tags: BASE, DATE
560              
561             =head3 localtime2date_time
562              
563             $datetime = localtime2date_time( time() )
564              
565             Returns time in format dd.mm.yyyy hh.mm.ss
566              
567             Tags: BASE, DATE
568              
569             =head3 lockdir
570              
571             my $value = lockdir();
572              
573             For example value can be set as: /var/lock
574              
575             Lock files should be stored within the /var/lock directory structure.
576             Lock files for devices and other resources shared by multiple applications, such as the serial device lock files that
577             were originally found in either /usr/spool/locks or /usr/spool/uucp, must now be stored in /var/lock.
578             The naming convention which must be used is "LCK.." followed by the base name of the device. For example, to
579             lock /dev/ttyS0 the file "LCK..ttyS0" would be created. 5
580              
581             The format used for the contents of such lock files must be the HDB UUCP lock file format. The HDB format is
582             to store the process identifier (PID) as a ten byte ASCII decimal number, with a trailing newline. For example, if
583             process 1230 holds a lock file, it would contain the eleven characters: space, space, space, space, space, space,
584             one, two, three, zero, and newline.
585              
586             See L
587              
588             Tags: CORE, BASE, FILE
589              
590             =head3 ls
591              
592             @list = ls( $dir);
593             @list = ls( $dir, $mask );
594              
595             A function returns list content of directory $dir by $mask (regexp or scalar string)
596              
597             Tags: BASE, FILE, ATOM
598              
599             =head3 prefixdir
600              
601             my $value = prefixdir();
602              
603             For example value can be set as: /usr
604              
605             /usr - $Config::Config{'prefix'}
606              
607             Is a helper function and should not be used directly.
608              
609             /usr is the second major section of the filesystem. /usr is shareable, read-only data. That means that /usr
610             should be shareable between various FHS-compliant hosts and must not be written to. Any information that is
611             host-specific or varies with time is stored elsewhere.
612              
613             Large software packages must not use a direct subdirectory under the /usr hierarchy.
614              
615             See L
616              
617             Tags: CORE, BASE, FILE
618              
619             =head3 preparedir
620              
621             $status = preparedir( $dir );
622             $status = preparedir( \@dirs );
623             $status = preparedir( \%dirs );
624             $status = preparedir( $dir, $chmode );
625              
626             Preparing directory: creation and permission modification.
627             The function returns true or false.
628              
629             The $chmode argument should be a octal value, for example:
630              
631             $status = preparedir( [qw/ foo bar baz /], 0777 );
632              
633             Tags: BASE, FILE, ATOM
634              
635             =head3 randchars
636              
637             $rand = randchars( $n ); # default chars collection: 0..9,'a'..'z','A'..'Z'
638             $rand = randchars( $n, \@collection ); # Defined chars collection
639              
640             Returns random sequence of casual characters by the amount of n
641              
642             For example:
643              
644             $rand = randchars( 8, [qw/a b c d e f/]); # -> cdeccfdf
645              
646             Tags: BASE, UTIL
647              
648             =head3 randomize
649              
650             $rand = randomize( $n );
651              
652             Returns random number of the set amount of characters
653              
654             Tags: BASE, UTIL
655              
656             =head3 read_attributes
657              
658             Smart rearrangement of parameters to allow named parameter calling.
659             We do the rearrangement if the first parameter begins with a "-", but
660             since 2.82 it is optional condition
661              
662             my @args = @_;
663             my ($content, $maxcnt, $timeout, $timedie, $base, $login, $password, $host, $table_tmp);
664             ($content, $maxcnt, $timeout, $timedie, $base, $login, $password, $host, $table_tmp) =
665             read_attributes([
666             ['DATA','CONTENT','USERDATA'],
667             ['COUNT','MAXCOUNT','MAXCNT'],
668             ['TIMEOUT','FORBIDDEN','INTERVAL'],
669             ['TIMEDIE','TIME'],
670             ['BD','DB','BASE','DATABASE'],
671             ['LOGIN','USER'],
672             ['PASSWORD','PASS'],
673             ['HOST','HOSTNAME','ADDRESS','ADDR'],
674             ['TABLE','TABLENAME','NAME','SESSION','SESSIONNAME']
675             ],@args) if defined $args[0];
676              
677             See L
678              
679             Tags: API, BASE
680              
681             =head3 rundir
682              
683             my $value = rundir();
684              
685             For example value can be set as: /var/run
686              
687             This directory contains system information data describing the system since it was booted. Files under this
688             directory must be cleared (removed or truncated as appropriate) at the beginning of the boot process. Programs
689             may have a subdirectory of /var/run; this is encouraged for programs that use more than one run-time file. 7
690             Process identifier (PID) files, which were originally placed in /etc, must be placed in /var/run. The naming
691             convention for PID files is .pid. For example, the crond PID file is named
692             /var/run/crond.pid.
693              
694             See L
695              
696             Tags: CORE, BASE, FILE
697              
698             =head3 scandirs
699              
700             @dirs = scandirs( $dir, $mask );
701              
702             A function returns all directories of directory $dir by $mask (regexp or scalar string) in
703             format: [$path, $name]
704              
705             Tags: BASE, FILE, ATOM
706              
707             =head3 scanfiles
708              
709             @files = scanfiles( $dir, $mask );
710              
711             A function returns all files of directory $dir by $mask (regexp or scalar string) in
712             format: [$path, $name]
713              
714             Tags: BASE, FILE, ATOM
715              
716             =head3 sendmail, send_mail
717              
718             my $sent = sendmail(
719             -to => 'to@example.com',
720             -cc => 'cc@example.com', ### OPTIONAL
721             -from => 'from@example.com',
722             -subject => 'My subject',
723             -message => 'My message',
724             -type => 'text/plain',
725             -charset => 'utf-8', ### OPTIONAL
726             -smtp => '192.168.1.1', ### OPTIONAL
727             -smtpuser => '', ### OPTIONAL
728             -smtppass => '', ### OPTIONAL
729             -sendmail => '/usr/bin/sendmail -t', ### OPTIONAL, NOT RECOMMENDED
730             -smtpargs => { Debug=> 1, ... }, ### OPTIONAL
731             -attach => [ ### OPTIONAL
732             {
733             Type=>'text/plain',
734             Data=>'document 1 content',
735             Filename=>'doc1.txt',
736             Disposition=>'attachment',
737             },
738             {
739             Type=>'text/plain',
740             Data=>'document 2 content',
741             Filename=>'doc2.txt',
742             Disposition=>'attachment',
743             },
744             {
745             Type=>'text/html',
746             Data=>'blah-blah-blah',
747             Filename=>'response.htm',
748             Disposition=>'attachment',
749             },
750             {
751             Type=>'image/gif',
752             Path=>'aaa000123.gif',
753             Filename=>'logo.gif',
754             Disposition=>'attachment',
755             },
756             ### ... ###
757             ],
758             );
759             print($sent ? 'mail has been sent :)' : 'mail was not sent :(');
760              
761             Send UTF-8 E-mail. See L for details
762              
763             Tags: UTIL, EXT, ATOM
764              
765             =head3 sharedir
766              
767             my $value = sharedir();
768              
769             For example value can be set as: /usr/share
770              
771             The /usr/share hierarchy is for all read-only architecture independent data files. 10
772             This hierarchy is intended to be shareable among all architecture platforms of a given OS; thus, for example, a
773             site with i386, Alpha, and PPC platforms might maintain a single /usr/share directory that is
774             centrally-mounted. Note, however, that /usr/share is generally not intended to be shared by different OSes or
775             by different releases of the same OS.
776              
777             Any program or package which contains or requires data that doesn't need to be modified should store that data
778             in /usr/share (or /usr/local/share, if installed locally). It is recommended that a subdirectory be used in
779             /usr/share for this purpose.
780              
781             Game data stored in /usr/share/games must be purely static data. Any modifiable files, such as score files,
782             game play logs, and so forth, should be placed in /var/games.
783              
784             See L
785              
786             Tags: CORE, BASE, FILE
787              
788             =head3 sharedstatedir
789              
790             my $value = sharedstatedir();
791              
792             For example value can be set as: /var/lib
793              
794             This hierarchy holds state information pertaining to an application or the system. State information is data that
795             programs modify while they run, and that pertains to one specific host. Users must never need to modify files in
796             /var/lib to configure a package's operation.
797              
798             State information is generally used to preserve the condition of an application (or a group of inter-related
799             applications) between invocations and between different instances of the same application. State information
800             should generally remain valid after a reboot, should not be logging output, and should not be spooled data.
801              
802             An application (or a group of inter-related applications) must use a subdirectory of /var/lib for its data. There
803             is one required subdirectory, /var/lib/misc, which is intended for state files that don't need a subdirectory;
804             the other subdirectories should only be present if the application in question is included in the distribution.
805              
806             /var/lib/ is the location that must be used for all distribution packaging support. Different
807             distributions may use different names, of course.
808              
809             See L
810              
811             Tags: CORE, BASE, FILE
812              
813             =head3 shuffle
814              
815             @cards = shuffle(0..51); # 0..51 in a random order
816              
817             Returns the elements of LIST in a random order
818              
819             Pure-Perl implementation of Function List::Util::PP::shuffle
820             (Copyright (c) 1997-2009 Graham Barr . All rights reserved.)
821              
822             See also L
823              
824             Tags: BASE, UTIL
825              
826             =head3 slash
827              
828             $slashed = slash( $string );
829              
830             Escaping symbols \ and ' and returns strings \\ and \'
831              
832             Tags: BASE, FORMAT
833              
834             =head3 spooldir
835              
836             my $value = spooldir();
837              
838             For example value can be set as: /var/spool
839              
840             /var/spool contains data which is awaiting some kind of later processing. Data in /var/spool represents
841             work to be done in the future (by a program, user, or administrator); often data is deleted after it has been
842             processed.
843              
844             See L
845              
846             Tags: CORE, BASE, FILE
847              
848             =head3 srvdir
849              
850             my $value = srvdir();
851              
852             For example value can be set as: /srv
853              
854             /srv contains site-specific data which is served by this system.
855              
856             See L
857              
858             Tags: CORE, BASE, FILE
859              
860             =head3 sysconfdir
861              
862             my $value = sysconfdir();
863              
864             For example value can be set as: /etc
865              
866             The /etc hierarchy contains configuration files. A "configuration file" is a local file used to control the operation
867             of a program; it must be static and cannot be an executable binary.
868              
869             See L
870              
871             Tags: CORE, BASE, FILE
872              
873             =head3 syslogdir
874              
875             my $value = syslogdir();
876              
877             For example value can be set as: /var/log
878              
879             This directory contains miscellaneous log files. Most logs must be written to this directory or an appropriate
880             subdirectory.
881              
882             See L
883              
884             Tags: CORE, BASE, FILE
885              
886             =head3 tag
887              
888             $detagged = tag( $string );
889              
890             <, >, " and ' chars convert to <, >, " and ' strings.
891              
892             Tags: BASE, FORMAT
893              
894             =head3 tag_create
895              
896             $string = tag_create( $detagged );
897              
898             Reverse function L
899              
900             Tags: BASE, FORMAT
901              
902             =head3 to_base64
903              
904             $base64_text = to_base64( $utf8_text );
905              
906             Function to encode strings into the base64 encoding specified in
907             RFC 2045 - I
908             Mail Extensions)>. The base64 encoding is designed to represent
909             arbitrary sequences of octets in a form that need not be humanly
910             readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used,
911             enabling 6 bits to be represented per printable character.
912              
913             See also L
914              
915             Tags: BASE, FORMAT
916              
917             =head3 to_cp1251, to_windows1251
918              
919             $win1251_text = to_windows1251( $utf8_text )
920             $win1251_text = to_windows1251( $utf8, "Windows-1251" )
921              
922             Encodes a string from Perl's internal form into I (Windows-1251) and returns
923             a sequence of octets ($win1251_text). ENCODING can be either a canonical name or
924             an alias. For encoding names and aliases, see L.
925              
926             Tags: BASE, FORMAT
927              
928             =head3 to_utf8
929              
930             $utf8_text = to_utf8( $win1251_text )
931             $utf8_text = to_utf8( $win1251_text, "Windows-1251" )
932              
933             Decodes a sequence of octets ($win1251_text) assumed to be in I (Windows-1251) into Perl's
934             internal form and returns the resulting string. As in encode(),
935             ENCODING can be either a canonical name or an alias. For encoding names
936             and aliases, see L.
937              
938             Tags: BASE, FORMAT
939              
940             =head3 touch
941              
942             touch( "file" );
943              
944             Makes file exist, with current timestamp
945              
946             Tags: BASE, FILE, ATOM
947              
948             =head3 trim
949              
950             print '"'.trim( " string " ).'"'; # "string"
951              
952             Returns the string with all leading and trailing whitespace removed. Trim on undef returns undef.
953             Original this function see L
954              
955             Tags: BASE, FORMAT
956              
957             =head3 C
958              
959             print tz_diff( time );
960              
961             Returns TimeZone difference value
962              
963             print dtf("%w, %DD %MON %YYYY %hh:%mm:%ss ".tz_diff(time), time);
964              
965             Prints RFC-2822 format date
966              
967             Tags: BASE, DATE
968              
969             =head3 unescape
970              
971             $str = unescape(escape("10% is enough\n"));
972              
973             Returns a string with each %XX sequence replaced with the actual byte (octet).
974              
975             This does the same as:
976              
977             $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
978              
979             See also L
980              
981             Tags: BASE, FORMAT
982              
983             =head3 variant_stf
984              
985             $fixlenstr = variant_stf( "qwertyuiop", 3 ); # -> q.p
986             $fixlenstr = variant_stf( "qwertyuiop", 7 ); # -> qw...op
987              
988             Returns a line the fixed length from 3 to the n chars
989              
990             Tags: BASE, FORMAT
991              
992             =head3 visokos
993              
994             $lybool = visokos( 2012 );
995              
996             Returns a leap-year or not
997              
998             Tags: BASE, DATE
999              
1000             =head3 webdir
1001              
1002             my $value = webdir();
1003              
1004             For example value can be set as: /var/www
1005              
1006             Directory where distribution put static web files.
1007              
1008             See L
1009              
1010             Tags: CORE, BASE, FILE
1011              
1012             =head3 where
1013              
1014             my @ls = which( "ls" );
1015              
1016             Get all paths to specified command. Same as which() but will return all the matches.
1017              
1018             Based on L
1019              
1020             Tags: UTIL, EXT, ATOM
1021              
1022             =head3 which
1023              
1024             my $ls = which( "ls" );
1025              
1026             Get full path to specified command
1027              
1028             First argument is the name used in the shell to call the program, e.g., perl.
1029              
1030             If it finds an executable with the name you specified, which() will return
1031             the absolute path leading to this executable, e.g., /usr/bin/perl or C:\Perl\Bin\perl.exe.
1032              
1033             If it does not find the executable, it returns undef.
1034              
1035             Based on L
1036              
1037             Tags: UTIL, EXT, ATOM
1038              
1039             =head2 TAGS
1040              
1041             =over 8
1042              
1043             =item B<:ALL>
1044              
1045             Exports all functions
1046              
1047             =item B<:API>
1048              
1049             Exports functions:
1050              
1051             L,
1052             L,
1053             L,
1054             L,
1055             L
1056              
1057             =item B<:ATOM>
1058              
1059             Exports all function FILE and EXT
1060              
1061             =item B<:BASE>
1062              
1063             Exports all function API, FILE, FORMAT, DATE and:
1064              
1065             L,
1066             L,
1067             L
1068              
1069             =item B<:CORE>
1070              
1071             Exports functions:
1072              
1073             L,
1074             L,
1075             L,
1076             L,
1077             L,
1078             L,
1079             L,
1080             L,
1081             L,
1082             L,
1083             L,
1084             L,
1085             L,
1086             L
1087              
1088             =item B<:DATE>
1089              
1090             Exports functions:
1091              
1092             L,
1093             L,
1094             L,
1095             L,
1096             L,
1097             L,
1098             L,
1099             L,
1100             L,
1101             L,
1102             L,
1103             L,
1104             L,
1105             L,
1106             L,
1107             L,
1108             L
1109              
1110             =item B<:EXT>
1111              
1112             Exports functions:
1113              
1114             L,
1115             L,
1116             L,
1117             L,
1118             L,
1119             L,
1120             L,
1121             L,
1122             L
1123              
1124             =item B<:FILE>
1125              
1126             Exports all function CORE and:
1127              
1128             L,
1129             L,
1130             L,
1131             L,
1132             L,
1133             L,
1134             L,
1135             L,
1136             L,
1137             L,
1138             L,
1139             L,
1140             L,
1141             L,
1142             L,
1143             L,
1144             L
1145              
1146             =item B<:FORMAT>
1147              
1148             Exports functions:
1149              
1150             L,
1151             L,
1152             L,
1153             L,
1154             L,
1155             L,
1156             L,
1157             L,
1158             L,
1159             L,
1160             L,
1161             L,
1162             L,
1163             L,
1164             L,
1165             L,
1166             L,
1167             L,
1168             L,
1169             L,
1170             L,
1171              
1172             =item B<:UTIL>
1173              
1174             Exports all function EXT and:
1175              
1176             L,
1177             L,
1178             L,
1179             L,
1180             L
1181              
1182             =back
1183              
1184             =head1 HISTORY
1185              
1186             See C file
1187              
1188             =head1 DEPENDENCIES
1189              
1190             L, L, L, L, L, L,
1191             L, L, L, L, L,
1192             L, L
1193              
1194             =head1 TO DO
1195              
1196             See C file
1197              
1198             =head1 BUGS
1199              
1200             * none noted
1201              
1202             =head1 SEE ALSO
1203              
1204             L, L, L, L, L
1205              
1206             =head1 AUTHOR
1207              
1208             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
1209              
1210             =head1 COPYRIGHT
1211              
1212             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
1213              
1214             =head1 LICENSE
1215              
1216             This program is free software; you can redistribute it and/or
1217             modify it under the same terms as Perl itself.
1218              
1219             See C file and L
1220              
1221             =cut
1222              
1223             use constant {
1224 20 50       3215 DEBUG => 1, # 0 - off, 1 - on, 2 - all (+ http headers and other)
    50          
    50          
1225             WIN => $^O =~ /mswin/i ? 1 : 0,
1226             NULL => $^O =~ /mswin/i ? 'NUL' : '/dev/null',
1227             TONULL => $^O =~ /mswin/i ? '>NUL 2>&1' : '>/dev/null 2>&1',
1228             ERR2OUT => '2>&1',
1229             VOIDFILE => 'void.txt',
1230             DTF => {
1231             DOW => [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/],
1232             DOWS => [qw/Sun Mon Tue Wed Thu Fri Sat/],
1233             MOY => [qw/January February March April May June
1234             July August September October November December/],
1235             MOYS => [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/],
1236              
1237             },
1238 20     20   5965 };
  20         35  
1239              
1240 20     20   128 use vars qw/$VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS/;
  20         47  
  20         1466  
1241             $VERSION = '2.83';
1242              
1243 20     20   9982 use Encode;
  20         182314  
  20         1480  
1244 20     20   8931 use Time::Local;
  20         39886  
  20         1331  
1245 20         1819 use File::Spec::Functions qw/
1246             catdir catfile rootdir tmpdir updir curdir
1247             path splitpath splitdir abs2rel rel2abs
1248 20     20   8021 /;
  20         14358  
1249 20     20   8386 use MIME::Base64;
  20         11472  
  20         979  
1250 20     20   13703 use MIME::Lite;
  20         569564  
  20         705  
1251 20     20   11851 use Net::FTP;
  20         1807211  
  20         1396  
1252 20     20   231 use File::Path; # mkpath / rmtree
  20         44  
  20         1325  
1253 20     20   9741 use IPC::Open3;
  20         48747  
  20         1117  
1254 20     20   147 use Symbol;
  20         159  
  20         850  
1255 20     20   173 use Cwd;
  20         39  
  20         1021  
1256              
1257 20     20   125 use Carp qw/carp croak cluck confess/;
  20         39  
  20         1068  
1258             # carp -- as warn
1259             # croak -- as die
1260             # cluck -- as extended warn
1261             # confess -- as extended die
1262              
1263 20     20   113 use base qw /Exporter/;
  20         44  
  20         163671  
1264             my @est_api = qw(
1265             read_attributes
1266             syscfg getsyscfg isos isostype
1267             );
1268             my @est_core = qw(
1269             prefixdir localstatedir sysconfdir srvdir
1270             sharedir docdir localedir cachedir syslogdir spooldir rundir lockdir sharedstatedir webdir
1271             );
1272             my @est_util = qw(
1273             randomize randchars shuffle isTrueFlag isFalseFlag
1274             );
1275             my @est_encoding = qw(
1276             to_utf8 to_windows1251 to_cp1251 to_base64 from_utf8
1277             );
1278             my @est_format = qw(
1279             escape unescape slash tag tag_create cdata dformat fformat
1280             lf_normalize nl_normalize file_lf_normalize file_nl_normalize
1281             correct_number correct_dig
1282             variant_stf trim
1283             );
1284             my @est_datetime = qw(
1285             current_date current_date_time localtime2date localtime2date_time correct_date date2localtime
1286             datetime2localtime visokos date2dig dig2date date_time2dig dig2date_time basetime
1287             dtf datetimef datef tz_diff
1288             );
1289             my @est_file = qw(
1290             load_file save_file file_load file_save fsave fload bsave bload touch eqtime
1291             );
1292             my @est_dir = qw(
1293             ls scandirs scanfiles getlist getfilelist getdirlist
1294             preparedir
1295             );
1296             my @est_ext = qw(
1297             sendmail send_mail
1298             ftp ftptest ftpgetlist
1299             exe execute where which
1300             );
1301              
1302             @EXPORT = (); # Defaults none
1303              
1304             @EXPORT_OK = ( # All
1305             @est_api, @est_core, @est_encoding, @est_format, @est_datetime,
1306             @est_file, @est_dir, @est_ext, @est_util
1307             );
1308              
1309             %EXPORT_TAGS = (
1310             DEFAULT => [@EXPORT],
1311             ALL => [@EXPORT_OK],
1312             API => [
1313             @est_api
1314             ],
1315             CORE => [
1316             @est_core,
1317             ],
1318             FORMAT => [
1319             @est_encoding,
1320             @est_format,
1321             ],
1322             DATE => [
1323             @est_datetime,
1324             ],
1325             FILE => [
1326             @est_core,
1327             @est_file,
1328             @est_dir,
1329             ],
1330             EXT => [
1331             @est_ext,
1332             ],
1333             UTIL => [
1334             @est_ext,
1335             @est_util,
1336             ],
1337             ATOM => [
1338             @est_file, @est_dir,
1339             @est_ext,
1340             ],
1341             BASE => [
1342             @est_api,
1343             @est_core, @est_file, @est_dir,
1344             @est_encoding, @est_format,
1345             @est_datetime,
1346             @est_util,
1347             ],
1348             );
1349              
1350             # Backend class
1351             push @CTK::Util::ISA, qw/CTK::Util::SysConfig/;
1352              
1353             my $CRLF = _crlf();
1354              
1355             #
1356             # Format functions
1357             #
1358              
1359             sub to_utf8 { # Default: Windows-1251
1360 5     5 1 10 my $ss = shift;
1361 5   50     18 my $ch = shift || 'Windows-1251';
1362 5         8 my $ret = "";
1363 5         18 Encode::_utf8_on($ret);
1364 5 50       12 return $ret unless defined($ss);
1365 5         13 return Encode::decode($ch,$ss)
1366             }
1367             sub from_utf8 { # Default: Windows-1251
1368 0     0 1 0 my $ss = shift;
1369 0   0     0 my $ch = shift || 'Windows-1251';
1370 0         0 my $ret = "";
1371 0         0 Encode::_utf8_off($ret);
1372 0 0       0 return $ret unless defined($ss);
1373 0         0 return Encode::encode($ch,$ss)
1374             }
1375             sub to_windows1251 {
1376 0     0 1 0 return from_utf8(shift, 'Windows-1251');
1377             }
1378 0     0 1 0 sub to_cp1251 { goto &to_windows1251 };
1379             sub to_base64 {
1380             # Converts UTF-8 string to base64 (RFC 2047)
1381 3     3 1 991 my $ss = shift; # Сообщение
1382 3 100       10 return '=?UTF-8?B??=' unless defined($ss);
1383 2         33 return sprintf('=?UTF-8?B?%s?=', MIME::Base64::encode(Encode::encode('UTF-8', $ss), ''));
1384             }
1385             sub slash {
1386             # \ -> \\
1387             # ' -> \'
1388 3     3 1 562 my $data_staring = shift;
1389 3 100       12 return '' unless defined($data_staring);
1390 2         4 $data_staring =~ s/\\/\\\\/g;
1391 2         5 $data_staring =~ s/'/\\'/g;
1392 2         6 return $data_staring;
1393             }
1394             sub tag {
1395             # <, >, " and ' chars convert to <, >, " and ' strings
1396 3     3 1 6 my $data_staring = shift;
1397 3 100       9 return '' unless defined($data_staring);
1398 2         6 $data_staring =~ s/
1399 2         4 $data_staring =~ s/>/>/g;
1400 2         3 $data_staring =~ s/\"/"/g;
1401 2         3 $data_staring =~ s/\'/'/g;
1402 2         6 return $data_staring;
1403             }
1404             sub tag_create {
1405             # < -> < and etc. See tag
1406 0     0 1 0 my $data_staring = shift;
1407 0 0       0 return '' unless defined($data_staring);
1408 0         0 $data_staring =~ s/\'\;/\'/g;
1409 0         0 $data_staring =~ s/\<\;/\
1410 0         0 $data_staring =~ s/\>\;/\>/g;
1411 0         0 $data_staring =~ s/\"\;/\"/g;
1412 0         0 return $data_staring;
1413             }
1414             sub cdata {
1415 2     2 1 4 my $s = shift;
1416 2         6 my $ss = to_utf8('
1417 2         9174 my $sf = to_utf8(']]>');
1418 2 100       97 if (defined $s) {
1419 1         9 return $ss.$s.$sf;
1420             }
1421 1         3 return to_utf8('');
1422             }
1423             sub escape { # Percent-encoding, also known as URL encoding
1424 0     0 1 0 my $toencode = shift;
1425 0 0       0 return '' unless defined($toencode);
1426 0         0 $toencode =~ s/([^a-zA-Z0-9_.~-])/uc(sprintf("%%%02x",ord($1)))/eg;
  0         0  
1427 0         0 return $toencode;
1428             }
1429             sub unescape { # Percent-decoding, also known as URL decoding
1430 0     0 1 0 my $todecode = shift;
1431 0 0       0 return '' unless defined($todecode);
1432 0         0 $todecode =~ tr/+/ /; # pluses become spaces
1433 0         0 $todecode =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  0         0  
1434 0         0 return $todecode;
1435             }
1436             sub lf_normalize {
1437             # line feed normalize in string
1438 0   0 0 1 0 my $s = shift // return '';
1439 0         0 $s =~ s/(\x0D*\x0A)|(\x0D)/_proxy_crlf($CRLF)/ges;
  0         0  
1440 0         0 return $s;
1441             }
1442 0     0 1 0 sub nl_normalize { goto &lf_normalize }
1443             sub file_lf_normalize {
1444             # line feed normalize in file. Original: dos2unix
1445 0   0 0 1 0 my $f = shift // return 0;
1446 0 0       0 return 0 unless -e $f;
1447 0 0       0 return 0 if -d $f;
1448 0 0       0 return 0 unless -w $f;
1449 0 0       0 return 0 unless -r $f;
1450 0 0       0 return 0 if -B $f;
1451              
1452 0         0 local $\;
1453              
1454 0         0 my $temp = sprintf('%s.%d.tmp',$f,$$);
1455 0 0       0 open ORIG, $f or do { carp "Can't open $f: $!"; return 0 };
  0         0  
  0         0  
1456 0 0       0 open TEMP, ">$temp" or do { carp "Can't create $temp: $!"; return 0 };
  0         0  
  0         0  
1457 0         0 binmode(TEMP);
1458 0         0 while (my $line = ) {
1459 0         0 print TEMP lf_normalize($line);
1460             }
1461 0         0 close ORIG;
1462 0         0 close TEMP;
1463 0         0 rename $temp, $f;
1464 0         0 return 1;
1465             }
1466 0     0 1 0 sub file_nl_normalize { goto &file_lf_normalize }
1467             sub dformat {
1468 0   0 0 1 0 my $fmt = shift // '';
1469 0   0     0 my $fd = shift || {};
1470 0 0       0 $fmt =~ s/\[([a-z0-9_\-.]+?)\]/(defined($fd->{uc($1)}) ? $fd->{uc($1)} : "[$1]")/ieg;
  0         0  
1471 0         0 return $fmt;
1472             }
1473             sub fformat {
1474             # [FILENAME] -- Filename only
1475             # [NAME] -- =FILENAME
1476             # [FILEEXT] -- File extension only
1477             # [EXT] -- =FILEEXT
1478             # [FILE] -- Filename and extension
1479 0   0 0 1 0 my $fmt = shift // ''; # [FILENAME]-blah-blah-blah.[FILEEXT]
1480 0   0     0 my $fin = shift // ''; # void.txt
1481 0 0       0 my ($fn,$fe) = ($fin =~ /^(.+)\.([0-9a-zA-Z]+)$/) ? ($1,$2) : ($fin,'');
1482 0         0 $fmt =~ s/\[FILENAME\]/$fn/ig;
1483 0         0 $fmt =~ s/\[NAME\]/$fn/ig;
1484 0         0 $fmt =~ s/\[FILEEXT\]/$fe/ig;
1485 0         0 $fmt =~ s/\[EXT\]/$fe/ig;
1486 0         0 $fmt =~ s/\[FILE\]/$fin/ig;
1487 0         0 return $fmt; # void-blah-blah-blah.txt
1488             }
1489             sub correct_number {
1490 0   0 0 1 0 my $var = shift || 0;
1491 0   0     0 my $sep = shift || "`";
1492 0         0 1 while $var=~s/(\d)(\d\d\d)(?!\d)/$1$sep$2/;
1493 0         0 return $var;
1494             }
1495             sub correct_dig {
1496 0   0 0 1 0 my $dig = shift || 0;
1497 0 0       0 if ($dig =~ /^\s*(\d+)\s*$/) {
1498 0         0 return $1;
1499             }
1500 0         0 return 0;
1501             }
1502             sub trim {
1503 0     0 1 0 my $val = shift;
1504 0 0       0 return unless defined $val;
1505 0         0 $val =~ s|^\s+||s; # trim left
1506 0         0 $val =~ s|\s+$||s; # trim right
1507 0         0 return $val;
1508             }
1509              
1510             #
1511             # Date and time
1512             #
1513              
1514             sub localtime2date {
1515             # localtime2date ( time() ) # => 02.12.2010
1516 0   0 0 1 0 my $dandt = shift || time();
1517 0         0 my @dt = localtime($dandt);
1518 0         0 return sprintf (
1519             "%02d.%02d.%04d",
1520             $dt[3], # Day
1521             $dt[4]+1, # Month
1522             $dt[5]+1900 # Year
1523             );
1524             }
1525             sub localtime2date_time {
1526 0   0 0 1 0 my $dandt = shift || time();
1527 0         0 my @dt = localtime($dandt);
1528 0         0 return sprintf (
1529             "%02d.%02d.%04d %02d:%02d:%02d",
1530             $dt[3], # Day
1531             $dt[4]+1, # Month
1532             $dt[5]+1900, # Year
1533             $dt[2], # Hour
1534             $dt[1], # Min
1535             $dt[0] # Sec
1536             );
1537             }
1538 0     0 1 0 sub current_date { localtime2date() }
1539 0     0 1 0 sub current_date_time { localtime2date_time() }
1540             sub correct_date {
1541 0     0 1 0 my $date = shift;
1542 0 0       0 if ($date =~/^\s*(\d{1,2})\D+(\d{1,2})\D+(\d{4})\s*$/) {
1543 0 0       0 my $dd = (($1<10)?('0'.($1/1)):$1);
1544 0 0       0 my $mm = (($2<10)?('0'.($2/1)):$2);
1545 0         0 my $yyyy=$3;
1546 0 0 0     0 if (($dd > 31) or ($dd <= 0)) {return ''};
  0         0  
1547 0 0 0     0 if (($mm > 12) or ($mm <= 0)) {return ''};
  0         0  
1548 0         0 my @aday = (31,28+visokos($yyyy),31,30,31,30,31,31,30,31,30,31);
1549 0 0       0 if ($dd > $aday[$mm-1]) {return ''}
  0         0  
1550 0         0 return "$dd.$mm.$yyyy";
1551             } else {
1552 0         0 return '';
1553             }
1554             }
1555             sub date2localtime {
1556 0   0 0 1 0 my $dtin= shift || return 0;
1557 0 0       0 if ($dtin=~/^\s*(\d{1,2})\.+(\d{1,2})\.+(\d{4}).*$/) {
1558 0         0 return timelocal(0,0,0,$1,$2-1,$3-1900);
1559             }
1560 0         0 return 0
1561             }
1562             sub datetime2localtime {
1563 0   0 0 1 0 my $dtin= shift || return 0;
1564 0 0       0 if ($dtin=~/^\s*(\d{1,2})\.+(\d{1,2})\.+(\d{4})\s+(\d{1,2})\:(\d{1,2})\:(\d{1,2}).*$/) {
1565 0 0 0     0 return timelocal(
    0 0        
      0        
      0        
1566             $6 || 0,
1567             $5 || 0,
1568             $4 || 0,
1569             $1 || 1,
1570             $2 ? $2-1 : 0,
1571             $3 ? $3-1900 : 0,
1572             );
1573             }
1574 0         0 return 0
1575             }
1576             sub visokos {
1577 0   0 0 1 0 my $arg = shift || 1;
1578 0 0 0     0 if ((($arg % 4) == 0 ) and not ( (($arg % 100) == 0) and (($arg % 400) != 0) )) {
      0        
1579 0         0 return 1;
1580             } else {
1581 0         0 return 0;
1582             }
1583             }
1584             sub date2dig {
1585             # date2dig( $date ) # 02.12.2010 => 20101202
1586 0   0 0 1 0 my $val = shift || &localtime2date();
1587 0         0 my $stat=$val=~s/^\s*(\d{1,2})\.+(\d{1,2})\.+(\d{4}).*$/$3$2$1/;
1588 0 0       0 $val = '' unless $stat;
1589 0         0 return $val;
1590             }
1591             sub dig2date {
1592 0   0 0 1 0 my $val = shift || date2dig();
1593 0         0 my $stat=$val=~s/^\s*(\d{4})(\d{2})(\d{2}).*$/$3.$2.$1/;
1594 0 0       0 $val = '' unless $stat;
1595 0         0 return $val;
1596             }
1597             sub date_time2dig {
1598 0   0 0 1 0 my $val = shift || current_date_time();
1599 0         0 my $stat=$val=~s/^\s*(\d{2})\.+(\d{2})\.+(\d{4})\D+(\d{2}):(\d{2}):(\d{2}).*$/$3$2$1$4$5$6/;
1600 0 0       0 $val = '' unless $stat;
1601 0         0 return $val;
1602             }
1603             sub dig2date_time {
1604 0   0 0 1 0 my $val = shift || date_time2dig();
1605 0         0 my $stat=$val=~s/^\s*(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2}).*$/$3.$2.$1 $4:$5:$6/;
1606 0 0       0 $val = '' unless $stat;
1607 0         0 return $val;
1608             }
1609             sub basetime {
1610 0     0 1 0 return time() - $^T
1611             }
1612             sub dtf {
1613 0   0 0 1 0 my $f = shift || '';
1614 0   0     0 my $t = shift || time();
1615 0   0     0 my $g = shift || 0; # GMT time switch
1616 0 0 0     0 my $z = ($g && $g =~ /^[\-+]?[1-9]$/) ? 'GMT' : ($g || '');
      0        
1617              
1618 0         0 my (@dt,%dth, %dth2);
1619 0 0 0     0 @dt = ($g && $z =~ /GMT|UTC/) ? gmtime($t) : localtime($t);
1620 0   0     0 $dth{'%s'} = $dt[0] || 0;
1621 0         0 $dth{'%ss'} = sprintf('%02d',$dth{'%s'});
1622 0         0 $dth{'%_s'} = sprintf('%2d',$dth{'%s'});
1623 0   0     0 $dth{'%m'} = $dt[1] || 0;
1624 0         0 $dth{'%mm'} = sprintf('%02d',$dth{'%m'});
1625 0         0 $dth{'%_m'} = sprintf('%2d',$dth{'%m'});
1626 0   0     0 $dth{'%h'} = $dt[2] || 0;
1627 0         0 $dth{'%hh'} = sprintf('%02d',$dth{'%h'});
1628 0         0 $dth{'%_h'} = sprintf('%2d',$dth{'%h'});
1629 0   0     0 $dth{'%D'} = $dt[3] || 0;
1630 0         0 $dth{'%DD'} = sprintf('%02d',$dth{'%D'});
1631 0         0 $dth{'%_D'} = sprintf('%2d',$dth{'%D'});
1632 0   0     0 $dth{'%M'} = $dt[4] || 0; $dth{'%M'}++;
  0         0  
1633 0         0 $dth{'%MM'} = sprintf('%02d',$dth{'%M'});
1634 0         0 $dth{'%_M'} = sprintf('%2d',$dth{'%M'});
1635 0   0     0 $dth{'%Y'} = $dt[5] || 0; $dth{'%Y'}+=1900;
  0         0  
1636 0         0 $dth{'%YY'} = sprintf('%02d',$dth{'%Y'}%100);
1637 0         0 $dth{'%YYY'} = sprintf('%03d',$dth{'%Y'}%1000);
1638 0         0 $dth{'%YYYY'} = sprintf('%04d',$dth{'%Y'});
1639 0         0 $dth{'%_Y'} = sprintf('%2d',$dth{'%Y'}%100);
1640 0         0 $dth{'%_YY'} = sprintf('%3d',$dth{'%Y'}%1000);
1641 0   0     0 $dth{'%w'} = DTF->{DOWS}->[$dt[6] || 0];
1642 0   0     0 $dth{'%W'} = DTF->{DOW}->[$dt[6] || 0];
1643 0   0     0 $dth{'%MON'} = DTF->{MOYS}->[$dt[4] || 0];
1644 0   0     0 $dth{'%mon'} = DTF->{MOYS}->[$dt[4] || 0];
1645 0   0     0 $dth{'%MONTH'} = DTF->{MOY}->[$dt[4] || 0];
1646 0   0     0 $dth{'%month'} = DTF->{MOY}->[$dt[4] || 0];
1647              
1648             # Second block
1649 0 0       0 $dth2{'%G'} = 'GMT' if $g;
1650 0 0       0 $dth2{'%U'} = 'UTC' if $g;
1651 0         0 $dth2{'%Z'} = $z;
1652 0         0 $dth2{'%%'} = '%';
1653              
1654 0         0 $f =~ s/$_/$dth{$_}/sge for sort { length($b) <=> length($a) } keys %dth;
  0         0  
  0         0  
1655 0         0 $f =~ s/$_/$dth2{$_}/sge for qw/%G %U %Z %%/;
  0         0  
1656              
1657 0         0 return $f
1658             }
1659 0     0 1 0 sub datef { goto &dtf }
1660 0     0 1 0 sub datetimef { goto &dtf }
1661             sub tz_diff {
1662 0   0 0 1 0 my $tm = shift || time;
1663 0         0 my $diff = Time::Local::timegm(localtime($tm)) - Time::Local::timegm(gmtime($tm));
1664 0 0       0 my $direc = $diff < 0 ? '-' : '+';
1665 0         0 $diff = abs($diff);
1666 0         0 my $tz_hr = int( $diff / 3600 );
1667 0         0 my $tz_mi = int( $diff / 60 - $tz_hr * 60 );
1668 0         0 return sprintf("%s%02d%02d", $direc, $tz_hr, $tz_mi);
1669             }
1670              
1671             sub variant_stf {
1672 0   0 0 1 0 my $S = shift // '';
1673 0   0     0 my $length_s = shift || 0;
1674 0         0 my $countpoints;
1675              
1676 0 0       0 $length_s = 3 if $length_s < 3;
1677 0 0       0 if ($length_s < 6) {
1678 0         0 $countpoints = $length_s - 2;
1679             }
1680             else {
1681 0         0 $countpoints = 3;
1682             }
1683              
1684 0         0 my $reallenght = $length_s - $countpoints;
1685              
1686 0         0 my ($Snew,$fix,$new_start,$dot,$new_midle,$new_end);
1687 0 0       0 if (length($S) <= $length_s) {
1688 0         0 $Snew = $S;
1689             } else {
1690 0         0 $fix= sprintf "%d",($reallenght / 2);
1691 0         0 $new_start = substr($S, 0, ($reallenght - $fix));
1692 0         0 $dot='.';
1693 0         0 $new_midle = $dot x $countpoints;
1694 0         0 $new_end = substr($S,(length($S)-$fix),$fix);
1695 0         0 $new_start=~s/\s+$//;
1696 0         0 $new_end=~s/^\s+//;
1697 0         0 $Snew = $new_start.$new_midle.$new_end;
1698             }
1699 0         0 return $Snew;
1700             }
1701             sub randomize {
1702 0   0 0 1 0 my $digs = shift || return 0;
1703 0         0 my $rstat;
1704 0         0 for (my $i=0; $i<$digs; $i++) {
1705 0         0 $rstat.=int(rand(10));
1706             }
1707 0         0 $rstat = substr($rstat,0,abs($digs));
1708 0         0 return "$rstat"
1709             }
1710             sub randchars {
1711 5   50 5 1 114 my $l = shift || return '';
1712 5 50       22 return '' unless $l =~/^\d+$/;
1713 5         7 my $arr = shift;
1714              
1715 5         7 my $result = '';
1716 5 50 33     52 my @chars = ($arr && ref($arr) eq 'ARRAY') ? (@$arr) : (0..9,'a'..'z','A'..'Z');
1717 5         129 $result .= $chars[(int(rand($#chars+1)))] for (1..$l);
1718              
1719 5         24 return $result;
1720             }
1721             sub shuffle {
1722             # See List::Util::PP
1723 0 0   0 1 0 return unless @_;
1724 0         0 my @a=\(@_);
1725 0         0 my $n;
1726 0         0 my $i=@_;
1727             map {
1728 0         0 $n = rand($i--);
  0         0  
1729 0         0 (${$a[$n]}, $a[$n] = $a[$i])[0];
  0         0  
1730             } @_;
1731             }
1732             sub isTrueFlag {
1733 23   100 23 1 90 my $flag = shift || return 0;
1734 3 50       23 return $flag =~ /^(on|y|true|enable|1)/i ? 1 : 0;
1735             }
1736             sub isFalseFlag {
1737 4   100 4 1 91 my $flag = shift || return 1;
1738 3 100       24 return $flag =~ /^(off|n|false|disable|0)/i ? 1 : 0;
1739             }
1740              
1741              
1742             #
1743             # Files (text mode)
1744             #
1745             sub load_file { # Text mode
1746 6   50 6 1 58 my $filename = shift // return '';
1747 6 50       19 return '' unless length($filename);
1748 6         11 my $text ='';
1749 6         20 local *FILE;
1750 6 50       63 if(-e $filename){
1751 6         232 my $ostat = open(FILE,"<",$filename);
1752 6 50       21 if ($ostat) {
1753 6 50       251 read(FILE, $text, -s $filename) unless -z $filename;
1754 6         89 close FILE;
1755             } else {
1756 0         0 carp("fload: Can't open file to load \"$filename\": $!");
1757             }
1758             }
1759 6         48 return $text;
1760             }
1761             sub save_file { # Text mode
1762 6   50 6 1 20 my $filename = shift // return 0;
1763 6   50     26 my $text = shift // '';
1764 6 50       15 return 0 unless length($filename);
1765 6         31 local *FILE;
1766 6         700 my $ostat = open(FILE,">",$filename);
1767 6 50       34 if ($ostat) {
1768 6 50       78 flock (FILE, 2) or carp("fsave: Can't lock file \"$filename\": $!");
1769 6         116 print FILE $text;
1770 6         247 close FILE;
1771             } else {
1772 0         0 carp("fsave: Can't open file to write \"$filename\": $!");
1773 0         0 return 0;
1774             }
1775 6         54 return 1;
1776             }
1777 6     6 1 40 sub fload { goto &load_file }
1778 6     6 1 50 sub fsave { goto &save_file }
1779              
1780             #
1781             # Files (bin mode)
1782             #
1783             sub file_load {
1784 0   0 0 1 0 my $fn = shift // return '';
1785 0         0 my $onutf8 = shift;
1786 0         0 my $IN;
1787 0 0       0 return '' unless length($fn);
1788              
1789 0 0       0 if (ref $fn eq 'GLOB') {
1790 0         0 $IN = $fn;
1791             } else {
1792 0         0 my $ostat = open $IN, '<', $fn;
1793 0 0       0 unless ($ostat) {
1794 0         0 carp("bload: Can't open file to load \"$fn\": $!");
1795 0         0 return '';
1796             }
1797             }
1798 0 0       0 binmode $IN, ':raw:utf8' if $onutf8;
1799 0 0       0 binmode $IN unless $onutf8;
1800 0         0 return scalar(do { local $/; <$IN> });
  0         0  
  0         0  
1801             }
1802             sub file_save {
1803 0   0 0 1 0 my $fn = shift // return 0;
1804 0   0     0 my $content = shift // '';
1805 0         0 my $onutf8 = shift;
1806 0 0       0 return 0 unless length($fn);
1807 0         0 my $OUT;
1808 0         0 my $flc = 0;
1809 0 0       0 if (ref $fn eq 'GLOB') {
1810 0         0 $OUT = $fn;
1811             } else {
1812 0 0       0 open($OUT, '>', $fn) or do {
1813 0         0 carp("bsave: Can't open file to write \"$fn\": $!");
1814 0         0 return 0;
1815             };
1816 0 0       0 flock($OUT, 2) or carp("bsave: Can't lock file \"$fn\": $!");
1817 0         0 $flc = 1;
1818             }
1819 0 0       0 if ($onutf8) {
1820 0         0 binmode($OUT, ':raw:utf8');
1821             } else {
1822 0         0 binmode($OUT);
1823             }
1824 0         0 print $OUT $content;
1825 0 0       0 close $OUT if $flc;
1826 0         0 return 1;
1827             }
1828 0     0 1 0 sub bload { goto &file_load } # двоичное чтение
1829 0     0 1 0 sub bsave { goto &file_save } # двоичная запись
1830              
1831             #
1832             # Files utilities
1833             #
1834             sub touch {
1835             # See ExtUtils::Command)
1836 0   0 0 1 0 my $fn = shift // '';
1837 0 0       0 return 0 unless length($fn);
1838 0         0 my $t = time;
1839 0         0 my $OUT;
1840 0         0 my $ostat = open $OUT, '>>', $fn;
1841 0 0       0 unless ($ostat) {
1842 0         0 carp("touch: Can't open file to write \"$fn\": $!");
1843 0         0 return 0;
1844             }
1845 0 0       0 close $OUT if $ostat;
1846 0         0 utime($t,$t,$fn);
1847 0         0 return 1;
1848             }
1849             sub eqtime {
1850             # Делаем файл такой же датой создания и модификации
1851 0   0 0 1 0 my $src = shift // '';
1852 0   0     0 my $dst = shift // '';
1853 0 0       0 return 0 unless length($src);
1854 0 0       0 return 0 unless length($dst);
1855 0 0 0     0 unless ($src && -e $src) {
1856 0         0 carp("eqtime: Can't open file to read \"$src\": $!");
1857 0         0 return 0;
1858             }
1859 0 0       0 unless (utime((stat($src))[8,9],$dst)) {
1860 0         0 carp("eqtime: Can't change access and modification times on file \"$dst\": $!");
1861 0         0 return 0;
1862             }
1863 0         0 return 1;
1864             }
1865             sub preparedir {
1866 0   0 0 1 0 my $din = shift // return 0;
1867 0         0 my $chmod = shift; # 0777
1868              
1869 0         0 my @dirs;
1870 0 0       0 if (ref($din) eq 'HASH') {
    0          
1871 0 0 0     0 foreach my $k (values %$din) { push @dirs, $k if length($k // '') };
  0         0  
1872             } elsif (ref($din) eq 'ARRAY') {
1873 0 0       0 @dirs = grep { defined($_) && length($_) } @$din;
  0         0  
1874 0 0       0 } else { push @dirs, $din if length($din) }
1875 0         0 my $stat = 1;
1876 0         0 foreach my $dir (@dirs) {
1877 0 0       0 mkpath( $dir, {verbose => 0} ) unless -e $dir; # mkdir $dir unless -e $dir;
1878 0 0 0     0 chmod($chmod, $dir) if defined($chmod) && -e $dir;
1879 0 0 0     0 unless (-d $dir or -l $dir) {
1880 0         0 $stat = 0;
1881 0         0 carp("preparedir: Directory don't prepare \"$dir\"");
1882             }
1883             }
1884 0         0 return $stat;
1885             }
1886             sub scandirs {
1887 0   0 0 1 0 my $dir = shift // cwd() // curdir() // '.';
      0        
      0        
1888 0   0     0 my $mask = shift // '';
1889              
1890 0         0 my @dirs;
1891              
1892 0 0       0 @dirs = grep {!(/^\.+$/) && -d catdir($dir,$_)} ls($dir, $mask);
  0         0  
1893 0         0 @dirs = sort {$a cmp $b} @dirs;
  0         0  
1894              
1895 0         0 return map {[catdir($dir,$_), $_]} @dirs;
  0         0  
1896             }
1897             sub scanfiles {
1898 0   0 0 1 0 my $dir = shift // cwd() // curdir() // '.';
      0        
      0        
1899 0   0     0 my $mask = shift // '';
1900              
1901 0         0 my @files;
1902 0         0 @files = grep { -f catfile($dir,$_)} ls($dir, $mask);
  0         0  
1903 0         0 @files = sort {$a cmp $b} @files;
  0         0  
1904              
1905 0         0 return map {[catfile($dir,$_), $_]} @files;
  0         0  
1906             }
1907             sub ls {
1908 0   0 0 1 0 my $dir = shift // curdir() // '.';
      0        
1909 0   0     0 my $mask = shift // '';
1910              
1911 0         0 my @fds;
1912              
1913 0         0 my $dh = gensym();
1914 0 0       0 unless (opendir($dh,$dir)) {
1915 0         0 carp("ls: Can't open directory \"$dir\": $!");
1916 0         0 return @fds;
1917             }
1918              
1919 0         0 @fds = readdir($dh);
1920 0         0 closedir($dh);
1921 0 0 0     0 if ($mask && ref($mask) eq 'Regexp') {
1922 0         0 return grep {$_ =~ $mask} @fds;
  0         0  
1923             } else {
1924 0 0       0 return grep {/$mask/} @fds if length($mask);
  0         0  
1925             }
1926 0         0 return @fds;
1927             }
1928             sub getfilelist {
1929 0     0 1 0 return [map {$_->[1]} scanfiles(@_)];
  0         0  
1930             }
1931 0     0 1 0 sub getlist { goto &getfilelist }
1932             sub getdirlist {
1933 0     0 1 0 return [map {$_->[1]} scandirs(@_)];
  0         0  
1934             }
1935              
1936             #
1937             # Extended
1938             #
1939              
1940             sub send_mail { # MIME::Lite interface only
1941 0     0 1 0 my @args = @_;
1942 0 0       0 my ($to, $cc, $from, $subject, $message, $type,
1943             $sendmail, $charset, $smtp, $smtpuser, $smtppass, $att, $smtpargs) =
1944             read_attributes([
1945             ['TO','ADDRESS'],
1946             ['COPY','CC'],
1947             ['FROM'],
1948             ['SUBJECT','SUBJ','SBJ'],
1949             ['MESSAGE','CONTENT','TEXT'],
1950             ['TYPE','CONTENT-TYPE','CONTENT_TYPE'],
1951             ['PROGRAM','SENDMAIL',],
1952             ['CHARSET','CHARACTER_SET'],
1953             ['SMTP','MAILSERVER','SERVER','HOST'],
1954             ['SMTPLOGIN','AUTHLOGIN','LOGIN','SMTPUSER','AUTHUSER','USER'],
1955             ['SMTPPASSWORD','AUTHPASSWORD','PASSWORD','SMTPPASS','AUTHPASS','PASS'],
1956             ['ATTACH','ATTACHE','ATT'],
1957             ['SMTPARGS','ARGS','ARGUMENTS'],
1958             ],@args) if defined $args[0];
1959              
1960 0   0     0 $to //= '';
1961 0   0     0 $cc //= '';
1962 0   0     0 $from //= '';
1963 0   0     0 $subject //= '';
1964 0   0     0 $message //= '';
1965 0   0     0 $type //= "text/plain";
1966 0   0     0 $sendmail //= '';
1967 0   0     0 $charset //= "utf-8";
1968 0   0     0 $smtp //= '';
1969 0   0     0 $smtpuser //= '';
1970 0   0     0 $smtppass //= '';
1971              
1972 0 0       0 if ($charset !~ /utf\-?8/i) {
1973 0         0 $subject = to_utf8($subject, $charset);
1974 0         0 $message = to_utf8($message, $charset);
1975             }
1976              
1977             # Object
1978 0 0       0 my $msg = MIME::Lite->new(
1979             From => $from,
1980             To => $to,
1981             $cc ? (Cc => $cc) : (),
1982             Subject => $subject, # to_base64($subject),
1983             Type => $type,
1984             Encoding => 'base64',
1985             Data => Encode::encode('UTF-8', $message)
1986             );
1987 0         0 $msg->attr('content-type.charset' => 'UTF-8');
1988 0         0 $msg->attr('Content-Transfer-Encoding' => 'base64');
1989              
1990             # Attaches
1991 0 0       0 if ($att) {
1992 0 0       0 if (ref($att) =~ /HASH/i) {
    0          
1993 0         0 $msg->attach(%$att);
1994             } elsif (ref($att) =~ /ARRAY/i) {
1995 0         0 foreach (@$att) {
1996 0 0       0 if (ref($_) =~ /HASH/i) {
1997 0         0 $msg->attach(%$_);
1998             } else {
1999 0         0 carp("Can't attach scalar data. Please use hash structure");
2000             }
2001             }
2002             } else {
2003 0         0 carp("Can't attach scalar data. Please use hash structure or array of hashes");
2004             }
2005             }
2006              
2007             # Sending
2008 0         0 my $sendstat;
2009 0 0 0     0 my %tmp = ($smtpargs && ref($smtpargs) eq 'HASH') ? %$smtpargs : ();
2010 0 0 0     0 if ($smtp) { # If SMTP
    0          
2011 0 0 0     0 $tmp{AuthUser} //= $smtpuser if length($smtpuser);
2012 0 0 0     0 $tmp{AuthPass} //= $smtppass if length($smtppass);
2013 0         0 eval { $sendstat = $msg->send('smtp', $smtp, %tmp); };
  0         0  
2014 0 0       0 carp(sprintf("sendmail (smtp://%s): %s", $smtp, $@)) if $@;
2015             } elsif ($sendmail && -e $sendmail) { # Try sendmail program
2016 0         0 eval { $sendstat = $msg->send('sendmail', $sendmail); };
  0         0  
2017 0 0       0 carp(sprintf("sendmail (%s): %s", $sendmail, $@)) if $@;
2018             } else { # Try without args
2019 0         0 eval { $sendstat = $msg->send(); };
  0         0  
2020 0 0       0 carp(sprintf("sendmail (default): %s", $@)) if $@;
2021             }
2022 0 0       0 return $sendstat ? 1 : 0;
2023             }
2024 0     0 1 0 sub sendmail { goto &send_mail }
2025             sub ftp {
2026             #my %ftpct = (
2027             # ftphost => '192.168.1.1',
2028             # ftpuser => 'login',
2029             # ftppassword => 'password',
2030             # ftpdir => '~/',
2031             # voidfile => './void.txt',
2032             # #ftpattr => {},
2033             #);
2034             #my $rfiles = CTK::ftp(\%ftpct, 'ls');
2035             #my @remotefiles = $rfiles ? grep {!(/^\./)} @$rfiles : ();
2036             #ftp(\%ftpct, 'put', catfile($dirin,$file), $file);
2037              
2038 0   0 0 1 0 my $ftpconnect = shift || {};
2039 0   0     0 my $cmd = shift || '';
2040 0   0     0 my $lfile = shift || '';
2041 0   0     0 my $rfile = shift || '';
2042              
2043 0 0 0     0 unless ($ftpconnect && (ref($ftpconnect) eq 'HASH') && $ftpconnect->{ftphost}) {
      0        
2044 0         0 carp("Connect's data missing");
2045 0         0 return undef;
2046             }
2047              
2048 0 0       0 my $ftphost = $ftpconnect ? $ftpconnect->{ftphost} : '';
2049 0 0       0 my $ftpuser = $ftpconnect ? $ftpconnect->{ftpuser} : '';
2050 0 0       0 my $ftppassword = $ftpconnect ? $ftpconnect->{ftppassword} : '';
2051 0 0       0 my $ftpdir = $ftpconnect ? $ftpconnect->{ftpdir} : '';
2052 0 0 0     0 my $attr = $ftpconnect && $ftpconnect->{ftpattr} ? $ftpconnect->{ftpattr} : {};
2053 0         0 $attr->{Debug} = (DEBUG && DEBUG == 2) ? 1 : 0;
2054              
2055             my $ftp = Net::FTP->new($ftphost, %$attr)
2056 0 0       0 or do { carp("FTP: Can't connect to remote FTP server $ftphost: $@"); return undef};
  0         0  
  0         0  
2057             $ftp->login($ftpuser, $ftppassword)
2058 0 0       0 or do {carp("FTP: Can't login to remote FTP server: ", $ftp->message); return undef};
  0         0  
  0         0  
2059 0 0 0     0 if ($ftpdir && !$ftp->cwd($ftpdir)) {
2060 0         0 carp("FTP: Can't change FTP working directory \"$ftpdir\": ", $ftp->message);
2061 0         0 return undef;
2062             }
2063              
2064 0         0 my @out;
2065 0 0       0 if ( $cmd eq "connect" ){
    0          
    0          
    0          
    0          
    0          
2066 0         0 return $ftp; # Returns handler
2067             } elsif ( $cmd eq "ls" ){
2068 0 0       0 (my @out = $ftp->ls(WIN ? "" : "-1a" ))
2069             or carp( "FTP: Can't get directory listing (\"$ftpdir\") from remote FTP server $ftphost: ", $ftp->message );
2070 0         0 $ftp->quit;
2071 0         0 return [@out];
2072             } elsif (!$lfile) {
2073 0         0 carp("FTP: No filename given as parameter to FTP command $cmd");
2074             } elsif ($cmd eq "delete") {
2075 0 0       0 $ftp->delete($lfile)
2076             or carp( "FTP: Can't delete file \"$lfile\" on remote FTP server $ftphost: ", $ftp->message );
2077             } elsif ($cmd eq "get") {
2078 0         0 $ftp->binary;
2079 0 0       0 $ftp->get($rfile,$lfile)
2080             or carp("FTP: Can't get file \"$lfile\" from remote FTP server $ftphost: ", $ftp->message);
2081             } elsif ($cmd eq "put") {
2082 0         0 $ftp->binary;
2083 0 0       0 $ftp->put($lfile,$rfile)
2084             or carp("FTP: Can't put file \"$lfile\" on remote FTP server $ftphost: ", $ftp->message );
2085             }
2086              
2087 0         0 $ftp->quit;
2088 0         0 return 1;
2089             }
2090             sub ftptest {
2091 0   0 0 1 0 my $ftpdata = shift || undef;
2092 0 0       0 unless ($ftpdata) {
2093 0         0 carp("Connect's data missing");
2094 0         0 return undef;
2095             }
2096 0         0 my $vfile = '';
2097 0 0       0 if ($ftpdata->{voidfile}) {
2098 0         0 $vfile = $ftpdata->{voidfile};
2099             } else {
2100 0         0 $vfile = catfile(tmpdir(), VOIDFILE);
2101 0         0 touch($vfile);
2102             }
2103 0 0       0 unless (-e $vfile) {
2104 0         0 carp("VOID file \"$vfile\" missing");
2105 0         0 return undef;
2106             }
2107 0         0 ftp($ftpdata, 'put', $vfile, VOIDFILE);
2108 0         0 my $rfiles = ftp($ftpdata,'ls');
2109 0 0       0 my @remotefiles = $rfiles ? grep {!(/^\./)} @$rfiles : ();
  0         0  
2110 0 0       0 unless (grep {$_ eq VOIDFILE} @remotefiles) {
  0         0  
2111 0         0 carp("Can't connect to remote FTP server {".join(", ",(%$ftpdata))."}");
2112 0         0 return undef;
2113             }
2114 0         0 ftp($ftpdata, 'delete', VOIDFILE);
2115 0         0 return 1;
2116             }
2117             sub ftpgetlist {
2118 0   0 0 1 0 my $connect = shift || {};
2119 0   0     0 my $mask = shift || '';
2120              
2121 0         0 my $rfile = ftp($connect, 'ls');
2122 0 0 0     0 my @files = (($rfile && ref($rfile) eq 'ARRAY') ? @$rfile : ());
2123              
2124 0 0 0     0 if ($mask && ref($mask) eq 'Regexp') {
2125 0         0 @files = grep {$_ =~ $mask} @files;
  0         0  
2126             } else {
2127 0 0       0 @files = grep {/$mask/} @files if $mask;
  0         0  
2128             }
2129              
2130 0         0 return [@files];
2131             }
2132             sub execute {
2133 0   0 0 1 0 my $icmd = shift || '';
2134 0         0 my $in = shift;
2135 0         0 my $out = '';
2136 0         0 my $err = shift; # !! REFERENCE TO SCALAR
2137 0         0 my $bm = shift;
2138              
2139 0         0 my @scmd;
2140 0 0 0     0 if ($icmd && ref($icmd) eq 'ARRAY') {
2141 0         0 @scmd = @$icmd;
2142             } else {
2143 0         0 push @scmd, $icmd;
2144             }
2145              
2146 0         0 local (*IN, *OUT, *ERR);
2147 0         0 my $pid = open3(\*IN, \*OUT, \*ERR, @scmd);
2148              
2149             # 0 Input
2150 0 0 0     0 binmode(IN) if defined($bm) && $bm && $bm =~ /^\d+$/;
      0        
2151 0 0 0     0 binmode(IN, $bm) if defined($bm) && $bm =~ /\:/;
2152 0 0       0 print IN $in if defined $in;
2153 0         0 close IN;
2154              
2155             # 1 Output
2156 0 0 0     0 binmode(OUT) if defined($bm) && $bm && $bm =~ /^\d+$/;
      0        
2157 0 0 0     0 binmode(OUT, $bm) if defined($bm) && $bm =~ /\:/;
2158 0         0 while () { $out .= $_ }
  0         0  
2159 0         0 close OUT;
2160              
2161             # 2 Error
2162 0         0 my $ierr = '';
2163 0 0 0     0 binmode(ERR) if defined($bm) && $bm && $bm =~ /^\d+$/;
      0        
2164 0 0 0     0 binmode(ERR, $bm) if defined($bm) && $bm =~ /\:/;
2165 0         0 while () { $ierr .= $_ }
  0         0  
2166 0         0 close ERR;
2167              
2168 0         0 waitpid($pid, 0);
2169 0 0 0     0 if ($err && ref($err) eq 'SCALAR') {
2170 0         0 $$err = $ierr
2171             } else {
2172 0 0       0 carp("Executable error (".join(" ", @scmd)."): $ierr") if $ierr;
2173             }
2174              
2175 0         0 return $out;
2176             }
2177 0     0 1 0 sub exe { goto &execute }
2178             sub which {
2179 0     0 1 0 my $cs = shift;
2180 0         0 my $wh = shift;
2181 0 0       0 return undef unless defined $cs;
2182 0 0       0 return undef if $cs eq '';
2183 0         0 my @aliases = ($cs);
2184 0 0       0 if (isostype('Windows')) {
2185 0         0 my @pext = (qw/.com .exe .bat/);
2186 0 0       0 if ($ENV{PATHEXT}) {
2187 0         0 push @pext, split /\s*\;\s*/, lc($ENV{PATHEXT});
2188             }
2189 0         0 push @aliases, $cs.$_ for (_uniq(@pext));
2190             }
2191 0         0 my @path = path();
2192 0         0 unshift @path, curdir();
2193              
2194 0         0 my @arr = ();
2195 0         0 foreach my $p ( @path ) {
2196 0         0 foreach my $f ( @aliases ) {
2197 0         0 my $file = catfile($p, $f);
2198 0 0       0 next if -d $file;
2199 0 0       0 if (isostype('Windows')) {
    0          
2200 0 0       0 if (-e $file) {
2201 0 0       0 my $nospcsf = ($file =~ /\s/) ? sprintf("\"%s\"", $file) : $file;
2202 0 0       0 if ($wh) {push @arr, $nospcsf} else {return $nospcsf}
  0         0  
  0         0  
2203             }
2204             } elsif (isostype('Unix')) {
2205 0 0 0     0 if (-e $file and -x _) {
2206 0 0       0 if ($wh) {push @arr, $file} else {return $file}
  0         0  
  0         0  
2207             }
2208             } else {
2209 0 0       0 if (-e $file) {
2210 0 0       0 if ($wh) {push @arr, $file} else {return $file}
  0         0  
  0         0  
2211             }
2212             }
2213             }
2214             }
2215 0 0       0 return @arr if $wh;
2216 0         0 return undef;
2217             }
2218 0     0 1 0 sub where { which(shift,1) }
2219              
2220             #
2221             # See Sys::Path
2222             #
2223             # prefixdir localstatedir sysconfdir srvdir
2224             # sharedir docdir localedir cachedir syslogdir spooldir rundir lockdir sharedstatedir webdir
2225             #
2226             sub prefixdir {
2227 18     18 1 93 my $pfx = __PACKAGE__->ext_syscfg('prefix') ;
2228 18 50       55 return defined $pfx ? $pfx : '';
2229             }
2230             sub localstatedir {
2231 10     10 1 20 my $pfx = prefixdir();
2232 10 50       32 if ($pfx eq '/usr') {
    50          
2233 0         0 return '/var';
2234             } elsif ($pfx eq '/usr/local') {
2235 10         141 return '/var';
2236             }
2237 0         0 return catdir($pfx, 'var');
2238             }
2239             sub sysconfdir {
2240 8     8 1 20 my $pfx = prefixdir();
2241 8 50       165 return $pfx eq '/usr' ? '/etc' : catdir($pfx, 'etc');
2242             }
2243             sub srvdir {
2244 0     0 1 0 my $pfx = prefixdir();
2245 0 0       0 if ($pfx eq '/usr') {
    0          
2246 0         0 return '/srv';
2247             } elsif ($pfx eq '/usr/local') {
2248 0         0 return '/srv';
2249             }
2250 0         0 return catdir($pfx, 'srv');
2251             }
2252             sub webdir {
2253 0     0 1 0 my $pfx = prefixdir();
2254 0 0       0 return $pfx eq '/usr' ? '/var/www' : catdir($pfx, 'www');
2255             }
2256 0     0 1 0 sub sharedir { catdir(prefixdir(), 'share') }
2257 0     0 1 0 sub docdir { catdir(prefixdir(), 'share', 'doc') }
2258 0     0 1 0 sub localedir { catdir(prefixdir(), 'share', 'locale') }
2259 0     0 1 0 sub cachedir { catdir(localstatedir(), 'cache') }
2260 10     10 1 24 sub syslogdir { catdir(localstatedir(), 'log') }
2261 0     0 1 0 sub spooldir { catdir(localstatedir(), 'spool') }
2262 0     0 1 0 sub rundir { catdir(localstatedir(), 'run') }
2263 0     0 1 0 sub lockdir { catdir(localstatedir(), 'lock') }
2264 0     0 1 0 sub sharedstatedir { catdir(localstatedir(), 'lib') }
2265              
2266             #
2267             # Sys core utils
2268             #
2269 0     0 1 0 sub getsyscfg { __PACKAGE__->ext_syscfg(@_) }
2270 0     0 1 0 sub syscfg { __PACKAGE__->ext_syscfg(@_) }
2271 40     40 1 210 sub isostype {__PACKAGE__->ext_isostype(@_)}
2272 0     0 1 0 sub isos {__PACKAGE__->ext_isos(@_)}
2273              
2274             #
2275             # API
2276             #
2277             # Smart rearrangement of parameters to allow named parameter calling.
2278             # See also CGI::Util
2279             #
2280             sub read_attributes {
2281 5     5 1 4674 my ($schema, @param) = @_;
2282 5 50 33     27 unless ($schema && ref($schema) eq 'ARRAY') {
2283 0         0 carp("No scheme specified");
2284 0         0 return ();
2285             }
2286 5         6 my $first = $param[0];
2287 5         6 my %params;
2288 5 50       24 if (ref($first) eq 'HASH') {
    50          
    100          
2289 0         0 %params = %$first;
2290             } elsif (ref($first) eq 'ARRAY') {
2291 0         0 %params = (@$first);
2292             } elsif (!defined($first)) {
2293 1         3 return ();
2294             } else {
2295 4         9 %params = @param
2296             }
2297              
2298             # Map parameters into positional indices
2299 4         5 my %pos; # alias => name
2300 4         7 my $i = 0;
2301 4         7 foreach my $s (@$schema) {
2302 8 100       16 my @ks = ref($s) eq 'ARRAY' ? @$s : ($s);
2303 8         10 foreach my $k (@ks) {
2304 16         34 $pos{lc($k)} = $i;
2305             }
2306 8         11 $i++;
2307             }
2308              
2309 4         4 my @result;
2310 4         12 $#result = $#$schema; # Preextend
2311 4         15 while (my ($k, $v) = each %params) {
2312 10         13 my $key = lc($k);
2313 10         25 $key =~ s/^\-//;
2314 10 100       34 $result[$pos{$key}] = $v if exists $pos{$key};
2315             }
2316 4         25 return @result;
2317             }
2318              
2319             sub _crlf {
2320             # Original: CGI::Simple
2321 20 50   20   61 return "\015\012" if isostype('Windows');
2322 20 50       401 return "\012" if isostype('Unix');
2323 0   0     0 my $OS = $^O || do { require Config; $Config::Config{'osname'} };
2324             return
2325 0 0       0 ( $OS =~ m/VMS/i ) ? "\n"
2326             : ( "\t" ne "\011" ) ? "\r\n"
2327             : "\015\012";
2328             }
2329 0     0   0 sub _proxy_crlf {shift}
2330             sub _uniq {
2331             # See List::MoreUtils::PP
2332 0     0   0 my %seen = ();
2333 0         0 my $k;
2334             my $seen_undef;
2335 0 0       0 grep { defined $_ ? not $seen{$k = $_}++ : not $seen_undef++ } @_;
  0         0  
2336             }
2337              
2338             1;
2339              
2340             package # hide me from PAUSE
2341             CTK::Util::SysConfig;
2342 20     20   271 use strict;
  20         47  
  20         750  
2343 20     20   112 use vars qw/$VERSION/;
  20         52  
  20         1436  
2344             $VERSION = $CTK::Util::VERSION;
2345 20     20   143 use Config qw//;
  20         92  
  20         392  
2346 20     20   9716 use Perl::OSType qw//;
  20         8456  
  20         4371  
2347             sub ext_syscfg {
2348 18 50 33 18   24 my $caller; $caller = shift if (@_ && $_[0] && $_[0] eq 'CTK::Util');
  18   33     106  
2349 18         39 my $param = shift;
2350 18 50       33 if (defined $param) {
2351 18         443 return $Config::Config{$param}
2352             }
2353 0         0 my %locconf = %Config::Config;
2354 0         0 return %locconf;
2355             }
2356             sub ext_isostype {
2357 40 50 33 40   59 my $caller; $caller = shift if (@_ && $_[0] && $_[0] eq 'CTK::Util');
  40   33     2208  
2358 40         1618 return Perl::OSType::is_os_type(@_);
2359             }
2360             sub ext_isos {
2361 0 0 0 0     my $caller; $caller = shift if (@_ && $_[0] && $_[0] eq 'CTK::Util');
  0   0        
2362 0           my $cos = shift;
2363 0           my $os = $^O;
2364 0 0 0       return $cos && (lc($os) eq lc($cos)) && Perl::OSType::os_type($os) ? 1 : 0;
2365             }
2366              
2367             1;
2368              
2369             __END__