File Coverage

blib/lib/Net/DirectConnect/pslib/psmisc.pm
Criterion Covered Total %
statement 53 891 5.9
branch 5 602 0.8
condition 5 547 0.9
subroutine 18 134 13.4
pod 0 97 0.0
total 81 2271 3.5


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             #$Id: psmisc.pm 4847 2014-06-30 23:41:45Z pro $ $URL: svn://svn.setun.net/search/trunk/lib/psmisc.pm $
3              
4             =copyright
5             PRO-search shared library
6             Copyright (C) 2003-2011 Oleg Alexeenkov http://pro.setun.net/search/ proler@gmail.com
7              
8             This program is free software: you can redistribute it and/or modify
9             it under the terms of the GNU General Public License as published by
10             the Free Software Foundation, either version 3 of the License, or
11             (at your option) any later version.
12              
13             This program is distributed in the hope that it will be useful,
14             but WITHOUT ANY WARRANTY; without even the implied warranty of
15             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16             GNU General Public License for more details.
17              
18             You should have received a copy of the GNU General Public License
19             along with this program. If not, see .
20             =cut
21              
22             #print "Content-type: text/html\n\n" if defined($ENV{'SERVER_PORT'}); # for web dev debug
23             #print "misc execute " , $mi++;
24             #=pac
25             #local *config = *main::config;
26             #%config
27             #our ( %config );
28             package #not ready for cpan
29             psmisc;
30 1     1   7 use strict;
  1         2  
  1         45  
31 1     1   6 no warnings qw(uninitialized);
  1         2  
  1         50  
32 1     1   7 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  1         3  
  1         9  
33 1     1   54 use utf8;
  1         2  
  1         10  
34             #use open qw(:utf8 :std);
35             #use encoding "utf8", STDOUT => "utf8", STDIN => "utf8", STDERR => "utf8";
36             #use open ':utf8';
37 1     1   26 use Socket;
  1         2  
  1         829  
38 1     1   8 use Time::HiRes qw(time);
  1         2  
  1         13  
39             #use locale;
40 1     1   158 use Encode;
  1         53  
  1         104  
41 1     1   6 use POSIX qw(strftime);
  1         3  
  1         10  
42 1     1   604 use lib::abs;
  1         2  
  1         7  
43             our $VERSION = ( split( ' ', '$Revision: 4847 $' ) )[1];
44             our (%config);
45             #my ( %config );
46             #local *config = *main::config;
47             #local
48             #*psmisc::config = *main::config;
49             *config = *main::config;
50             *stat = *main::stat;
51             *work = *main::work;
52             *param = *main::param;
53             *static = *main::static;
54             #*psmisc::program = *main::program;
55 1     1   158 use Data::Dumper; #dev only
  1         3  
  1         120  
56             $Data::Dumper::Sortkeys = $Data::Dumper::Useqq = $Data::Dumper::Indent = 1;
57             #use vars qw( %config %work %stat %static $param %processor %program %out ); #%human,
58             #our ( @ISA, @EXPORT, @EXPORT_OK ,%EXPORT_TAGS);
59             our ( @EXPORT, @EXPORT_OK, %EXPORT_TAGS );
60             #use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
61             #require Exporter;
62 1     1   7 use Exporter 'import';
  1         2  
  1         23884  
