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/\\<\;/g; | ||||
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; |