63             #our
64             #@
65             #@ISA = qw(Exporter);
66             # @EXPORT = qw(A1 A2 A3 A4 A5);
67             # @EXPORT_OK = qw(B1 B2 B3 B4 B5);
68             # %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
69             #our %config;
70             @EXPORT = qw(
71             );
72             @EXPORT_OK = qw(
73             get_params_one
74             get_params
75             array
76             encode_url
77             encode_url_link
78             decode_url
79             printlog
80             dmp
81             printprog
82             openproc
83             state
84             hconfig
85             html_chars
86             name_to_ip
87             normalize_ip
88             ip_to_name
89             counter
90             timer
91             join_url
92             split_url
93             full_host
94             cp_trans
95             utf_trans
96             to_utf_trans
97             cp_trans_hash
98             cp_detect_trans
99             lang
100             min
101             max
102             alarmed
103             mkdir_rec
104             sleeper
105             mysleep
106             check_int
107             shuffle
108             config_reload
109             conf
110             http_get
111             http_get_code
112             loadlist
113             shelldata
114             printall
115             %work %static $param
116             %program
117             );
118             # %config
119             %EXPORT_TAGS = ( log => [qw(printlog dmp)], config => [qw(%config)], all => \@EXPORT_OK, ); #%human %out %processor %stat
120              
121             =no
122             open_out_file
123             close_out_file
124             =cut
125              
126             #flush
127             #our ( %config, %work, %stat, %static, $param, %program, $root_path, ); #%human, %out, %processor,
128             our ( %work, %static, $param, %program, $root_path, ); #%human, %out, %processor, %stat,
129             #my %human;
130             #sub conf_once {
131             sub config_init {
132 1 50   1 0 8 return if $static{'lib_init_psmisc'}{ $ENV{'SCRIPT_FILENAME'} }++;
133 1         3 my ($param) = @_;
134             #print " config_init;";
135             #caller_trace(10);
136             conf(
137             sub {
138             #print " config_init:sub;";
139 0   0 0   0 $config{'stderr_redirect'} ||= '2>&1'; #'2>/dev/null';
140             #A | YA E a | ya e |-ukr------------------|
141 0   0     0 $config{'trans'}{'cp1251'} ||=
142             "\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xA8\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF\xB8\xB2\xB3\xAF\xBF\xAA\xBA";
143 0   0     0 $config{'trans'}{'koi8-r'} ||=
144             "\xE1\xE2\xF7\xE7\xE4\xE5\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xB3\xC1\xC2\xD7\xC7\xC4\xC5\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1\xA3\xB6\xA6\xB7\xA7\xB4\xA4";
145 0   0     0 $config{'trans'}{'iso8859-5'} ||=
146             "\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xA1\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF1\xA6\xF6\xA7\xF7\xA4\xF4";
147 0   0     0 $config{'trans'}{'cp866'} ||=
148             "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xF0\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF1\xF6\xF7\xF8\xF9\xF4\xF5";
149 0   0     0 $config{'trans'}{'utf-8'} ||= "\xD0\xD1"; #JUST TRICK for autodetect
150             #$config{'trans_up'}{$_} = (split//, $config{'trans'}{$_})[0..32] for keys %{$config{'trans'}};
151 0         0 $config{'trans_up'}{$_} = substr( $config{'trans'}{$_}, 0, 33 ),
152             $config{'trans_lo'}{$_} = substr( $config{'trans'}{$_}, 33, 33 ),
153             #print("$config{'trans_up'}{$_}\n$config{'trans_lo'}{$_}\n"),
154 0         0 for grep { length $config{'trans'}{$_} >= 66 } keys %{ $config{'trans'} };
  0         0  
155             #exit;
156              
157             =with 50% UPPER case
158             #cp detect with cp_learn_symbols=10; from 28691 bytes text
159             $config{'trans_detect'}{'cp1251'} ||= '\xCE\xEE\xC0\xE0\xE5\xC5\xD2\xF2\xE8\xC8'; # [­Ќоћ…Ґађ•е] = [­Ќоћ…Ґађ•е]; stat:­[CE]=658; Ќ[EE]=658; о[C0]=578; ћ[E0]=578; …[E5]=503; Ґ[C5]=503; а[D2]=434; ђ[F2]=434; •[E8]=422; е[C8]=422;
160             $config{'trans_detect'}{'cp866'} ||= '\xAE\x8E\x80\xA0\xA5\x85\x92\xE2\xA8\x88'; # [R__Н_:'Ѓ»_] = [Ќ­оћ…Ґађ•е]; stat:Ќ[AE]=658; ­[8E]=658; о[80]=578; ћ[A0]=578; …[A5]=503; Ґ[85]=503; а[92]=434; ђ[E2]=434; •[A8]=422; е[88]=422;
161             $config{'trans_detect'}{'koi8-r'} ||= '\xCF\xEF\xC1\xE1\xC5\xE5\xD4\xF4\xC9\xE9'; # [®Ћ ЂҐ…в’Ё€] = [Ќ­ћо…Ґђа•е]; stat:Ќ[CF]=658; ­[EF]=658; ћ[C1]=578; о[E1]=578; …[C5]=503; Ґ[E5]=503; ђ[D4]=434; а[F4]=434; •[C9]=422; е[E9]=422;
162             $config{'trans_detect'}{'utf-8'} ||= '\xD0\xD1\x9E\xBE\xB0\x90\x95\xB5\xA2\x82'; # [Їп__З_‚Х'] = [Їпз_ЗЇг‚ЃЎ]; stat:Ї[D0]=10542; п[D1]=1934; з[9E]=658; _[BE]=658; З[B0]=578; Ї[90]=578; г[95]=503; ‚[B5]=503; Ѓ[A2]=434; Ў[82]=434;
163             #$config{'trans_detect'}{'iso8859-5'} ||= '\xDE\xBE\xD0\xB0\xB5\xD5\xC2\xE2\xB8\xD8'; # [з_ЇЗ‚гЎЃЛм] = [Ќ­ћоҐ…ађе•]; stat:Ќ[DE]=658; ­[BE]=658; ћ[D0]=578; о[B0]=578; Ґ[B5]=503; …[D5]=503; а[C2]=434; ђ[E2]=434; е[B8]=422; •[D8]=422;
164             =cut
165              
166             =was
167             #cp detect with cp_learn_symbols=20; from 14344 bytes text
168             $config{'trans_detect'}{'cp1251'} ||= '\xEE\xE0\xE5\xF2\xE8\xED\xF1\xF0\xE2\xEA\xEB\xEF\xE4\xFC\xEC\xE7\xF3\xE1\xFB\xF7'
169             ; # [Ќћ…ђ•ЊџЏЃ‰ЉЋ„ќ‹ѓ‘Ђ˜‚] = [Ќћ…ђ•ЊџЏЃ‰ЉЋ„ќ‹ѓ‘Ђ˜‚]; stat:Ќ[EE]=649; ћ[E0]=573; …[E5]=489; ђ[F2]=425; •[E8]=416; Њ[ED]=410; џ[F1]=379; Џ[F0]=296; Ѓ[E2]=269; ‰[EA]=256; Љ[EB]=221; Ћ[EF]=194; „[E4]=174; ќ[FC]=156; ‹[EC]=153; ѓ[E7]=152; ‘[F3]=141; Ђ[E1]=109; ˜[FB]=108; ‚[F7]=100;
170             $config{'trans_detect'}{'cp866'} ||= '\xAE\xA0\xA5\xE2\xA8\xAD\xE1\xE0\xA2\xAA\xAB\xAF\xA4\xEC\xAC\xA7\xE3\xA1\xEB\xE7'
171             ; # [RН_Ѓ»-ЂћХУ<ЖЦ‹ѕ·–єЉѓ] = [Ќћ…ђ•ЊџЏЃ‰ЉЋ„ќ‹ѓ‘Ђ˜‚]; stat:Ќ[AE]=649; ћ[A0]=573; …[A5]=489; ђ[E2]=425; •[A8]=416; Њ[AD]=410; џ[E1]=379; Џ[E0]=296; Ѓ[A2]=269; ‰[AA]=256; Љ[AB]=221; Ћ[AF]=194; „[A4]=174; ќ[EC]=156; ‹[AC]=153; ѓ[A7]=152; ‘[E3]=141; Ђ[A1]=109; ˜[EB]=108; ‚[E7]=100;
172             $config{'trans_detect'}{'koi8-r'} ||= '\xCF\xC1\xC5\xD4\xC9\xCE\xD3\xD2\xD7\xCB\xCC\xD0\xC4\xD8\xCD\xDA\xD5\xC2\xD9\xDE'
173             ; # [® ҐвЁ­баўЄ«Ї¤м¬§гЎлз] = [Ќћ…ђ•ЊџЏЃ‰ЉЋ„ќ‹ѓ‘Ђ˜‚]; stat:Ќ[CF]=649; ћ[C1]=573; …[C5]=489; ђ[D4]=425; •[C9]=416; Њ[CE]=410; џ[D3]=379; Џ[D2]=296; Ѓ[D7]=269; ‰[CB]=256; Љ[CC]=221; Ћ[D0]=194; „[C4]=174; ќ[D8]=156; ‹[CD]=153; ѓ[DA]=152; ‘[D5]=141; Ђ[C2]=109; ˜[D9]=108; ‚[DE]=100;
174             $config{'trans_detect'}{'utf-8'} ||= '\xD0\xD1\xBE\xB0\xB5\x82\xB8\xBD\x81\x80\xB2\xBA\xBB\xBF\xB4\x8C\xBC\xB7\x83\xB1'
175             ; # [Їп_З‚'Л____Р>ь___Т_+] = [Їп_З‚ЎЛ_ о_Р>ь_«_Тж+]; stat:Ї[D0]=4352; п[D1]=1894; _[BE]=649; З[B0]=573; ‚[B5]=489; Ў[82]=425; Л[B8]=416; _[BD]=410;  [81]=379; о[80]=296; _[B2]=269; Р[BA]=256; >[BB]=221; ь[BF]=194; _[B4]=174; «[8C]=156; _[BC]=153; Т[B7]=152; ж[83]=141; +[B1]=109;
176             =cut
177              
178             #cp detect with cp_learn_symbols=20; from 145699 bytes text
179 0         0 $config{'trans_detect'}{'cp1251'} = '\xEE\xE0\xE5\xE8\xED\xF2\xF1\xF0\xEB\xE2\xEA\xF3\xEF\xEC\xE4\xFF\xFB\xFC\xE7\xE3'
180             ; # [оаеинтсрлвкупмдяыьзг] = [оаеинтсрлвкупмдяыьзг]; stat:о[EE]=12122; а[E0]=10566; е[E5]=9827; и[E8]=8929; н[ED]=7504; т[F2]=6931; с[F1]=6839; р[F0]=6744; л[EB]=6225; в[E2]=5384; к[EA]=4505; у[F3]=3912; п[EF]=3864; м[EC]=3811; д[E4]=3497; я[FF]=3047; ы[FB]=2693; ь[FC]=2628; з[E7]=2192; г[E3]=1934;
181 0         0 $config{'trans_detect'}{'utf-8'} = '\xD0\xD1\xBE\xB0\xB5\xB8\xBD\x82\x81\x80\xBB\xB2\xBA\x83\xBF\xBC\xB4\x8F\x8B\x8C'
182             ; # [РС?°чё?'??>Iє?ї???IєГї??ПЛМ]; stat:Р[D0]=88304; С[D1]=39900; ?[BE]=12122; °[B0]=10566; ч[B5]=9827; ё[B8]=8929; ?[BD]=7504; В[82]=6931; Б[81]=6845; А[80]=6744; >[BB]=6225; I[B2]=5384; є[BA]=4505; Г[83]=3912; ї[BF]=3864; ?[BC]=3811; ?[B4]=3497; П[8F]=3047; Л[8B]=2693; М[8C]=2628;
183 0         0 $config{'trans_detect'}{'cp866'} = '\xAE\xA0\xA5\xA8\xAD\xE2\xE1\xE0\xAB\xA2\xAA\xE3\xAF\xAC\xA4\xEF\xEB\xEC\xA7\xA3'
184             ; # [R ?Ё-вба<ўЄгЇ¬¤плм§?] = [оаеинтсрлвкупмдяыьзг]; stat:о[AE]=12122; а[A0]=10566; е[A5]=9827; и[A8]=8929; н[AD]=7504; т[E2]=6931; с[E1]=6839; р[E0]=6744; л[AB]=6225; в[A2]=5384; к[AA]=4505; у[E3]=3912; п[AF]=3864; м[AC]=3811; д[A4]=3497; я[EF]=3047; ы[EB]=2693; ь[EC]=2628; з[A7]=2192; г[A3]=1934;
185 0         0 $config{'trans_detect'}{'koi8-r'} = '\xCF\xC1\xC5\xC9\xCE\xD4\xD3\xD2\xCC\xD7\xCB\xD5\xD0\xCD\xC4\xD1\xD9\xD8\xDA\xC7'
186             ; # [ПБЕЙОФУТМЧЛХРНДСЩШЪЗ] = [оаеинтсрлвкупмдяыьзг]; stat:о[CF]=12122; а[C1]=10566; е[C5]=9827; и[C9]=8929; н[CE]=7504; т[D4]=6931; с[D3]=6839; р[D2]=6744; л[CC]=6225; в[D7]=5384; к[CB]=4505; у[D5]=3912; п[D0]=3864; м[CD]=3811; д[C4]=3497; я[D1]=3047; ы[D9]=2693; ь[D8]=2628; з[DA]=2192; г[C7]=1934;
187             #$config{'trans_detect'}{'iso8859-5'} = '\xDE\xD0\xD5\xD8\xDD\xE2\xE1\xE0\xDB\xD2\xDA\xE3\xDF\xDC\xD4\xEF\xEB\xEC\xD7\xD3'; # [ЮРХШЭвбаЫТЪгЯЬФплмЧУ] = [оаеинтсрлвкупмдяыьзг]; stat:о[DE]=12122; а[D0]=10566; е[D5]=9827; и[D8]=8929; н[DD]=7504; т[E2]=6931; с[E1]=6839; р[E0]=6744; л[DB]=6225; в[D2]=5384; к[DA]=4505; у[E3]=3912; п[DF]=3864; м[DC]=3811; д[D4]=3497; я[EF]=3047; ы[EB]=2693; ь[EC]=2628; з[D7]=2192; г[D3]=1934;
188             #$config{'trans_detect'}{'iso8859-5'} ||= '\xDE\xD0\xD5\xE2\xD8\xDD\xE1\xE0\xD2\xDA\xDB\xDF\xD4\xEC\xDC\xD7\xE3\xD1\xEB\xE7'; # [зЇгЃмйЂћа§икв‹нў–пЉѓ] = [Ќћ…ђ•ЊџЏЃ‰ЉЋ„ќ‹ѓ‘Ђ˜‚]; stat:Ќ[DE]=649; ћ[D0]=573; …[D5]=489; ђ[E2]=425; •[D8]=416; Њ[DD]=410; џ[E1]=379; Џ[E0]=296; Ѓ[D2]=269; ‰[DA]=256; Љ[DB]=221; Ћ[DF]=194; „[D4]=174; ќ[EC]=156; ‹[DC]=153; ѓ[D7]=152; ‘[E3]=141; Ђ[D1]=109; ˜[EB]=108; ‚[E7]=100;
189             #$config{'trans_detect'}{'cp1251'} ||= "\xE0\xC0\xEE\xCE"; #ћо Ќ­
190             #$config{'trans_detect'}{'cp866'} ||= "\xA0\x80\xAE\x8E";
191             #$config{'trans_detect'}{'koi8-r'} ||= "\xC1\xE1\xCF\xEF";
192             ## $config{'trans_detect'}{'iso8859-5'} ||= "\xD0\xB0\xDE\xBE";
193             #$config{'trans_detect'}{'utf-8'} ||= "\xD0\xD1";
194             #$config{'trans_detect'}{'bin'} ||= join '', map{'\\x'.sprintf '%02X', $_}0..0x08,0x0B,0x0C,0x0E,0x0F;
195             #$config{'trans_detect'}{'latin'} ||= 'a-zA-Z';
196             #print $config{'trans_detect'}{'bin'};exit;
197             #$config{'trans_name'}{'cp1251'} ||= 'cp1251';
198 0   0     0 $config{'trans_name'}{'win1251'} ||= 'cp1251';
199 0   0     0 $config{'trans_name'}{'windows1251'} ||= 'cp1251';
200 0   0     0 $config{'trans_name'}{'windows-1251'} ||= 'cp1251';
201 0   0     0 $config{'trans_name'}{'win'} ||= 'cp1251';
202 0   0     0 $config{'trans_name'}{'1251'} ||= 'cp1251';
203             #$config{'trans_name'}{'koi8-r'} ||= 'koi8-r';
204 0   0     0 $config{'trans_name'}{'koi8r'} ||= 'koi8-r';
205 0   0     0 $config{'trans_name'}{'koi8'} ||= 'koi8-r';
206 0   0     0 $config{'trans_name'}{'koi'} ||= 'koi8-r';
207             #$config{'trans_name'}{'iso8859-5'} ||='iso8859-5';
208 0   0     0 $config{'trans_name'}{'iso88595'} ||= 'iso8859-5';
209 0   0     0 $config{'trans_name'}{'iso8859'} ||= 'iso8859-5';
210 0   0     0 $config{'trans_name'}{'iso'} ||= 'iso8859-5';
211             #$config{'trans_name'}{'cp866'} ||='cp866';
212 0   0     0 $config{'trans_name'}{'866'} ||= 'cp866';
213 0   0     0 $config{'trans_name'}{'dos'} ||= 'cp866';
214             #$config{'trans_name'}{'utf-8'} ||= 'utf-8';
215 0   0     0 $config{'trans_name'}{'utf8'} ||= 'utf-8';
216 0   0     0 $config{'trans_name'}{'utf'} ||= 'utf-8';
217 0   0     0 $config{'cp_detect_strings'} ||= 0;
218 0   0     0 $config{'cp_detect_letters'} ||= 2;
219 0   0     0 $config{'cp_detect_length'} ||= 10000;
220 0   0     0 $config{'kilo'} ||= 8; # 5000k 6000k 7000k >8
221 0   0     0 $config{'lng'}{'en'}{'months'} ||= [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)];
222 0   0     0 $config{'lng'}{'ru'}{'months'} ||=
223             [qw(Янв Фев Мар Апр Май Июн Июл Авг Сен Окт Ноя Дек)];
224 0 0       0 @{ $config{'lng'}{$_}{'month_table'} }{ @{ $config{'lng'}{$_}{'months'} || [] } } = ( 0 .. 11 )
  0         0  
  0         0  
225 0         0 for keys %{ $config{'lng'} };
226             #@{ $config{'lng'}{''}{'month_table'} }{ @{ $config{'lng'}{''}{'months'} } } = ( 0 .. 11 ) ;
227 0   0     0 $config{'lng'}{'en'}{'wdays'} ||= [qw(Sun Mon Tue Wed Thu Fri Sat)];
228 0   0     0 $config{'log_screen'} ||= 1;
229 0   0     0 $config{'log_dir'} ||= $config{'root_path'};
230 0 0       0 unless ( $ENV{'SERVER_PORT'} ) {
231 0         0 $0 =~ m{([^\\/\s]+)\.\w+$};
232             #warn "LD[$0:$1]";
233 0   0     0 $config{'log_default'} ||= ( $1 // $0 // 'log' ) . '.log';
      0        
      0        
234             }
235             #$config{'log_all'} ||= '#book.log';
236             #$config{'log_all'} ||= '1';
237 0   0     0 $config{'encode_url_file_mask'} ||= '[^a-zA-Z0-9\-.()_]'; #url = '[^a-zA-Z0-9\-.()_!,]';
238             $config{'human'}{'date'} ||= sub { #v1
239             #my ( $day_of_month, $month, $year ) = ( localtime( ( $_[0] or time() ) ) )[ 3 .. 5 ];
240             #return sprintf( '%04d' . ( ( ( $_[1] or '/' ) . '%02d' ) x 2 ), $year + 1900, $month + 1, $day_of_month );
241 0   0     0 my $d = $_[1] || '/';
242 0   0     0 return strftime "%Y${d}%m${d}%d", localtime( $_[0] || time() );
243             #strftime "%Y%m%d%H%M%S", localtime
244 0   0     0 };
245             $config{'human'}{'time'} ||= sub {
246             #return sprintf( join( ( $_[1] or ':' ), ( ("%02d") x 3 ) ), ( reverse( ( localtime( ( $_[0] or time() ) ) )[ 0 .. 2 ] ) ) );
247 0   0     0 my $d = $_[1] || ':';
248 0   0     0 return strftime "%H${d}%M${d}%S", localtime( $_[0] || time() );
249 0   0     0 };
250             # strftime "%Y-%m-%dT%H:%M:%S", localtime( $_[0] || time() )
251             $config{'human'}{'date_time'} ||=
252 0   0     0 sub { return human( 'date', $_[0] || time(), $_[2] ) . ( $_[1] || '-' ) . human( 'time', $_[0] || time(), $_[3] ); };
  0   0     0  
      0        
      0        
253             $config{'human'}{'float'} ||= sub { #v1
254 0 0 0     0 return ( $_[0] < 8 and $_[0] - int( $_[0] ) )
    0          
    0          
255             ? sprintf( '%.' . ( $_[0] < 1 ? 3 : ( $_[0] < 3 ? 2 : 1 ) ) . 'f', $_[0] )
256             : int( $_[0] );
257 0   0     0 };
258             $config{'human'}{'micro_time'} ||= sub {
259 0         0 my $now = time();
260 0         0 ( $now = human( 'float', abs( int($now) - $now ) ) ) =~ s/^0//;
261 0   0     0 return ( $now or '' );
262 0   0     0 };
263             $config{'human'}{'rfc822_date_time'} ||= sub {
264 0   0     0 my ( $day_of_month, $month, $year, $wday ) = ( localtime( ( $_[0] or time() ) ) )[ 3 .. 6 ];
265 0   0     0 return sprintf( $config{'lng'}{'en'}{'wdays'}[$wday] . ', %02d ' . $config{'lng'}{'en'}{'months'}[$month] . ' %02d',
266             $day_of_month, $year + 1900 )
267             . ' '
268             . $config{'human'}{'time'}->( ( $_[0] or time() ) )
269             . ' +0300';
270 0   0     0 };
271             $config{'human'}{'size'} ||= sub {
272 0         0 my ( $size, $sp, $unit, $kilo ) = @_;
273 0 0 0     0 $sp //= ( $ENV{'SERVER_PORT'} ? ' ' : ' ' );
274 0   0     0 $unit //= 'B';
275 0   0     0 $kilo //= $config{'kilo'} || 8;
      0        
276 0 0       0 return int( $size / 1099511627776 ) . $sp . 'T' . $unit if ( $size >= $kilo * 1099511627776 );
277 0 0       0 return int( $size / 1073741824 ) . $sp . 'G' . $unit if ( $size >= $kilo * 1073741824 );
278 0 0       0 return int( $size / 1048576 ) . $sp . 'M' . $unit if ( $size >= $kilo * 1048576 );
279 0 0       0 return int( $size / 1024 ) . $sp . 'K' . $unit if ( $size >= $kilo * 1024 );
280 0 0       0 return human( 'float', $size ) . $sp . $unit if ( $size > 0 );
281 0         0 return $size;
282 0   0     0 };
283             $config{'human'}{'number_k'} ||= sub {
284 0         0 local $_ = $_[0];
285 0 0       0 $_ *= 1024 if ( $_ =~ s/kb?$//gi );
286 0 0       0 $_ *= 1048576 if ( $_ =~ s/mb?$//gi );
287 0 0       0 $_ *= 1073741824 if ( $_ =~ s/gb?$//gi );
288 0 0       0 $_ *= 1099511627776 if ( $_ =~ s/tb?$//gi );
289 0         0 return $_;
290 0   0     0 };
291             $config{'human'}{'procent'} ||= sub { #v1
292 0 0       0 return sprintf( '%' . ( $_[0] < 10 ? '.3f' : 'd' ), $_[0] ) . '%';
293 0   0     0 };
294             $config{'human'}{'time_period'} ||= sub { #v0
295 0         0 my ( $tim, $delim, $sign ) = @_;
296 0 0       0 $sign = '-', $tim = -$tim if $tim < 0;
297             #print("tpern[", $tim, ']'),
298 0 0 0     0 return '' if $tim == 0 or $tim > 1000000000;
299             #print("tperf[", $tim, ']'),
300 0 0       0 return ( $sign . human( 'float', $tim ) . $delim . "s" ) if $tim < 60;
301 0         0 $tim = $tim / 60;
302 0 0       0 return ( $sign . int($tim) . $delim . "m" ) if $tim < 60;
303 0         0 $tim = $tim / 60;
304 0 0       0 return ( $sign . int($tim) . $delim . "h" ) if $tim < 24;
305 0         0 $tim = $tim / 24;
306 0 0       0 return ( $sign . int($tim) . $delim . "d" ) if $tim <= 31;
307 0         0 $tim = $tim / 30.5;
308 0 0       0 return ( $sign . int($tim) . $delim . "M" ) if $tim < 12;
309 0         0 $tim = $tim / 12;
310 0         0 return ( $sign . int($tim) . $delim . "Y" );
311 0   0     0 };
312             $config{'human'}{'number'} ||= sub { #v0 #FIXIT
313             #return $_ = reverse( join( ' ', split( /(\d{3})/, reverse $_[0] ) ) );
314             #local $_ = reverse( join( ' ', split( /(\d{3})/, reverse $_[0] ) ) );
315             #return $_;
316             #return reverse( join( ' ', grep {length $_} split( /(\d{3})/, reverse $_[0] ) ) )
317 0         0 return local $_ = reverse join ' ', grep { length $_ } split /(\d{3})/, reverse $_[0];
  0         0  
318 0   0     0 };
319             #print 'dh1:',Dumper $config{'human'};
320             $config{'human'}{'string_long'} ||= sub {
321 0   0     0 my $maxlen = ( $_[1] or 20 );
322 0         0 html_chars( \$_[0] );
323 0 0       0 return $_[0] if length $_[0] <= $maxlen;
324 0         0 my $print = substr( $_[0], 0, $maxlen );
325 0         0 $print =~ s/[\xD0\xD1]$//;
326 0         0 $_[0] =~ s/\"/"/g;
327 0         0 return "$print...";
328 0   0     0 };
329             #print 'dh2:',Dumper $config{'human'};
330             },
331 1         10 1010,
332             );
333             }
334              
335             sub get_params_one(@) { # p=x,p=y,p=z => p=x,p1=y,p2=z ; p>=z => p=z, p_mode='>'; p => p; -p => -p=1;
336 0 0   0 0 0 local %_ = %{ ref $_[0] eq 'HASH' ? shift : {} };
  0         0  
337 0         0 for (@_) { # PERL RULEZ # SORRY # 8-) #
338             #tr/+/ /, s/%([a-f\d]{2})/pack 'C', hex $1/gei for my ( $k, $v ) = /^([^=]+=?)=(.+)$/ ? ( $1, $2 ) : ( /^([^=]*)=?$/, /^-/ );
339 0 0       0 tr/+/ /, s/%([a-f\d]{2})/pack 'H*', $1/gei for my ( $k, $v ) = /^([^=]+=?)=(.+)$/ ? ( $1, $2 ) : ( /^([^=]*)=?$/, /^-/ );
  0         0  
340 0 0       0 $_{"${1}_mode$2"} .= $3 if $k =~ s/^(.+?)(\d*)([=!><~@]+)$/$1$2/;
341 0 0       0 $k =~ s/(\d*)$/($1 < 100 ? $1 + 1 : last)/e while defined $_{$k};
  0         0  
342 0         0 $_{$k} = $v; #lc can be here
343             }
344 0 0       0 wantarray ? %_ : \%_;
345             }
346              
347             sub get_params(;$$) { #v7
348 0     0 0 0 my ( $string, $delim ) = @_;
349 0   0     0 $delim ||= '&';
350 0 0 0     0 read( STDIN, local $_ = '', $ENV{'CONTENT_LENGTH'} ) if !$string and $ENV{'CONTENT_LENGTH'};
351 0         0 local %_ = $string
352             ? get_params_one split $delim, $string
353             : (
354 0 0       0 get_params_one(@ARGV), map { get_params_one split $delim, $_ } split( /;\s*/, $ENV{'HTTP_COOKIE'} ),
355             $ENV{'QUERY_STRING'}, $_
356             );
357             #dmp (\%_);
358 0 0       0 wantarray ? %_ : \%_;
359             }
360              
361             sub get_params_utf8(;$$) {
362 0     0 0 0 local $_ = &get_params;
363 0         0 utf8::decode $_ for %$_;
364             #dmp (\%_);
365 0 0       0 wantarray ? %$_ : $_;
366             }
367              
368             sub use_try ($;@) {
369 0     0 0 0 ( my $path = ( my $module = shift ) . '.pm' ) =~ s{::}{/}g;
370 0 0 0     0 $INC{$path} or eval 'use ' . $module . ' qw(' . ( join ' ', @_ ) . ');1;' and $INC{$path};
371             }
372 0     0 0 0 sub is_array ($) { UNIVERSAL::isa( $_[0], 'ARRAY' ) }
373 0 0   0 0 0 sub is_array_size ($) { UNIVERSAL::isa( $_[0], 'ARRAY' ) and @{ $_[0] } }
  0         0  
374 0     0 0 0 sub is_hash ($) { UNIVERSAL::isa( $_[0], 'HASH' ) }
375 0 0   0 0 0 sub is_hash_size ($) { UNIVERSAL::isa( $_[0], 'HASH' ) and %{ $_[0] } }
  0         0  
376 0     0 0 0 sub is_code ($) { UNIVERSAL::isa( $_[0], 'CODE' ) }
377 0 0   0 0 0 sub code_run ($;@) { my $f = shift; return $f->(@_) if UNIVERSAL::isa( $f, 'CODE' ) }
  0         0  
378              
379             sub array (@) {
380 0 0 0 0 0 0 local @_ = map { is_array $_ ? @$_ : $_ } ( @_ == 1 and !defined $_[0] ) ? () : @_;
  0 0       0  
381             #local@_ = map { ref $_ eq 'ARRAY' ? @$_ : $_ } (@_ == 1 and !defined$_[0]) ? () : @_;
382 0 0       0 wantarray ? @_ : \@_;
383             }
384              
385             sub array_any (@) {
386 0 0   0 0 0 local @_ = map { is_array $_ ? @$_ : is_hash $_ ? sort keys %$_ : is_code $_ ? $_->() : $_ } @_;
  0 0       0  
    0          
387 0 0       0 wantarray ? @_ : \@_;
388             }
389              
390             sub in ($@) {
391 0     0 0 0 my $v = shift;
392 0         0 grep { $v eq $_ } &array_any;
  0         0  
393             }
394 0     0 0 0 sub hash_merge ($$) { $_[0]{$_} = $_[1]{$_} for keys %{ $_[1] }; }
  0         0  
395              
396             =todo
397             ------------jCZJhSDkEEg0Avf4h2hejC
398             Content-Disposition: form-data; name="n1"
399              
400             ertyeryery
401             ------------jCZJhSDkEEg0Avf4h2hejC
402             Content-Disposition: form-data; name="n2"
403              
404             ryertytry
405             ------------jCZJhSDkEEg0Avf4h2hejC
406             Content-Disposition: form-data; name="q"
407              
408             ertyeryery
409             ------------jCZJhSDkEEg0Avf4h2hejC--
410             =cut
411              
412             sub encode_url($;$) { #v5
413 0     0 0 0 my ( $str, $mask ) = @_;
414 0 0 0     0 return $str if defined $mask and !$mask;
415 0   0     0 $mask ||= '[^a-zA-Z0-9\-.()_!,]';
416 0         0 utf8::encode $str;
417             #return join( '+', map { s/$mask/'%'.sprintf('%02X', ord($&))/ge; $_ } split( /\x20/, $str ) );
418 0         0 return join '+', map { s/($mask)/sprintf'%%%02X',ord $1/ge; $_ } split /\x20/, $str;
  0         0  
  0         0  
  0         0  
419             }
420              
421             sub encode_url_link($;$) {
422             #v5
423 0     0 0 0 my ( $str, $mask ) = @_;
424 0 0 0     0 return $str if defined $mask and !$mask;
425 0 0       0 return $str if $str =~ /^(magnet|file):/i;
426             #fixed?
427             #return $str if $config{'client_ie'};
428             #printlog('Eb',Dumper $str);
429             # eval {utf8::downgrade($str, 'FAIL_OK')# if utf8::is_utf8($str);
430             #};
431             #utf8::encode($str);
432             #utf8::downgrade($str, 'FAIL_OK') if utf8::is_utf8($str);
433 0 0       0 utf8::is_utf8($str) ? utf8::encode($str) : utf8::downgrade( $str, 'FAIL_OK' );
434 0         0 local %_ = split_url($str);
435 0   0     0 $mask ||= '[^a-zA-Z0-9\-.()_\:@\/!,=]';
436             #utf8::encode($_{$_}),
437             #utf8::downgrade($_{$_}, 'FAIL_OK'),
438 0         0 $_{$_} =~ s/$mask/sprintf'%%%2X',ord$&/ge for keys %_;
  0         0  
439             #printlog('Ea',Dumper \%_);
440 0         0 return join_url( \%_ );
441             }
442              
443             sub decode_url($;$) { #v1
444 0     0 0 0 my ( $str, $noutf ) = @_;
445 0         0 $str =~ s/%([a-fA-F0-9]{2})/pack'C',hex$1/eg;
  0         0  
446 0 0       0 utf8::decode $str unless $noutf;
447 0         0 return $str;
448             }
449             {
450             my %fh;
451             my $savetime = 0;
452              
453             sub file_append(;$@) {
454 0     0 0 0 local $_ = shift;
455 0 0 0     0 for ( defined $_ ? $_ : keys %fh ) { close( $fh{$_} ), delete( $fh{$_} ) if $fh{$_} and !@_; }
  0 0       0  
456 0 0       0 return if !@_;
457 0 0       0 unless ( $fh{$_} ) { return unless open $fh{$_}, '>>', $_; return unless $fh{$_}; }
  0 0       0  
  0 0       0  
458 0         0 print { $fh{$_} } @_;
  0         0  
459 0 0       0 if ( time() > $savetime + 5 ) {
460 0         0 close( $fh{$_} ), delete( $fh{$_} ) for keys %fh;
461 0         0 $savetime = time();
462             }
463 0         0 return @_;
464             }
465 1     1   14 END { close( $fh{$_} ) for keys %fh; }
466             }
467              
468             sub file_rewrite(;$@) {
469 0     0 0 0 local $_ = shift;
470 0 0       0 return unless open my $fh, '>', $_;
471 0         0 print $fh @_;
472             }
473              
474             #all def fac =
475             #u u u 0
476             #u 1 u 1
477             #u 0 u 0
478             #u 1 0 0
479             #u * 1 1
480             #0 * * 0
481             #1 * * 1
482             sub printlog (@) { #v5
483             #print "[devlog][fac:$_[0]=".$config{ 'log_' . $_[0]}."][][log_screen=$config{'log_screen'} ]\n",Dumper (\%config );
484 0 0 0 0 0 0 return if defined $config{ 'log_' . $_[0] } and !$config{ 'log_' . $_[0] } and !$config{'log_all'};
      0        
485             #my $file = ( $config{'log_all'} or ( defined $config{ 'log_' . $_[0] } ? $config{ 'log_' . $_[0] } : '' ) );
486 0 0       0 my $file = ( (
    0          
487             defined $config{'log_all'}
488             ? $config{'log_all'}
489             : ( defined $config{ 'log_' . $_[0] } ? $config{ 'log_' . $_[0] } : $config{'log_default'} )
490             )
491             );
492 0         0 my $noscreen;
493 0         0 for ( 0 .. 1 ) {
494 0 0 0     0 $noscreen = 1 if $file =~ s/^[\-_]// or !$file;
495 0 0       0 $noscreen = 0 if $file =~ s/^[+\#]//;
496 0 0       0 $file = $config{'log_default'}, next if $file eq '1';
497 0         0 last;
498             }
499 0 0 0     0 my $html = !$file and ( $ENV{'SERVER_PORT'} or $config{'view'} eq 'html' or $config{'view'} =~ /http/i );
      0        
500 0 0       0 $file = undef if $file eq '1';
501 0         0 my $xml = $config{'view'} eq 'xml';
502 0   0     0 my $delim = $config{'log_delim'} || ' ';
503 0 0       0 my $string = join '', ( $xml ? '' : () ), (
504             ( ( $html || $xml ) and !$file ) ? ()
505             : (
506             $config{'log_datetime'} eq '0' ? () : human( 'date_time', ),
507             ( $config{'log_micro'} ? human('micro_time') : () ),
508             ( $config{'log_pid'} ? (" [$$]") : () ),
509             )
510             ), (
511             $config{'log_caller'}
512             ? (
513 0 0 0     0 ' [', join( ',', grep { $_ and !/^ps/ } ( map { ( caller($_) )[ 2 .. 3 ] } ( 0 .. $config{'log_caller'} - 1 ) ) ), ']'
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
514             )
515             : ()
516             ),
517             $delim, join( $delim, @_ ),
518             #(),
519             ( $html ? '' : () ), ( $xml ? ']]>' : () ), ("\n");
520             #print "[devlog][fac:$_[0]=".$config{ 'log_' . $_[0]}."][file=$file][log_screen=$config{'log_screen'} log_default=$config{'log_default'} noscreen=$noscreen html=$html xml=$xml]\n" ;
521 0         0 file_append( $config{'log_dir'} . $file, $string );
522 0 0       0 file_append() if !$config{'log_cache'}; #flush buffer
523             #if ( @_ and $file and open( LOG, '>>', $config{'log_dir'}.$file ) ) {
524             #print LOG@string;
525             #close(LOG);
526             #}
527             #local $_ = join '', @string;
528             #print @string if @_ and $config{'log_screen'} and !$noscreen and ;
529 0 0 0     0 print $string if @_ and $config{'log_screen'} and !$noscreen and ( !utf8::is_utf8($string) or utf8::valid($string) );
      0        
      0        
      0        
530             #print "not valid string\n"if utf8::is_utf8($string) and !utf8::valid($string);
531             #state(@_);
532 0 0       0 flush() if $config{'log_flush'};
533 0         0 return @_;
534             }
535              
536             sub file_read_ref ($) {
537 0 0   0 0 0 open my $f, '<', $_[0] or return;
538 0         0 local $/ = undef;
539 0         0 my $ret = <$f>;
540 0         0 close $f;
541 0         0 return \$ret;
542             }
543              
544             sub file_read ($) { #dont use, del
545 0 0   0 0 0 open my $f, '<', $_[0] or return;
546 0         0 local $/ = undef;
547 0         0 my $ret = <$f>;
548 0         0 close $f;
549 0         0 return $ret;
550             }
551              
552             sub openproc($;$) { #my ($proc) = @_;
553 0     0 0 0 printlog( 'dbg', 'run ext:', @_ );
554 0         0 my $handle;
555             #printlog('openok', $handle),
556 0 0       0 return $handle if $_[1] ? open( $handle, $_[0], $_[1] ) : open( $handle, $_[0] );
    0          
557             #return $handle if open( $handle, ((), @_));
558             #printlog('openfail');
559 0         0 return;
560             }
561              
562             sub printprog($;$$) { #v1
563 0     0 0 0 my ( $proc, $nologbody, $handler, $layer ) = @_;
564 0 0       0 return unless $proc;
565 0         0 my $ret;
566 0         0 my $tim = timer();
567 0         0 printlog( 'dbg', "Starting [$proc]:" );
568 0 0 0     0 system($proc), return if $nologbody and !$handler;
569 0 0       0 my $h = openproc( '-|' . $layer, "$proc $config{'stderr_redirect'}" ) or return 1;
570 0         0 while ( defined( local $_ = <$h> ) ) {
571 0         0 s/\s*[\x0A\x0D]*$//;
572 0 0       0 next unless length $_;
573 0 0       0 printlog( 'dbg', $_ ) unless $nologbody;
574 0 0 0     0 last if ref $handler eq 'CODE' and $ret = $handler->($_);
575             }
576 0         0 close($h);
577 0         0 printlog( 'dbg', 'prog done per', human( 'time_period', $tim->() ) );
578 0         0 return $ret;
579             }
580              
581             sub start(;$@) {
582 0     0 0 0 my ($cmd) = shift;
583 0 0       0 if ($cmd) {
584             #$processor{'out'}{'array'}->();
585 0 0 0     0 if ( $^O =~ /^(?:(ms)?(dos|win(32|nt)?))/i and $^O !~ /^cygwin/i ) {
586 0   0     0 $config{'starter'} ||= 'cmd /c';
587 0   0     0 $config{'spawn_prefix'} ||= 'start /min /low';
588             } else {
589 0   0     0 $config{'spawn_postfix'} ||= '&';
590             }
591             #"$config{'starter'} $config{'spawn_prefix'} $config{'perl'} $config{'root_path'}crawler.pl $force $start $config{'spawn_postfix'}";
592 0         0 my $com = join ' ', $config{'starter'}, $config{'spawn_prefix'}, $cmd, @_, $config{'spawn_postfix'};
593 0         0 printlog( 'dbg', "starting with $cmd:", $com );
594             #printlog( 'dbg', $com );
595 0         0 return system($com);
596             }
597             }
598              
599             sub startme(;$@) {
600 0     0 0 0 my ($start) = shift;
601 0 0       0 if ($start) {
602              
603             =old
604             my ($start) = shift;
605             if ($start) {
606             #$processor{'out'}{'array'}->();
607             if ( $^O =~ /^(?:(ms)?(dos|win(32|nt)?))/i and $^O !~ /^cygwin/i ) {
608             $config{'starter'} ||= 'cmd /c';
609             $config{'spawn_prefix'} ||= 'start /min /low';
610             } else {
611             $config{'spawn_postfix'} ||= '&';
612             }
613             my $com =
614             #"$config{'starter'} $config{'spawn_prefix'} $config{'perl'} $config{'root_path'}crawler.pl $force $start $config{'spawn_postfix'}";
615             join ' ', $config{'starter'}, $config{'spawn_prefix'}, $^X, $work{'$0'} || $0, $start, @_, $config{'spawn_postfix'};
616             printlog( 'dbg', "starting with $start:", $com );
617             #printlog( 'dbg', $com );
618             system($com);
619             }
620             =cut
621              
622 0   0     0 return start( $^X, $work{'$0'} || $0, $start, @_ );
623             }
624             }
625             our $indent = 1;
626             our $join = ', ';
627             our $prefix = 'dmp'; # 'dmp '
628             our $caller_shift = 0;
629              
630             sub dmp (@) {
631 0     0 0 0 my $fname = (caller(1 + $caller_shift))[3];
632 0 0       0 $fname = (caller(0 + $caller_shift))[0] if $fname eq '(eval)';
633 0 0       0 printlog $prefix, $fname, ':', ( caller(0 + $caller_shift) )[2], ' ',
    0          
634             join $join,
635 0 0       0 map { ref $_ ? Data::Dumper->new( [$_] )->Indent($indent)->Pair( $indent ? ' => ' : '=>' )->Terse(1)->Sortkeys(1)->Dump() : "'$_'" } @_ ? @_ : $_;
636 0 0       0 wantarray ? @_ : $_[0];
637             }
638              
639             # trace; # trace 5 calls
640             # trace 10; # trace 10 calls
641             # trace 'bzzzz', [42]; # trace 5 and dumpit
642             sub trace (;@) {
643 0     0 0 0 local $caller_shift = 1;
644 0 0       0 for (1..($_[0] =~ /^\d+$/ ? shift : 10)) {
645 0 0 0     0 dmp $_, ((caller $_ + 1 )[3]||(caller $_ )[0]) . ':' . ((caller $_ )[2] || last), ($_ > 1 ? () : @_),;
      0        
646             }
647             }
648              
649             sub state {
650 0   0 0 0 0 $work{'$0'} ||= $0;
651 0         0 $0 = $config{'state_prefix'} . join ' ', @_;
652             }
653              
654             sub hconfig($;@) {
655 0     0 0 0 my $par = shift;
656             #printlog('hc0', $par,@_);
657             #printlog('hc1', $_, $par),
658 0         0 return $config{'fine'}{$_}{$par} for grep { defined( $config{'fine'}{$_}{$par} ) } @_;
  0         0  
659             #printlog('hc2', $par),
660 0         0 return $config{$par};
661             }
662              
663             sub html_chars($) {
664             #local $_ = $_[0];
665 0     0 0 0 local $_; # = $_[0];
666 0 0       0 $_ = \$_[0] unless ref $_[0];
667 0   0     0 $_ ||= $_[0];
668             #print "REf:",ref $_, $$_;
669 0         0 $$_ =~ s/\&/\&\;/g;
670 0         0 $$_ =~ s/\
671 0         0 $$_ =~ s/\>/\>\;/g;
672 0         0 $$_ =~ s/"/\"\;/g; #"
673 0         0 return $$_;
674             }
675              
676             sub human($;@) {
677             #print "HUM", @_;
678 0     0 0 0 my $via = shift;
679             #print "CO[$config{'human'}{$via}]", Dumper $config{'human'};
680             #my $code = $config{'human'}{$via} if ref $config{'human'}{$via} eq 'CODE';
681             #$code ||= $config{'human'}{$via} if ref $config{'human'}{$via} eq 'CODE';
682             #return $code->(@_) if $code;
683 0 0       0 return $config{'human'}{$via}->(@_) if ref $config{'human'}{$via} eq 'CODE';
684 0         0 return @_;
685             }
686              
687             sub func_cache($;@) {
688 0     0 0 0 my ($func) = shift;
689 0         0 my $save = $func . join( ':', @_ );
690 0 0       0 unless ( $static{'func_cache'}{$save} ) { @{ $static{'func_cache'}{$save} } = $func->(@_); }
  0         0  
  0         0  
691             else { }
692 0 0       0 return wantarray ? @{ $static{'func_cache'}{$save} } : $static{'func_cache'}{$save}[0];
  0         0  
693             }
694              
695             sub name_to_ip_noc($) {
696 0     0 0 0 my ($name) = @_;
697 0 0       0 unless ( $name =~ /^\d+\.\d+\.\d+\.\d+$/ ) {
698 0         0 local $_ = ( gethostbyname($name) )[4];
699 0 0       0 return ( $name, 1 ) unless length($_) == 4;
700 0         0 $name = inet_ntoa($_);
701             }
702 0         0 return $name;
703             }
704              
705             sub ip_to_name_noc($) { #v1
706 0     0 0 0 local $_;
707 0 0       0 return $_[0] unless $_ = ( gethostbyname( $_[0] ) )[4];
708 0         0 return inet_ntoa($_);
709             }
710 0     0 0 0 sub normalize_ip($) { return func_cache( \&normalize_ip_noc, @_ ); }
711 0     0 0 0 sub ip_to_name($) { return func_cache( \&ip_to_name_noc, @_ ); }
712 0     0 0 0 sub name_to_ip($) { return func_cache( \&name_to_ip_noc, @_ ); }
713              
714             sub normalize_ip_noc($) { #v2
715 0     0 0 0 my ($host) = @_;
716             #my ($err);
717 0         0 my ( $ip, $err ) = name_to_ip($host);
718             #printlog "ip[$ip]";
719 0 0 0     0 return undef if $ip =~ /^(?:0|127)\./ and !$host =~ /^(?:0|127)\./;
720 0 0 0     0 return lc $host
    0          
721             if $config{'norm_skip_host'}
722             and ( (
723             ref $config{'norm_skip_host'} eq 'Regexp' ? $host =~ $config{'norm_skip_host'} : $host =~ /$config{'norm_skip_host'}/i
724             )
725             );
726 0 0       0 return $ip if $err;
727 0         0 my ($tmp);
728 0 0       0 return $ip unless $tmp = inet_aton($ip);
729 0 0       0 return $ip unless $host = ( gethostbyaddr( $tmp, AF_INET ) )[0];
730 0 0       0 for my $repl ( @{ $config{'ip_normalize_pre'} || [] } ) {
  0         0  
731 0 0       0 last if $host =~ /^$repl\./;
732 0         0 my $thost = $host;
733 0         0 $thost =~ s/^[^.]+/$repl/;
734 0         0 my $pip = inet_aton($ip);
735 0 0       0 for $thost ( ( $host =~ /\..+\./ ? ($thost) : () ), $repl . '.' . $host ) {
736 0 0       0 next unless @_ = grep $_, ( ( gethostbyname($thost) )[ 4 .. 14 ] );
737 0         0 return $thost for ( grep $_ eq $pip, @_ );
738             }
739             }
740 0 0       0 return $ip unless @_ = ( gethostbyname($host) )[4];
741 0         0 return $host for grep $_ eq $ip, map $_ = inet_ntoa($_), @_;
742 0         0 return $ip;
743             }
744              
745             sub counter($;$) {
746 0     0 0 0 my $start = $_[0];
747             return sub {
748 0 0   0   0 $start = $_[1] if $_[1];
749 0 0       0 return ( $_[0] - $start ) >= 0 ? ( $_[0] - $start ) : $start;
750 0         0 };
751             }
752              
753             sub timer(;$) {
754 0   0 0 0 0 my ( $start, $ret ) = ( $_[0] || time() );
755             return sub {
756 0     0   0 $ret = time() - $start;
757 0 0 0     0 $start = ( $_[0] or time() ) if defined( $_[0] );
758 0         0 return $ret;
759 0         0 };
760             }
761              
762             sub join_url($) { #v2
763             return
764 0 0 0 0 0 0 ( $_[0]->{'prot'} ? $_[0]->{'prot'} . '://' : '' )
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
765             . ( $_[0]->{'user'} ? $_[0]->{'user'} . ( $_[0]->{'pass'} ? ':' . $_[0]->{'pass'} : '' ) . '@' : '' )
766             . $_[0]->{'host'}
767             . ( (
768             $_[0]->{'port'}
769             and ( !$static{'port2prot'}{ $_[0]->{'port'} } or ( $static{'port2prot'}{ $_[0]->{'port'} } ne $_[0]->{'prot'} ) )
770             )
771             ? ':'
772             . $_[0]->{'port'}
773             : ''
774             )
775             . ( $_[0]->{'dcuser'} ? '/' . $_[0]->{'dcuser'} : '' )
776             . ( ( !$_[0]->{'path'} or $_[0]->{'path'} =~ /^\// ) ? '' : '/' )
777             . $_[0]->{'path'}
778             . ( ( ( !$_[0]->{'path'} and ( !$_[0]->{'host'} or !( $_[0]->{'name'} or $_[0]->{'ext'} ) ) ) or $_[0]->{'path'} =~ /\/$/ )
779             ? ''
780             : '/' )
781             . $_[0]->{'name'}
782             . ( $_[0]->{'ext'} ? '.' . $_[0]->{'ext'} : '' )
783             . ( $_[0]->{'param'} ? '?' . $_[0]->{'param'} : '' )
784             . ( $_[0]->{'pos'} ? '#' . $_[0]->{'pos'} : '' );
785             }
786             #[[prot://][user[:pass]@]host[:port][/dcuser][/[path]][/[name[.ext]]][?param][#pos]
787             sub split_url($;$) { #v3
788 0   0 0 0 0 my $table = ( $_[1] or $config{'sql_tresource'} );
789 0         0 local %_ = ();
790 0         0 ( $_{'prot'}, $_{'host'} ) = $_[0] =~ m|^\s*(?:(\w+)\://)?(.*)$|;
791 0         0 ( $_{'host'}, $_{'path'} ) = $_{'host'} =~ m|^([^/]*)(/.*)?$|;
792 0         0 ( $_{'user'}, $_{'host'} ) = $_{'host'} =~ m|^(?:(.+)@)?(.*)|;
793 0         0 ( $_{'user'}, $_{'pass'} ) = $_{'user'} =~ m|^([^/:@]+):?(.*)|;
794 0         0 ( $_{'host'}, $_{'port'} ) = $_{'host'} =~ m|([^/:@]+)\:?(\d*)$|;
795 0         0 $_{'path'} =~ s|([^/]*)$||;
796 0         0 ( $_{'name'} ) = $1;
797 0 0       0 $_{'path'} =~ s|/*$|| if $_{'path'} ne '/';
798 0 0 0     0 $_{'path'} ||= '/' if $_{'name'} or $_{'ext'};
      0        
799             #( $_{'pos'} ) = ( $_{'name'} =~ s/#(.+)$// ? ($1) : (undef) );
800 0 0       0 ( $_{'pos'} ) = $1 if $_{'name'} =~ s/#(.+)$//;
801 0 0       0 ( $_{'param'} ) = $1 if $_{'name'} =~ s/\?(.+)$//;
802 0 0       0 ( $_{'ext'} ) = ( $_{'name'} =~ s/\.([^\.]+)$// ? ($1) : ('') );
803 0 0 0     0 delete $_{'port'}
      0        
804             unless ( $_{'port'} and ( !$static{'port2prot'}{ $_{'port'} } or ( $static{'port2prot'}{ $_{'port'} } ne $_{'prot'} ) ) );
805 0 0       0 if ( $_{'prot'} eq 'dchub' ) {
806             #printlog ('split_url', 1, Dumper \%_);
807 0         0 my $dcuser;
808 0 0 0     0 ( $_{'path'} =~ s|^/([^/]+)|| and $dcuser = $1 )
    0 0        
      0        
      0        
      0        
809             or ($_{'path'} =~ s|^/?$||
810             and $_{'name'} =~ s|(.+)||
811             and $dcuser = $1
812             and $_{'ext'} =~ s|(.*)||
813             and $dcuser .= ( $1 ? ".$1" : '' ) );
814             #printlog('dcu', $dcuser);
815             #printlog ('split_url', 2, join ':', %_);
816 0 0       0 if ( %{ $config{'sql'}{'table'}{$table}{'dcuser'} or {} } ) { $_{'dcuser'} = $dcuser; }
  0 0       0  
  0         0  
817             else {
818 0         0 ( $_{'host'} = join_url( { 'host' => $_{'host'}, 'port' => $_{'port'}, 'path' => $dcuser, } ) ) =~ s|/$||;
819 0         0 delete $_{'port'};
820             #printlog ('split_url', 3, join ':', %_);
821             }
822             }
823 0         0 delete $_{$_} for grep !length $_{$_}, keys %_;
824             #printlog ('split_url', 'R', join ':', %_);
825 0 0       0 return wantarray ? %_ : \%_;
826             }
827              
828             sub full_host($;$) {
829 0   0 0 0 0 my $table = ( $_[1] or $config{'sql_tresource'} );
830 0 0       0 return join_url( {
831 0 0       0 ( %{ $config{'sql'}{'table'}{$table}{'user'} or {} } ? () : ( 'user' => $_[0]->{'user'} ) ),
832             ( %{ $config{'sql'}{'table'}{$table}{'pass'} or {} } ? () : ( 'pass' => $_[0]->{'pass'} ) ),
833             'host' => $_[0]->{'host'}, ( ( (
834             $_[0]->{'port'}
835             and ( !$static{'port2prot'}{ $_[0]->{'port'} } or ( $static{'port2prot'}{ $_[0]->{'port'} } ne $_[0]->{'prot'} ) )
836             )
837 0 0       0 and ( !%{ $config{'sql'}{'table'}{$table}{'port'} or {} } or ( $_[0]->{'prot'} eq 'dchub' ) )
838             ) ? ( 'port' => $_[0]->{'port'} ) : ()
839             ),
840 0 0 0     0 ( %{ $config{'sql'}{'table'}{$table}{'dcuser'} or {} } ? () : ( 'dcuser' => $_[0]->{'dcuser'} ) ),
    0          
    0          
    0          
841             }
842             );
843             }
844 0   0 0 0 0 sub cp_normalize($) { return $config{'trans_name'}{ lc $_[0] } || lc $_[0]; }
845              
846             sub encode_safe ($$) {
847 0     0 0 0 my ( $cto, $string ) = @_;
848             #printlog('es', $string);
849 0         0 $cto = cp_normalize($cto);
850 0 0 0     0 return $string if !$cto or $cto eq 'utf-8';
851             #return
852             #utf8::downgrade($string),
853             #Encode::_utf8_off($string);
854             #printlog('ensafeB',$cto, Dumper $string, utf8::is_utf8 $string);
855             #local $_ = Encode::encode $cto, Encode::decode 'utf-8', $string;
856 0         0 local $_ = Encode::encode $cto, $string, Encode::FB_WARN;
857             # Encode::_utf8_off($_);
858             #utf8::downgrade($_),
859             #utf8::decode($_),
860             #printlog('ensafeA',$cto, Dumper $_, utf8::is_utf8 $_);
861             #printlog('esR', $_);
862 0         0 return $_;
863             }
864              
865             sub cp_trans($$$) { #v1
866 0     0 0 0 my ( $cfrom, $cto, $string ) = @_;
867 0         0 $cfrom = cp_normalize($cfrom);
868 0         0 $cto = cp_normalize($cto);
869             #printlog('dev', 'cp_trans:', $cfrom, $cto, $string);
870 0 0 0     0 return $string if $cto eq $cfrom or !length($string) or !$cfrom or !$cto;
      0        
      0        
871 0 0       0 print( 'dev', 'cp_trans:', join ':', $cfrom, $cto, $string ) if $config{debug};
872             #local $_ = "$cfrom -> $cto";
873             #caller_trace();
874             #return scalar cp_trans_count(@_); # unless $config{'fast_cp_trans'};
875             #use Encode;
876             #$string = encode($cto, decode($cfrom, $string));
877             #return eval {Encode::encode $cto, Encode::decode $cfrom, $string} or $string;
878 0         0 Encode::from_to $string, $cfrom, $cto, Encode::FB_WARN;
879 0         0 return $string;
880             }
881              
882             sub cp_trans_count($$$) { #v1
883 0     0 0 0 my ( $cfrom, $cto, $string ) = @_;
884 0         0 $cfrom = cp_normalize($cfrom);
885 0         0 $cto = cp_normalize($cto);
886             #printlog('dev', 'cp_trans:', $cfrom, $cto, $string);
887 0 0 0     0 return $string if $cto eq $cfrom or !length($string) or !$cfrom or !$cto;
      0        
      0        
888             #print('dev', 'cp_trans:', join ':',$cfrom, $cto, $string);
889             #local $_ = "$cfrom -> $cto";
890             #caller_trace();
891             #use Encode;
892             #$string = encode($cto, decode($cfrom, $string));
893             #return encode($cto, decode($cfrom, $string));
894 0 0 0     0 return utf_trans( $cto, $string ) if $cfrom eq 'utf-8' and $config{'trans'}{$cto};
895 0 0 0     0 return to_utf_trans( $cfrom, $string ) if $cto eq 'utf-8' and $config{'trans'}{$cfrom};
896 0         0 my $cnt;
897 0 0 0     0 if ( $config{'trans'}{$cfrom} and $config{'trans'}{$cto} ) {
898 0         0 ( $cfrom, $cto ) = \( $config{'trans'}{$cfrom}, $config{'trans'}{$cto} );
899 0         0 eval "\$cnt = \$string =~ tr/$$cfrom/$$cto/";
900             }
901             #printlog('dev', "cp_trans($_):", $string), caller_trace() if $cnt;
902 0 0       0 return wantarray ? ( $string, $cnt ) : $string;
903             }
904              
905             sub utf_trans($$) {
906 0     0 0 0 my ( $cto, $string ) = @_;
907 0   0     0 $cto ||= $config{'cp_db'};
908 0         0 $cto = cp_normalize($cto);
909 0 0       0 return if $cto eq 'utf-8';
910 0         0 my ( $cnt, $cnt2 );
911 0         0 $cnt += $string =~ s/\xD0\x81/\xF0/g; # e
912 0         0 $cnt += $string =~ s/\xD1\x91/\xF1/g; # E
913 0         0 $cnt += $string =~ s/\xD0\x84/\xF4/g; # ukr beg
914 0         0 $cnt += $string =~ s/\xD1\x94/\xF5/g;
915 0         0 $cnt += $string =~ s/\xD0\x86/\xF6/g;
916 0         0 $cnt += $string =~ s/\xD1\x96/\xF7/g;
917 0         0 $cnt += $string =~ s/\xD0\x87/\xF8/g;
918 0         0 $cnt += $string =~ s/\xD1\x97/\xF9/g; # ukr end
919 0         0 $cnt += $string =~ s/\xE2\x80\x94/-/g; # -
920 0         0 $cnt += $string =~ s/\xC2\xAB/"/g; # «
921 0         0 $cnt += $string =~ s/\xC2\xBB/"/g; # »
922 0         0 $cnt += $string =~ s/\xD1\x98/j/g; #
923 0         0 $cnt += $string =~ s/\xD0\xB9/\xA9/g; # й
924             #$cnt += $string =~ s/\xD0\xA9/\xC9/g; # Щ
925 0         0 $cnt += $string =~ s/\xD0([\x90-\xBF])/chr(ord($1)-16)/eg;
  0         0  
926 0         0 $cnt += $string =~ s/\xD1([\x80-\x8F])/chr(ord($1)+96)/eg;
  0         0  
927 0         0 ( $string, $cnt2 ) = cp_trans_count( 'cp866', $cto, $string );
928 0         0 $cnt += $cnt2;
929 0         0 $cnt += $string =~ s/\x21\x16/\xB9/g; # й
930 0 0       0 return wantarray ? ( $string, $cnt ) : $string;
931             }
932              
933             sub to_utf_trans($$) {
934 0     0 0 0 my ( $cfrom, $string ) = @_;
935 0   0     0 $cfrom ||= $config{'cp_db'};
936 0         0 $cfrom = cp_normalize($cfrom);
937 0 0       0 return if $cfrom eq 'utf-8';
938 0         0 my $cnt;
939             #$cnt += $string =~ s/\xE9/\xD0\xB9/g; # й
940 0         0 $cnt += $string =~ s/\xAB/"/g; # <
941 0         0 $cnt += $string =~ s/\xBB/"/g; # <
942             #print "\ndos0[$string]\n";
943 0         0 ( $string, $cnt ) = cp_trans_count( $cfrom, 'cp866', $string );
944             #print "\ndos1[$string]\n";
945 0         0 $cnt += $string =~ s/([\x80-\x88\x8A-\xA8\xAA-\xAF])/"\xD0".chr(ord($1)+16)/eg;
  0         0  
946 0         0 $cnt += $string =~ s/([\xE0-\xE8\xEA-\xEF])/"\xD1".chr(ord($1)-96)/eg;
  0         0  
947             #print "\ndos2[$string]\n";
948 0         0 $cnt += $string =~ s/\xF0/\xD0\x81/g; # e
949 0         0 $cnt += $string =~ s/\xF1/\xD1\x91/g; # E
950 0         0 $cnt += $string =~ s/\xF4/\xD0\x84/g; # ukr beg
951 0         0 $cnt += $string =~ s/\xF5/\xD1\x94/g;
952 0         0 $cnt += $string =~ s/\xF6/\xD0\x86/g;
953 0         0 $cnt += $string =~ s/\xF7/\xD1\x96/g;
954 0         0 $cnt += $string =~ s/\xF8/\xD0\x87/g;
955 0         0 $cnt += $string =~ s/\xF9/\xD1\x97/g; # ukr end
956             #=c
957 0         0 $cnt += $string =~ s/(?
958 0         0 $cnt += $string =~ s/(?
959 0         0 $cnt += $string =~ s/(?
960 0         0 $cnt += $string =~ s/(?
961 0         0 $cnt += $string =~ s/(?
962             #=cut
963             #$cnt += $string =~ s/\xAB/"/g; # <
964             #$cnt += $string =~ s/\xBB/"/g; # >
965 0 0       0 return wantarray ? ( $string, $cnt ) : $string;
966             }
967              
968             sub cp_trans_hash($$$) {
969 0     0 0 0 my ( $from, $to, $hash ) = @_;
970             #printlog('dev', 'cp_trans_hash:', $from, $to, Dumper $hash);
971 0 0       0 return $hash if $from eq $to;
972 0         0 $hash->{$_} = cp_trans( $from, $to, $hash->{$_} ) for grep { !ref $hash->{$_} }keys %$hash;
  0         0  
973 0 0       0 return wantarray ? %$hash : $hash;
974             }
975              
976             sub max_hash_el($$;$) {
977 0     0 0 0 my ( $hash, $max, $ret ) = @_;
978 0 0       0 $hash->{$_} >= $max ? ( $max = $hash->{$_}, $ret = $_ ) : () for grep $_, keys %$hash;
979 0         0 return $ret;
980             }
981              
982             sub cp_dump($) {
983 0     0 0 0 my ($data) = @_;
984 0         0 printlog( 'devcp', "$_ = $data->{'stat'}{$_}" ) for keys %{ $data->{'stat'} };
  0         0  
985             }
986              
987             sub detectcp($) {
988 0     0 0 0 my ($string) = @_;
989 0         0 my ( $detectedcp, $t );
990 0         0 my %cpstat;
991 0         0 for my $cp ( keys %{ $config{'trans_detect'} } ) {
  0         0  
992 0 0       0 ( length($$string) > $config{'cp_detect_length'} ? substr( $$string, 0, $config{'cp_detect_length'} ) : $$string ) =~
993 0         0 s/([$config{'trans_detect'}{$cp}])/++$cpstat{$cp},$1/eg;
994             #printlog('testcp:', $cp, $cpstat{$cp});
995             #$$string
996             }
997 0         0 $detectedcp = max_hash_el( \%cpstat, $config{'cp_detect_letters'} );
998 0 0       0 return wantarray ? ( $detectedcp, \%cpstat ) : $detectedcp;
999             }
1000              
1001             sub cp_detect_trans(\$;$$$$$) {
1002 0     0 0 0 my ( $string, $data, $cp_to, $cp_default, $prot, $host ) = @_;
1003 0   0     0 $data ||= {};
1004 0   0     0 $cp_to = cp_normalize( $cp_to || hconfig( 'cp_db', $host ) ) || 'utf-8';
1005              
1006             =bat
1007             if (use_try('Encode::Detect')) {
1008             eval {$$string = decode("Detect", $$string);
1009             return;
1010             };
1011             } elsif (use_try('Encode::Guess')) {
1012             my $decoder; eval {$decoder = Encode::Guess::guess_encoding($$string, Encode->encodings(":all"));};
1013             printlog(Dumper $decoder);
1014             if ($decoder) {
1015             $$string = $decoder->decode($$string);
1016             return;
1017             }
1018             }
1019             =cut
1020              
1021 0 0 0     0 return 'utf-8' if $cp_to eq 'utf-8' and utf8::decode($$string);
1022 0   0     0 $cp_default = cp_normalize( $cp_default || hconfig( 'cp_res', $host, $prot ) );
1023 0         0 my $cnt;
1024 0 0 0     0 if ( !hconfig( 'no_cp_detect', $host ) and ( ++$data->{'tries'} < 20 or !$data->{'cp'} ) ) {
      0        
1025 0         0 ++$data->{'stat'}{ detectcp($string) };
1026 0         0 $data->{'cp'} = max_hash_el( $data->{'stat'}, hconfig( 'cp_detect_strings', $host ) );
1027             #printlog( 'dbg', 'charset detected:', $data->{'cp'}, ' dbg: ', %{ $data->{'stat'} }, Dumper($data), Dumper(detectcp($string)),' [', $$string, ']', "def:$cp_default",);# if $data->{'cp'} and $data->{'cp'} ne $cp_default;
1028             }
1029             #printlog( 'dbg', "encto: from=$data->{'cp'} to=$cp_to, def=$cp_default");
1030 0 0       0 if (
1031             $data->{'cp'} #and ($data->{'cp'} ne $cp_to
1032             #or $data->{'cp'} eq 'utf-8')
1033             )
1034             {
1035             #( $$string, $cnt ) = cp_trans_count( $data->{'cp'}, $cp_to, $$string );
1036 0 0       0 return $data->{'cp'} if $data->{'cp'} eq $cp_to;
1037 0         0 $$string = Encode::decode $data->{'cp'}, $$string, Encode::FB_WARN;
1038             #return $cnt ? $data->{'cp'} : undef;
1039             #printlog( 'dbg', "charset decoded [$data->{'cp'}]:", $$string);
1040 0         0 return $data->{'cp'};
1041             }
1042 0 0 0     0 if ( $cp_default and $cp_default ne $cp_to ) {
1043             #( $$string, $cnt ) = cp_trans_count( $cp_default, $cp_to, $$string );
1044             #return $cnt ? $cp_default : undef;
1045 0         0 $$string = Encode::decode $cp_default, $$string, Encode::FB_WARN;
1046             #printlog( 'dbg', "charset decoded def [$cp_default]:", $$string);
1047 0         0 return $cp_default;
1048             }
1049 0         0 return undef;
1050             }
1051              
1052             sub cp_up($;$) { #v1
1053 0   0 0 0 0 my ( $string, $cp ) = ( shift, cp_normalize( shift || 'cp1251' ) );
1054 0 0 0     0 eval "\$string =~ tr/$config{'trans_lo'}{$cp}/$config{'trans_up'}{$cp}/"
1055             if ( $config{'trans_up'}{$cp} and $config{'trans_lo'}{$cp} );
1056 0         0 return $string;
1057             }
1058              
1059             sub cp_lo($;$) { #v1
1060 0   0 0 0 0 my ( $string, $cp ) = ( shift, cp_normalize( shift || 'cp1251' ) );
1061 0 0 0     0 eval "\$string =~ tr/$config{'trans_up'}{$cp}/$config{'trans_lo'}{$cp}/"
1062             if ( $config{'trans_up'}{$cp} and $config{'trans_lo'}{$cp} );
1063 0         0 return $string;
1064             }
1065              
1066             sub unref ($;@) {
1067 0     0 0 0 local $_ = shift;
1068 0 0       0 return unless length $_;
1069 0         0 $_ = $$_ while ref $_ eq 'REF';
1070 0 0       0 return $_->(@_) if ref $_ eq 'CODE';
1071 0 0       0 @_ = () if ref $_[0];
1072 0 0       0 return join $,, ( $$_, @_ ) if ref $_ eq 'SCALAR';
1073 0         0 return join $,, $_, @_;
1074             }
1075              
1076             sub lang($;$$$) {
1077 0     0 0 0 my ( $key, $lang ) = shift, shift;
1078             #print "CP[$config{'cp_config'},$work{'codepage'}]" if $key eq 'search';
1079 0 0 0     0 local $_ = (
    0 0        
1080             defined $config{'lng'}{ $lang ||= ( $work{'lang'} || $config{'lang'} ) }{$key} ? $config{'lng'}{$lang}{$key}
1081             : defined $config{'lng'}{''}{$key} ? $config{'lng'}{''}{$key}
1082             : $key );
1083             #return unref $_ if ref $_;
1084             return
1085             #"[".(%config)."]".
1086 0         0 shift() . # "CP[$config{'cp_config'},$work{'codepage'}]".
1087             unref($_) .
1088             #cp_trans(
1089             #( $config{'cp_config'} || $config{'cp_perl'} ),
1090             #$work{'codepage'},
1091             #) .
1092             shift();
1093             }
1094              
1095             sub printu (@) {
1096 0     0 0 0 for (@_) {
1097 0 0       0 print($_), next unless utf8::is_utf8($_);
1098 0         0 my $s = $_;
1099 0         0 utf8::encode($s);
1100 0         0 print($s);
1101             }
1102             }
1103              
1104             sub json_encode($) {
1105 0 0   0 0 0 if ( use_try 'JSON::XS' ) { return \( JSON::XS->new->encode(@_) ) }
  0         0  
1106 0 0       0 if ( use_try('JSON') ) { return \( JSON->new->encode(@_) ); }
  0         0  
1107             {
1108 0         0 local *Data::Dumper::qquote = sub {
1109 0     0   0 $_[0] =~ s/\\/\\\\/g, s/"/\\"/g for $_[0];
1110 0         0 return ( '"' . $_[0] . '"' );
1111 0         0 };
1112 0         0 return \( Data::Dumper->new( \@_ )->Pair(':')->Terse(1)->Indent(0)->Useqq(1)->Useperl(1)->Dump() );
1113             }
1114             }
1115              
1116             sub min (@) {
1117 0 0   0 0 0 ( sort { $a <=> $b || $a cmp $b } @_ )[0];
  0         0  
1118             }
1119              
1120             sub max (@) {
1121 0 0   0 0 0 ( sort { $b <=> $a || $b cmp $a } @_ )[0];
  0         0  
1122             }
1123              
1124             sub alarmed {
1125 0     0 0 0 my ( $timeout, $proc, @proc_param ) = @_;
1126 0         0 my $ret;
1127 0         0 eval {
1128 0     0   0 local $SIG{ALRM} = sub { die "alarm\n" }
1129 0 0       0 if $timeout; # NB: \n required
1130 0 0       0 alarm $timeout if $timeout;
1131 0 0       0 $ret = $proc->(@proc_param) if ref $proc eq 'CODE';
1132 0 0       0 alarm 0 if $timeout;
1133             };
1134 0 0 0     0 if ( $timeout and $@ ) {
1135 0 0       0 printlog( 'err', 'Sorry, unknown error (',
1136             $@, ') runs:', ' [', join( ',', grep $_, map ( ( caller($_) )[2], ( 0 .. 15 ) ) ), ']' ),
1137             sleeper( 3600, 'alarmed' ), return
1138             unless $@ eq "alarm\n"; # propagate unexpected errors
1139 0         0 printlog( 'err', 'Sorry, timeout (', $timeout, ')' );
1140             } else {
1141 0         0 sleeper( undef, 'alarmed' );
1142             } # else { print "no timeout
"; }
1143 0         0 return $ret;
1144             }
1145              
1146             sub mkdir_rec(;$$) {
1147 0   0 0 0 0 local $_ = shift // $_;
1148 0 0       0 $_ .= '/' unless m{/$};
1149 0         0 my @ret;
1150 0 0       0 while (m{/}g) { ( push @ret, $` ), ( @_ ? mkdir $`, $_[0] : mkdir $` ) if length $` }
  0 0       0  
1151 0         0 @ret;
1152             }
1153              
1154             sub check_int($;$$$) {
1155 0     0 0 0 my ( $int, $min, $max, $def ) = @_;
1156             #printlog('dev', 'int', ( "int=$int,min=$min,max=$max,def=$def" ));
1157 0 0       0 $def = 0 unless defined $def;
1158 0 0 0     0 return $def unless ( defined($int) and length($int) );
1159             #printlog('dev', "int0[$int]", defined $int, length($int));
1160 0         0 $int =~ s/\s+//g;
1161 0         0 $int = int($int);
1162             #printlog('dev', 'int1',$int);
1163 0 0       0 return $def unless $int =~ /^-?\d+$/;
1164             #printlog('dev', 'int2',$int, $min);
1165 0 0 0     0 return $min if defined $min and $int < $min;
1166             #printlog('dev', 'int3',$int, $max);
1167 0 0 0     0 return $max if defined $max and $int > $max;
1168             #printlog('dev', 'int4',$int);
1169 0         0 return $int;
1170             }
1171              
1172             =old trash
1173             {
1174             my $current_name;
1175              
1176             sub open_out_file {
1177             my ($name) = join( '.', grep ( /.+/, @_ ) );
1178             $name =~ s/\W+/_/g;
1179             close_out_file();
1180             $current_name = "$config{'datadir'}$config{'slash_sys'}$name.$config{'output'}";
1181             $work{'current_name_work'} = "$current_name$config{'work_ext'}";
1182             rename( $current_name, $work{'current_name_work'} ) if -e $current_name and $work{'current_name_work'} and $current_name;
1183             open( I, '>>', $work{'current_name_work'} )
1184             or printlog( 'err', "!!! UNABLE TO OPEN $work{'current_name_work'}" )
1185             and return;
1186             }
1187              
1188             sub close_out_file {
1189             if ( $work{'current_name_work'} ) {
1190             $processor{'out'}{'array'}->();
1191             print I";\n";
1192             close(I);
1193             rename( $work{'current_name_work'}, $current_name ) if $work{'current_name_work'} and $current_name;
1194             }
1195             $work{'current_name_work'} = $current_name = '';
1196             }
1197             }
1198             =cut
1199              
1200             sub caller_trace(;$) {
1201 0 0 0 0 0 0 for ( 0 .. $_[0] || 5 ) { local @_ = caller $_; last unless @_; printlog( 'caller', $_, @_ ); }
  0         0  
  0         0  
  0         0  
1202             }
1203              
1204             sub lib_init() {
1205             $SIG{__WARN__} = sub {
1206 0     0   0 printlog( 'warn', $@, $!, @_ );
1207             #printlog( 'die', 'caller', $_, caller($_) ) for ( 0 .. 15 );
1208             #caller_trace(15);
1209             }, $SIG{__DIE__} = sub {
1210 0     0   0 printlog( 'die', 'psm',$@, $!, @_ );
1211             #printlog( 'die', 'caller', $_, caller($_) || last ) for ( 0 .. 15 );
1212 0         0 trace(15);
1213             }
1214 0 0 0 0 0 0 if !$static{'no_sig_log'} and !$ENV{'SERVER_PORT'}; #die $!;
1215 0 0       0 unless ( $static{'port2prot'} ) {
1216 0         0 @{ $static{'port2prot'} }{ ( $config{'scanner'}{$_}{'port'}, $_ ) } = ( $_, $_ ) for keys %{ $config{'scanner'} };
  0         0  
  0         0  
1217             }
1218             }
1219              
1220             sub mysleep($) {
1221 0 0 0 0 0 0 if ( $_[0] > 1 and $config{'system'} eq 'win' ) { #activeperl only?
1222 0         0 sleep(1) for ( 0 .. $_[0] );
1223             } else {
1224 0         0 sleep( $_[0] );
1225             }
1226             }
1227              
1228             sub sleeper($;$$) {
1229 0     0 0 0 my ( $max, $where, $min, ) = @_;
1230 0   0     0 $where ||= join '', caller;
1231 0 0 0     0 ( $work{'sleeper'}{$where} ? printlog( 'dev', "sleeper: clean $where was $work{'sleeper'}{$where}" ) : () ),
    0          
1232             $work{'sleeper'}{$where} = 0, return 0
1233             if !$max
1234             or $ENV{'SERVER_PORT'};
1235 0   0     0 $min ||= 0.5;
1236             #printlog( 'dbg', "sleepe0: sleep $where $work{'sleeper'}{$where} mi=$min" );
1237 0 0 0     0 ( $work{'sleeper'}{$where} ||= $min ) *= ( $work{'sleeper'}{$where} > $max ? 1 : 2 );
1238 0         0 printlog( 'dbg', "sleeper: sleep $where $work{'sleeper'}{$where}" );
1239 0         0 mysleep( $work{'sleeper'}{$where} );
1240 0         0 return $work{'sleeper'}{$where};
1241             }
1242              
1243             sub shuffle(@) { #@$deck = map{ splice @$deck, rand(@$deck), 1 } 0..$#$deck;
1244 0     0 0 0 my $deck = shift;
1245 0 0       0 $deck = [ $deck, @_ ] unless ref $deck eq 'ARRAY';
1246 0         0 my $i = @$deck;
1247 0         0 while ( $i-- ) {
1248 0         0 my $j = int rand( $i + 1 );
1249 0         0 @$deck[ $i, $j ] = @$deck[ $j, $i ];
1250             }
1251 0 0       0 return wantarray ? @$deck : $deck;
1252             }
1253              
1254             sub flush(;$) {
1255             #printlog('dev', 'FLUSH') ;
1256 0 0   0 0 0 return if $config{'no_flush'};
1257 0   0     0 select( ( select( $_[0] || *STDOUT ), $| = 1 )[0] );
1258             }
1259              
1260             =todo
1261             sub paintdots_onreload {
1262             my ($ref) = shift;
1263             sub {
1264             if ( $_[0] =~ /[Ss]ubroutine (\w+) redefined/ ) {
1265             my ($subr) = $1;
1266             ++$$ref;
1267             local ($|) = 1;
1268             #$CPAN::Frontend->myprint(".($subr)");
1269             #$CPAN::Frontend->myprint(".");
1270             print(".");
1271             return;
1272             }
1273             warn @_;
1274             };
1275             }
1276             =cut
1277              
1278 0     0 0 0 sub count(@) { local %_; ++$_{$_} for @_; \%_ }
  0         0  
  0         0  
1279 0     0 0 0 sub uniq(@) { keys %{ count @_ } }
  0         0  
1280              
1281             sub config_read {
1282             #warn Dumper \@_;
1283 0     0 0 0 my @files;
1284 0 0       0 @files = @{ shift(@_) } if ref $_[0] eq 'ARRAY';
  0         0  
1285             #warn Dumper \@files;
1286             #warn Dumper \@_;
1287             #print "config_read($ENV{'SCRIPT_FILENAME'}, $_[0]);\n";
1288             #print ("config_read NOREAD!;\n");
1289             #my $file = ;
1290             #return if $static{'config_read'}{ $ENV{'SCRIPT_FILENAME'} . $file }++ and !$_[0];
1291             #print " [$file] config_read($_[0])";
1292             #do $ENV{'PROSEARCH_PATH'} . './config.pl' or do '../config.pl';
1293             #print "config_readb(); root_path = $root_path\n";
1294             #$root_path ||= lib::abs::path('../').'/';
1295 0   0     0 ( $ENV{'SCRIPT_FILENAME'} || $work{'$0'} || $0 ) =~ m|^(.+)[/\\].+?$|;
1296 0 0       0 $root_path = #||= $ENV{'PROSEARCH_PATH'} ||
1297             ( $1 ? $1 . '/' : undef );
1298             #$root_path||= $1 . '/' if $1;
1299 0         0 $root_path =~ s|\\|/|g;
1300 0   0     0 $root_path //= './';
1301             #do $ENV{'PROSEARCH_PATH'} . './config.pl' or
1302             #print "pa=". ( $ENV{'SCRIPT_FILENAME'} ,';', $0),"\n";
1303 0 0       0 unless (@files) {
1304 0   0     0 @files = (
1305             $root_path . ( $config{'config_file'} // 'config.pl' ) #, $root_path . 'confdef.pl'
1306             );
1307             }
1308             #warn "config_read(); root_path = $root_path ; file = @files\n";
1309 0         0 my @errs;
1310 0         0 local $_; #= do ;
1311             #use lib::abs;
1312 0         0 for my $file ( uniq @files ) {
1313 0 0 0     0 ++$_, last if $static{'config_read'}{ $ENV{'SCRIPT_FILENAME'} . $file }++ and !$_[0];
1314             #warn "reading [$file]", -s $file, ;# lib::abs::path($file);
1315             #print( ' do1:',$_,',', $!, ' eval=', $@, "\n" ) if !$_ or $! or $@;
1316             #MAKE ARRAY
1317 0 0 0     0 if ( !$ENV{'SERVER_PORT'} and !-e $file and -e $file . '.dist' and use_try('File::Copy') ) {
      0        
      0        
1318 0         0 printlog( 'warn', 'unfinished install, copying', $file . '.dist', '->', $file );
1319 0         0 File::Copy::copy( $file . '.dist', $file );
1320             }
1321 0 0       0 $_ += do $file and last; #and warn("read [$file] ok $! $@;")
1322 0 0       0 push @errs, map { "config [$file] not found: " . $_ } grep { $_ } $!, $@, unless $_;
  0         0  
  0         0  
1323             #push @errs, grep { $_ } $!, $@ unless $_;
1324             #push @errs, grep { $_ } $!, $@, $_ += do $root_path . '../config.pl', push @errs, grep { $_ } $!, $@ unless $_;
1325             }
1326 0 0 0     0 if ( !$_ and !$_[1] ) {
1327 0 0       0 print "Content-type: text/html\n\n" if defined( $ENV{'SERVER_PORT'} );
1328 0         0 print "config read errors: [@files]: ",, map "$_;\n", @errs;
1329             }
1330             #print"rp set1 to [$root_path]\n";
1331             conf(
1332             sub {
1333             #print"rp set2 to [$root_path]\n";
1334 0     0   0 $config{'root_path'} = $root_path;
1335             },
1336 0         0 0.0001
1337             );
1338             #print( ' do2:',$_,',', $!, ' eval=', $@, "\n" ) if $! or $@;
1339             #print( ' do1:', $!, 'eval=', $@ ,"\n" ) if $! or $@;
1340             #print( 'compile err1:', $!, "\n" ) if $!;
1341             #print ('compile err2:',$@, "\n");
1342             #require $ENV{'PROSEARCH_PATH'} . './config.pl' or do '../config.pl';
1343             #print('config_read',Dumper (\%config ));
1344             #print('config_read',(scalar keys %config ));
1345             }
1346              
1347             sub pre_calc_every {
1348 0         0 $config{'post_init_every'}{$_}->(@_)
1349 0 0   0 0 0 for grep { ref $config{'post_init_every'}{$_} eq 'CODE' } sort keys %{ $config{'post_init_every'} || {} };
  0         0  
1350             }
1351              
1352             sub pre_calc_once {
1353             #$config{'post_init_once'}->(@_) if $config{'post_init_once'};
1354             #print "pre_calc_once\n";
1355 0         0 $config{'post_init_once'}{$_}->(@_)
1356 0 0   0 0 0 for grep { ref $config{'post_init_once'}{$_} eq 'CODE' } sort keys %{ $config{'post_init_once'} || {} };
  0         0  
1357             }
1358              
1359             sub pre_calc {
1360 0     0 0 0 pre_calc_once(@_);
1361 0         0 pre_calc_every(@_);
1362             }
1363              
1364             sub config_reload {
1365             #warn "config_reload(clear=$_[0];; $config{'root_path'})";
1366             #print "config_reload(clear!=$_[0])\n";
1367 0 0   0 0 0 my $files = shift if ref $_[0] eq 'ARRAY';
1368 0 0       0 %config = () if $_[0];
1369 0   0     0 config_read( ( $files || () ), $_[1], $_[3] );
1370             #print "read end;";
1371 0 0       0 $_[2]->() if ref $_[2] eq 'CODE';
1372 0         0 conf();
1373             #print ('compile err2:',$@, "\n");
1374 0 0       0 if ( !%config ) {
1375 0 0       0 print "Content-type: text/html\n\n" if defined( $ENV{'SERVER_PORT'} );
1376 0 0       0 print("Please fix error in config.pl: [$@]"), exit if $@;
1377 0         0 print "Please create config.pl with parametrs (see config.pl.dist) and correct modes [$!]";
1378 0         0 exit;
1379             }
1380             #print('config_reload',(scalar keys %config ));
1381             #print('config_reload',Dumper (\%config ));
1382             }
1383 0     0 0 0 sub configure { &config_reload; }
1384             #sub config { &configure; } #to del
1385             sub reload_lib {
1386             #%human = ();
1387 0     0 0 0 my $redef = 0;
1388 0         0 for my $file (@_) {
1389 0         0 printlog( 'dbg', "reloading $file: $INC{$file}" );
1390 0 0 0     0 open( my $fh, '<', ( $INC{$file} or $file ) ) or printlog( 'err', "reload err $file=$INC{$file}" ), next;
1391 0         0 local ($/);
1392 0         0 local ( $SIG{__WARN__} ) = paintdots_onreload( \$redef );
1393 0         0 local ( $SIG{__DIE__} ) = paintdots_onreload( \$redef );
1394 0         0 eval <$fh>;
1395 0 0       0 warn $@ if $@;
1396             }
1397             }
1398             our %conf;
1399              
1400             sub conf(;$$) {
1401             #warn 'conf from ', caller, Dumper \@_ ;
1402 1     1 0 2 my ( $sub, $order ) = ( shift, shift );
1403             #if ( !$ENV{'MOD_PERL'} ) { $sub->(@_) if $sub; return; }
1404 1   33     11 my $id = #$ENV{'PROSEARCH_PATH'} ||
1405             $ENV{'SCRIPT_FILENAME'} || $work{'$0'} || $0;
1406             #print join ' ',('dev',"conf($sub, $order, [$root_path] id=$id)", caller,"");
1407 1 50       5 unless ($sub) {
1408             #print("running", scalar keys %{ $conf{'conf_init'}{ $ENV{'PROSEARCH_PATH'} } }, "now=",scalar keys %config, "\n");
1409             #warn("RUNCONF[$id]($_/",scalar keys %{ $conf{'conf_init'}{$id } },"] from(",join('|',@{$conf{'conf_init_from'}{$id}{$_}}), ";", ""),
1410 0         0 $conf{'conf_init'}{$id}{$_}->() for sort { $a <=> $b } keys %{ $conf{'conf_init'}{$id} };
  0         0  
  0         0  
1411             #warn("confrunned", "now=",scalar keys %config, "\n");
1412 0         0 return;
1413             }
1414 1         1 local $_;
1415 1   33     7 $conf{'conf_init'}{$id}{ $_ = ( $order or $conf{'conf_count'}{$id} += 10 ) } = $sub;
1416 1         8 $conf{'conf_init_from'}{$id}{$_} = [caller];
1417             #print "conf(@_):", Dumper([caller],$conf{'conf_init'}, $conf{'conf_init_from'});
1418             }
1419              
1420             sub http_get { # REWRITE easier
1421 0     0 0 0 my ( $what, $asfile, $lwpopt, $method, $content, $headers_out, $headers_in ) = @_;
1422             #return "ZZZZZ";
1423             #printlog( 'dev', 'http_get', $what, $asfile, "cd=$config{'cachedir'};c=$config{'cache_http'}; " );
1424 0         0 my %url = split_url($what);
1425 0         0 my $c = encode_url( $what, $config{'encode_url_file_mask'} );
1426 0 0       0 if ( length $c > 200 ) {
1427 0         0 my ( $bef, $mid, $aft ) = $c =~ /^(.{50})(.+)(.{50})$/;
1428             #local $_ = 0;
1429 0         0 my $midv = 0;
1430 0         0 $midv += ord for split //, $mid;
1431 0         0 $c = join '__', $bef, $midv, $aft;
1432             #$_ += ord;
1433             #}
1434             }
1435 0 0 0     0 $c = ( $config{'cachedir'} || '.' ) . '/' . $c if $config{'cachedir'};
1436 0 0 0     0 $c = $asfile if $asfile and $asfile != 1;
1437             #printlog('dev', $what, $asfile, "cache=$config{'cache_http'}, dir=$config{'cachedir'};");
1438 0 0 0     0 if ( $config{'cache_http'} and -e $c and -M $c < $config{'cache_http'} ) {
      0        
1439 0 0       0 return $c if $asfile;
1440 0 0       0 if ( open( CF, '<', $c ) ) {
1441 0         0 local $/;
1442 0         0 local $_ = ;
1443 0         0 close(CF);
1444 0         0 return $_;
1445             }
1446             }
1447 0 0       0 printlog( 'warn', 'http_get disabled' ), return if $config{'no_http_get'};
1448             #printlog('dev', 'http_get',$what, $asfile);
1449             return eval
1450             #do
1451 0 0       0 {
1452             #printlog 'dev' ,0 ;
1453 0 0       0 eval('use LWP::UserAgent; use URI::URL;1;') or printlog( 'err', 'http use libs', @!, $! ); #if not installed
1454 0 0       0 my $ua = LWP::UserAgent->new(
1455             'agent' => $config{'useragent'} || $config{'crawler_name'},
1456             'timeout' => hconfig( 'timeout', $url{'host'}, $url{'prot'} ) || 10,
1457 0 0 0     0 %{ $config{'lwp'} || {} }, %{ $lwpopt || {} }
  0   0     0  
1458             );
1459             #$ua->proxy('http', 'http://proxy.ru:3128');
1460 0 0       0 if ( ref $config{'proxy'} eq 'ARRAY' ) {
    0          
1461 0         0 local @_ = @{ shuffle( $config{'proxy'} )->[0] };
  0         0  
1462             #printlog('proxy', @_, Dumper($config{'proxy'}));
1463 0         0 $ua->proxy(@_);
1464             } elsif ( $config{'proxy'} ) {
1465 0         0 $ua->proxy( 'http', $config{'proxy'} );
1466             }
1467             #printlog 'dev' ,1 , $asfile , $c;
1468 0 0       0 $ua->mirror( $what, $c ), return $c if $asfile;
1469 0   0     0 $method ||= 'GET';
1470             #print "RwM:$method;";
1471             #my $resp =( $method eq 'HEAD' ? $ua->head($what) :
1472 0 0       0 my $resp = (
1473             $ua->request(
1474             HTTP::Request->new(
1475             $method,
1476             URI::URL->new($what),
1477             HTTP::Headers->new(
1478             #'User-Agent' => ($config{'useragent'} || $config{'crawler_name'}),
1479 0         0 %{ $headers_in || {} }
1480             ),
1481             $content
1482             )
1483             )
1484             );
1485             #my $ret = $headers ? \$resp->content : \$resp->asfile;
1486 0 0       0 my $ret = $headers_out ? 'as_string' : 'content';
1487             #printlog 'resp', Dumper $resp;
1488             #print "[H:",$resp->header();
1489             #print "[H:",$resp->code();
1490 0 0       0 if ( $resp->is_success ) {
1491 0 0       0 if ( $config{'cachedir'} ) {
1492 0 0       0 open( CF, '>', $c ) or return;
1493 0         0 binmode(CF);
1494 0         0 print CF$resp->$ret(); #content;
1495             #print CF $ret->(); #content;
1496 0         0 close(CF);
1497             }
1498             #return $asfile ? $c : ($resp->content); #{map {$_ => $resp->header($_)}$resp->header_field_names}
1499             #printlog('dev', 'http ret', $ret, $asfile,"NOW");
1500             #return "FUCCCCKKAAA";
1501             #return $resp->$ret();
1502 0 0       0 return ( $asfile ? $c : ( $resp->$ret() ) ); #{map {$_ => $resp->header($_)}$resp->header_field_names}
1503             #return $asfile ? $c : $ret->(); #{map {$_ => $resp->header($_)}$resp->header_field_names}
1504             } else {
1505 0         0 printlog( 'dev', 'http getfail', $what, $resp->code(), $resp->message() );
1506             #return $asfile ? undef: $resp->message;
1507 0         0 return undef;
1508             }
1509 0         0 1;
1510             } or printlog( 'err', @$, @!, $! );
1511 0         0 return undef;
1512             }
1513              
1514             sub http_get_code ($;$$) {
1515 0     0 0 0 my ( $what, $lwpopt, $method ) = @_;
1516             #printlog('dev', 'http_get_code',$what, $method);
1517 0 0       0 my $ret = eval {
1518 0 0       0 eval('use LWP::UserAgent; use URI::URL;1;') or printlog( 'err', 'http use libs', @!, $! ); #if not installed
1519             #my $ua = ;
1520             #$ua->proxy('http', 'http://proxy.ru:3128');
1521 0 0       0 my $resp = (
1522 0 0 0     0 ( LWP::UserAgent->new( 'timeout' => hconfig('timeout'), %{ $config{'lwp'} or {} }, %{ $lwpopt or {} } ) )->request(
  0   0     0  
1523             HTTP::Request->new(
1524             ( $method or 'GET' ),
1525             URI::URL->new($what), HTTP::Headers->new( 'User-Agent' => $config{'useragent'} || $config{'crawler_name'} )
1526             )
1527             )
1528             );
1529             #print "[H:",$resp->header();
1530             #print 'GCR', $resp->code(), "\n";
1531 0         0 return $resp->code();
1532             } or printlog( 'err', @$, @!, $! );
1533 0   0     0 return $ret || undef;
1534             }
1535              
1536             sub html_strip($) {
1537 0     0 0 0 my $s = $_[0];
1538 0         0 $s =~ s{HTTP/.*?\n\n}{}gs;
1539 0         0 $s =~ s///gs;
1540 0         0 $s =~ s{<$_.*?>.*?}{}gs for qw(script style);
1541 0         0 $s =~ s{}{}gs;
1542 0         0 return $s;
1543             }
1544              
1545             sub loadlist {
1546 0     0 0 0 my %res = ();
1547 0         0 for my $sca (@_) {
1548 0 0       0 next unless $sca;
1549 0 0       0 open( SSF, '<', $sca ) or next;
1550 0         0 while () {
1551 0 0       0 next if /^\s*[#;]/;
1552 0         0 local @_ = split /\s+/, $_;
1553 0 0       0 my $host = shift or next;
1554 0         0 local %_;
1555 0         0 get_params_one( \%_, @_ );
1556 0         0 $res{$host} = \%_;
1557             }
1558 0         0 close(SSF);
1559             }
1560 0 0       0 return wantarray ? %res : \%res;
1561             }
1562 0     0 0 0 sub shelldata(@) { s/[\x0d\x0a\"\'\`|><&]//g for @_; } #`
1563              
1564             =c
1565             sub save_list {
1566             my ($file, $data) = @_;
1567             use Storable;
1568             store($data, $file);
1569             =c
1570             return 1 unless open(SF, '>', $file);
1571             for my $str (sort keys %$data) {
1572             print SF join(' ', map{ encode_url($_) . (length($data->{$str}{$_}) ? ( '='. encode_url($data->{$str}{$_})) : ())} sort keys %{$data->{$str}});
1573             #for my $k (sort keys %{$data->{$str}}) {
1574             #}
1575             print SF "\n";
1576             }
1577            
1578             close(SF);
1579             }
1580             =cut
1581              
1582             =schedule
1583              
1584             schedule(everysec, our $___mysub ||= sub{});
1585             schedule([firstafter, everysec], our $___mysub ||= sub{});
1586             schedule({wait=>10, every=>5}, our $___mysub ||= sub{});
1587              
1588             =cut
1589              
1590             sub schedule($$;@) { #$Id: psmisc.pm 4847 2014-06-30 23:41:45Z pro $ $URL: svn://svn.setun.net/search/trunk/lib/psmisc.pm $
1591 0     0 0 0 our %schedule;
1592 0         0 my ( $every, $func ) = ( shift, shift );
1593 0         0 my $p;
1594 0 0       0 ( $p->{'wait'}, $p->{'every'}, $p->{'runs'}, $p->{'cond'}, $p->{'id'} ) = @$every if ref $every eq 'ARRAY';
1595 0 0       0 $p = $every if ref $every eq 'HASH';
1596 0 0 0     0 $p->{'every'} ||= $every if !ref $every;
1597 0   0     0 $p->{'id'} ||= join ';', caller;
1598             #dmp $p, \%schedule;
1599             #dmp $schedule{ $p->{'id'} }{'runs'}, $p->{'runs'}, $p, $schedule{ $p->{'id'} } if $p->{'runs'};
1600 0 0 0     0 $schedule{ $p->{'id'} }{'func'} = $func if !$schedule{ $p->{'id'} }{'func'} or $p->{'update'};
1601 0 0 0     0 $schedule{ $p->{'id'} }{'last'} = time - $p->{'every'} + $p->{'wait'} if $p->{'wait'} and !$schedule{ $p->{'id'} }{'last'};
1602             #dmp("RUN", $p->{'id'}),
1603 0 0 0     0 ++$schedule{ $p->{'id'} }{'runs'}, $schedule{ $p->{'id'} }{'last'} = time, $schedule{ $p->{'id'} }{'func'}->(@_),
      0        
      0        
      0        
      0        
1604             if ( $schedule{ $p->{'id'} }{'last'} + $p->{'every'} < time )
1605             and ( !$p->{'runs'} or $schedule{ $p->{'id'} }{'runs'} < $p->{'runs'} )
1606             and ( !( ref $p->{'cond'} eq 'CODE' ) or $p->{'cond'}->( $p, $schedule{ $p->{'id'} }, @_ ) )
1607             and ref $schedule{ $p->{'id'} }{'func'} eq 'CODE';
1608             }
1609             { #$Id: psmisc.pm 4847 2014-06-30 23:41:45Z pro $ $URL: svn://svn.setun.net/search/trunk/lib/psmisc.pm $
1610             my (@locks);
1611             sub lockfile($) {
1612 0 0 0 0 0 0 return ( $config{'lock_dir'} || './' ) . ( length $_[0] ? $_[0] : 'lock' ) . ( $config{'lock_ext'} || '.lock' );
      0        
1613             }
1614              
1615             sub lock (;$@) {
1616 0     0 0 0 my $name = shift;
1617 0 0       0 my %p = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
  0         0  
1618 0   0     0 $p{'sleep'} //= $config{'lock_sleep'} // 1;
      0        
1619 0 0 0     0 $p{'timeout'} //= $config{'lock_timeout'} // 600 unless length $p{'timeout'};
      0        
1620 0   0     0 $p{'old'} //= $config{'lock_old'} // 3600;
      0        
1621             #$p{'readonly'} ||= 0; #dont write lock file, only wait
1622 0         0 my $waitstart = time();
1623 0         0 my $waits;
1624             LOCKWAIT:
1625 0         0 while ( -e lockfile $name) {
1626             #printlog( 'lockdev', 'locktime', -M lockfile $name, time() - $^T + 86400 * -M lockfile $name, $^T + 86400 * -M lockfile $name, 86400 * -M lockfile $name, );
1627 0 0       0 printlog( 'lock', $name, 'ignore too old', -M lockfile $name, time() - $^T + 86400 * -M lockfile $name), last
1628             if time() - $^T + 86400 * -M lockfile $name > $p{'old'};
1629 0 0       0 printlog( 'lock', $name, 'fail, timeout', int( time() - $waitstart ) ), return 0 if time() - $waitstart > $p{'timeout'};
1630 0 0       0 printlog( 'lock', 'locked, wait', $name ) unless $waits++;
1631 0         0 sleep $p{'sleep'};
1632             }
1633 0 0       0 printlog( 'lock', 'unlocked', $name, 'per', int( time() - $waitstart ) ) if $waits;
1634 0 0       0 return 1 if $p{'readonly'};
1635 0         0 local $_ = "pid=$$ time=" . int( time() );
1636 0         0 file_rewrite lockfile $name, $_;
1637 0         0 file_rewrite; #flush
1638 0 0       0 if ( open my $f, '<', lockfile $name) {
1639 0         0 local $/ = undef;
1640 0         0 my $c = <$f>;
1641 0         0 close $f;
1642             #printlog 'test', $c;
1643 0 0       0 printlog( 'warn', 'not my lock', $_, $c ), goto LOCKWAIT if $_ ne $c;
1644             } else {
1645 0         0 printlog( 'err', 'lock open err', $name, lockfile $name);
1646 0         0 return 0;
1647             }
1648 0         0 push @locks, lockfile $name;
1649 0         0 return 1;
1650             }
1651              
1652             sub unlock (;$) {
1653 0     0 0 0 my $name = shift;
1654 0         0 local $_ = pop @locks;
1655 0 0 0     0 push @locks, $_ if length $name and lockfile($name) ne $_;
1656             #$name ||= $_;
1657             #printlog 'lock', 'unlocking', $name, lockfile $name;
1658             #unlink lockfile( $name ||= $_ );
1659 0 0       0 unlink $name ? lockfile($name) : $_;
1660             }
1661              
1662             sub unlock_all () {
1663             #unlink $_ for reverse @locks;
1664 1     1 0 9 unlink $_ while $_ = pop @locks;
1665             }
1666              
1667             END {
1668 1 50   1   60 printlog( 'lock', 'END locked unlock', @locks ) if @locks;
1669 1         5 unlock_all();
1670             }
1671             $SIG{$_} ||= sub {
1672             printlog( 'lock', 'SIG locked unlock', @locks ) if @locks;
1673             unlock_all();
1674             exit;
1675             }
1676             for qw(INT QUIT KILL TERM); #HUP
1677             }
1678             {
1679             my ( $current, $order );
1680              
1681             sub program(;$$) {
1682 16     16 0 23 my ( $name, $setorder ) = @_;
1683 16 100       121 return $current unless $name;
1684 5   66     46 $program{ $current = $name }{'order'} ||= ( $setorder or $order += ( $config{'order_step'} || 10 ) );
      33        
1685             #print "newprog($current, $program{$current}{'order'});" ;
1686 5         8 return $current;
1687             } #v2
1688             }
1689              
1690             sub printall {
1691 0     0 0   local $_ = shift;
1692 0 0         return unless length $_;
1693 0           $_ = $$_ while ref $_ eq 'REF';
1694 0 0         return $_->(@_) if ref $_ eq 'CODE';
1695             #local
1696 0 0         @_ = () if ref $_[0];
1697 0 0         print( $$_, @_ ), return if ref $_ eq 'SCALAR';
1698 0           print $_, @_;
1699             }
1700             program('params');
1701             $program{ program() }{'force'} = 1;
1702             $program{ program() }{'func'} ||= sub { $param = get_params(); };
1703             program('params_pre_config');
1704             $program{ program() }{'mask'} ||= '^(-*c(onf)?-*)|(--).*';
1705             $program{ program() }{'param_name'} ||= 1;
1706             $program{ program() }{'func'} ||= sub {
1707             my ( $v, $w ) = @_;
1708             $w =~ s/^(-*c(onf?)?-*)|(--)//i;
1709             $v =~ s/^NUL$//;
1710             return 0 unless defined($w) and defined($v);
1711             #local @_ = split /__/, eval( '$config' . join( '', map { '{$_[' . $_ . ']}' } ( 0 .. $#_ ) ) . '= $param->{$_};' ) for ( grep { $param->{$_} } keys %$param );
1712             local @_ = split( /__/, $w ) or return 0;
1713             #print( 'dev', 'genpre',$w, $v, @_, "\n");
1714             #printlog( 'dev', 'gen', @_,'$config' . join( '', map { '{$_[' . $_ . ']}' } ( 0 .. $#_ ) ) . ' = $v;' );
1715             eval( '$config' . join( '', map { '{$_[' . $_ . ']}' } ( 0 .. $#_ ) ) . ' = $v;' );
1716             #for ( grep { $param->{$_} } keys %$param );
1717             #$config{$w} = $v if defined($w) and defined($v);
1718             #printlog('dev', 'res', $config{'zzz'}{'yy'});
1719             return 0;
1720             };
1721             program('config');
1722             $program{ program() }{'force'} = 1;
1723             $program{ program() }{'func'} ||= sub {
1724             #print "COOOO";
1725             config_reload(); #$param
1726             pre_calc($param);
1727             #config_init($param);
1728             return 0;
1729             };
1730             program('params_config');
1731             %{ $program{ program() } } = ( %{ $program{'params_pre_config'} }, 'order' => $program{ program() }{'order'} );
1732             program( 'help', 100000 );
1733             $program{ program() }{'mask'} ||= '^-*he?l?p?$';
1734             $program{ program() }{'func'} ||= sub {
1735             print "Usage: perl $work{'$0'} [action[=params]] [--config_key[=value]] [...] \n\n Actions:\n";
1736             for ( sort keys %program ) {
1737             next if $program{$_}{'force'} or /(_aft)|(_bef)$/;
1738             print "$_ $program{$_}{'desc'}\n";
1739             }
1740             print "\nConfig defaults:\n";
1741             for ( sort keys %config ) { print "--$_\t[$config{$_}]\n"; }
1742             };
1743              
1744             sub program_one($;@) {
1745 0     0 0   my $current = shift;
1746 0 0         return undef unless exists $program{$current};
1747 0 0 0       if ( $program{$current}{'func'} and !$program{$current}{'disabled'} ) {
1748 0           my @ret;
1749 0           printlog( 'trace', 'program run', $current, @_ );
1750 0           eval { @ret = $program{$current}{'func'}->(@_); };
  0            
1751 0 0         printlog( 'err', 'program', $current, 'run error:', $@ ) if $@;
1752 0 0         return wantarray ? @ret : $ret[0];
1753             }
1754 0           return undef;
1755             }
1756              
1757             sub program_run(;$) {
1758 0     0 0   for my $n ( 0 .. 1 ) {
1759 0           my %masks;
1760 0   0       for my $current ( sort keys %program ) { ++$masks{ $program{$current}{'mask'} ||= "^-?$current\\d*\$" }; }
  0            
1761 0           $program{'default'}{'notmask'} = '^-?(' . join( '|', keys %masks ) . ")\\d*\$";
1762 0           for my $current ( grep { !$program{$_}{'checked'} } sort { $program{$a}{'order'} <=> $program{$b}{'order'} } keys %program )
  0            
  0            
1763             {
1764 0 0 0       next if $current eq 'default' and !$n;
1765 0           ++$program{$current}{'checked'};
1766 0           for my $par ( sort( keys %$param ), grep { $program{$_}{'force'} } keys %program ) {
  0            
1767 0 0 0       if (
      0        
1768             #BUG!!! next line always NOT on one char targets (/ z x ....)
1769             ( (
1770             !( $program{$current}{'notmask'} and $par =~ /$program{$current}{'notmask'}/i )
1771             and $par =~ /$program{$current}{'mask'}/i
1772             )
1773             or $program{$current}{'force'}
1774             )
1775             and !$program{$current}{'runned'}
1776             )
1777             {
1778 0 0 0       local @_ = (
    0          
1779             ( ( defined( $param->{$par} ) and $param->{$par} ne '' ) ? $param->{$par} : () ),
1780             ( $program{$current}{'param_name'} ? $par : () )
1781             );
1782 0           state( 'program:', $current, @_ );
1783 0           program_one( $current . '_bef', @_ );
1784 0           my @r = program_one( $current, @_ );
1785 0           program_one( $current . '_aft', @_, \@r );
1786 0 0 0       printlog( 'warn', 'program finished', $current, '=', @r ) if $r[0] and !ref $r[0];
1787 0 0 0       $program{$current}{'runned'} = 1 if $program{$current}{'once'} or $program{$current}{'force'};
1788 0           $program{$current}{'force'} = '';
1789             }
1790             }
1791             }
1792             }
1793             }
1794             #BEGIN { config_init(); }
1795             config_init();
1796             #
1797             #
1798             #
1799             #
1800             #
1801             package #hide from cpan
1802             psconn;
1803 1     1   17 use strict;
  1         2  
  1         1363  
1804             our $VERSION = ( split( ' ', '$Revision: 4847 $' ) )[1];
1805             #use psmisc;
1806             #sub connection {
1807             sub new {
1808 0     0     my $class = shift;
1809 0           my $self = {};
1810 0           bless( $self, $class );
1811 0           $self->init(@_);
1812             #printlog( 'conn', 'new', $self, $class, 'deb:', $self->{'error_sleep'} );
1813 0           return $self;
1814             }
1815              
1816             sub init {
1817 0     0     my $self = shift;
1818 0           local %_ =
1819             ( 'connected' => 0, 'connect_auto' => 1, 'connect_tries' => 100, 'connect_chain_tries' => 10, 'error_sleep' => 5, @_ );
1820             #@{$self}{ keys %_ } = values %_;
1821 0   0       $self->{$_} //= $_{$_} for keys %_;
1822             #printlog('dev', 'conn init error_sleep', $self->{'error_sleep'});
1823 0 0         $self->connect() if $self->{'auto_connect'};
1824 0           return $self;
1825             }
1826             ##methods
1827             #connect
1828             #reconnect
1829             #disconnect
1830             #dropconnect
1831             #keep
1832             ##child can do
1833             #_connect
1834             #_disconnect
1835             #_dropconnect
1836             #check_error
1837             #parse_error
1838             #_keep
1839             ##vars
1840             #tries
1841             #error_sleep
1842             #auto_connect
1843             ##vars status
1844             #connected
1845             sub connect {
1846 0     0     my $self = shift;
1847             #return ($self->{'connect_check'} ? $self->keep() : 0) if $self->{'connected'};
1848 0 0 0       return 1 if $self->{'in_connect'} or $self->{'in_disconnect'};
1849 0 0         return $self->keep() if $self->{'connected'};
1850             #printlog( 'dev', "conn::connect[$self->{'connect_tried'} <= $self->{'connect_tries'}]" );
1851             #if (!$self->_connect()) { #ok
1852 0           my $aftersleep = 1;
1853 0           while ( !$self->{'die'} ) {
1854 0 0 0       if ( ( !$self->{'connect_tries'} or $self->{'connect_tried'}++ <= $self->{'connect_tries'} )
      0        
      0        
1855             and ( !$self->{'connect_chain_tries'} or $self->{'connect_chain_tried'}++ <= $self->{'connect_chain_tries'} ) )
1856             {
1857             #do { { #ok
1858 0           $self->{'in_connect'} = 1;
1859 0 0         if ( !$self->_connect() ) {
1860             #printlog('CONNECTED!?');
1861 0           $self->{'in_connect'} = 0;
1862 0           ++$self->{'connected'};
1863 0           ++$self->{'connects'};
1864 0           $self->{'connect_chain_tried'} = 0;
1865             #printlog( 'dev', 'oncon', $_ ),
1866 0           $self->{ 'on_connect' . $_ }->($self) for grep { ref $self->{ 'on_connect' . $_ } eq 'CODE' } ( '', 1 .. 10 );
  0            
1867 0           return 0;
1868             }
1869 0           $self->{'in_connect'} = 0;
1870 0           $self->dropconnect();
1871 0           $self->log(
1872             'dev',
1873             'psconn::connect run sleep',
1874             $self->{'error_sleep'},
1875             "c=$self->{'connect_tried'}/$self->{'connect_tries'}",
1876             "ch=$self->{'connect_chain_tried'}/$self->{'connect_chain_tries'}",
1877             );
1878 0           $self->sleep( $self->{'error_sleep'} );
1879 0           $aftersleep = 0;
1880             } else {
1881 0           $self->log( 'dev',
1882             " if (( $self->{'connect_tried'}++ <= $self->{'connect_tries'} or !$self->{'connect_tries'} ) and ( $self->{'connect_chain_tried'}++ <= $self->{'connect_chain_tries'} or !$self->{'connect_chain_tries'} ) )"
1883             );
1884 0           last;
1885             }
1886             }
1887             #} while ( ++$self->{'connect_tried'} <= $self->{'connect_tries'} );
1888 0 0         $self->sleep($aftersleep) if $aftersleep;
1889 0           return 1;
1890             }
1891              
1892             sub reconnect {
1893 0     0     my $self = shift;
1894 0           $self->disconnect(@_);
1895 0           return $self->connect(@_);
1896             #++$self->{'reconnects'};
1897             }
1898              
1899             sub disconnect {
1900 0     0     my $self = shift;
1901 0 0         return 0 unless $self->{'connected'};
1902             #printlog('trace', 'psconn::disconnect');
1903 0           $self->_disconnect(@_);
1904 0           $self->dropconnect(@_);
1905             }
1906              
1907             sub dropconnect {
1908 0     0     my $self = shift;
1909 0 0         return 0 unless $self->{'connected'};
1910 0           $self->_dropconnect(@_);
1911 0           $self->{'connected'} = 0;
1912             }
1913              
1914             sub keep {
1915 0     0     my $self = shift;
1916             #print("psconn::keep\n");
1917             #print("psconn::keep:R1=0\n"),
1918 0 0 0       return 0 if $self->{'connected'} and !$self->{'connect_check'};
1919             #local $_ =$self->_check();
1920             #print("keep:preR2[$_]\n");
1921             #print("keep:R2=0[$_]\n"),
1922             #return 0 if !$_;
1923 0 0         return 0 if !$self->_check();
1924             #print("keep:postR2[$_]\n");
1925             #print('keep:R3=rc'),
1926 0           return $self->reconnect();
1927             }
1928              
1929             sub _connect {
1930 0     0     my $self = shift;
1931             #printlog('NEWER');
1932 0           return 0;
1933             }
1934              
1935             sub _disconnect {
1936 0     0     my $self = shift;
1937 0           return 0;
1938             }
1939              
1940             sub _dropconnect {
1941 0     0     my $self = shift;
1942 0           return 0;
1943             }
1944              
1945             sub _check {
1946 0     0     my $self = shift;
1947             #printlog('DONT');
1948 0           return 0;
1949             }
1950              
1951             sub check_error {
1952 0     0     my $self = shift;
1953 0           return 0;
1954             }
1955              
1956             sub parse_error {
1957 0     0     my $self = shift;
1958 0           return 0;
1959             }
1960              
1961             sub DESTROY {
1962 0     0     my $self = shift;
1963             #printlog('trace', 'psconn::DESTROY');
1964 0           $self->disconnect();
1965             }
1966              
1967             sub sleep {
1968 0     0     my $self = shift;
1969             #$self->log( 'dev', 'psconn::sleep', @_ );
1970             #local $_ = $work{'sql_locked'};
1971             #sql_unlock_tables() if $work{'sql_locked'} and $_[0];
1972 0           CORE::sleep(@_);
1973             #return psmisc::sleeper(@_);
1974             #sql_lock_tables($_) if $_ and $_[0];
1975             }
1976             1;