view release on metacpan or  search on metacpan

lib/Tie/Cycle.pm  view on Meta::CPAN

27
28
29
30
31
32
33
34
35
 
Does nothing, successfully
 
=cut
 
sub do_nothing()
{
        return 1;
}

 view release on metacpan or  search on metacpan

inc/Test/Base.pm  view on Meta::CPAN

64
65
66
67
68
69
70
71
72
73
74
    $default_object ||= $default_class->new;
    return $default_object;
}
 
my $import_called = 0;
sub import() {
    $import_called = 1;
    my $class = (grep /^-base$/i, @_) 
    ? scalar(caller)
    : $_[0];
    if (not defined $default_class) {

inc/Test/Base.pm  view on Meta::CPAN

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
        $caller =~ s/.*:://;
        croak "Too late to call $caller()"
    }
}
 
sub find_my_self() {
    my $self = ref($_[0]) eq $default_class
    ? splice(@_, 0, 1)
    : default_object();
    return $self, @_;
}
 
sub blocks() {
    (my ($self), @_) = find_my_self(@_);
 
    croak "Invalid arguments passed to 'blocks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to blocks()", shift(@_))

inc/Test/Base.pm  view on Meta::CPAN

164
165
166
167
168
169
170
171
172
173
174
    }
 
    return (@blocks);
}
 
sub next_block() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->block_list}, undef];
        $self->_next_list($list);

inc/Test/Base.pm  view on Meta::CPAN

178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
        $block->run_filters;
    }
    return $block;
}
 
sub first_block() {
    (my ($self), @_) = find_my_self(@_);
    $self->_next_list([]);
    $self->next_block;
}
 
sub filters_delay() {
    (my ($self), @_) = find_my_self(@_);
    $self->_filters_delay(defined $_[0] ? shift : 1);
}
 
sub no_diag_on_only() {
    (my ($self), @_) = find_my_self(@_);
    $self->_no_diag_on_only(defined $_[0] ? shift : 1);
}
 
sub delimiters() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    my ($block_delimiter, $data_delimiter) = @_;
    $block_delimiter ||= $self->block_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->block_delim($block_delimiter);
    $self->data_delim($data_delimiter);
    return $self;
}
 
sub spec_file() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_file(shift);
    return $self;
}
 
sub spec_string() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_string(shift);
    return $self;
}
 
sub filters() {
    (my ($self), @_) = find_my_self(@_);
    if (ref($_[0]) eq 'HASH') {
        $self->_filters_map(shift);
    }
    else {    

inc/Test/Base.pm  view on Meta::CPAN

231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
        push @$filters, @_;
    }
    return $self;
}
 
sub filter_arguments() {
    $Test::Base::Filter::arguments;
}
 
sub have_text_diff {
    eval { require Text::Diff; 1 } &&
        $Text::Diff::VERSION >= 0.35 &&
        $Algorithm::Diff::VERSION >= 1.15;
}
 
sub is($$;$) {
    (my ($self), @_) = find_my_self(@_);
    my ($actual, $expected, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ($ENV{TEST_SHOW_NO_DIFFS} or
         not defined $actual or

inc/Test/Base.pm  view on Meta::CPAN

261
262
263
264
265
266
267
268
269
270
271
        ok $actual eq $expected,
           $name . "\n" . Text::Diff::diff(\$expected, \$actual);
    }
}
 
sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);

inc/Test/Base.pm  view on Meta::CPAN

291
292
293
294
295
296
297
298
299
300
301
 
sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;
}
 
sub run_compare() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

inc/Test/Base.pm  view on Meta::CPAN

313
314
315
316
317
318
319
320
321
322
323
            is($block->$x, $block->$y, $block->name ? $block->name : ());
        }
    }
}
 
sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

inc/Test/Base.pm  view on Meta::CPAN

327
328
329
330
331
332
333
334
335
336
337
           $block->name ? $block->name : ()
          );
    }
}
 
sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

inc/Test/Base.pm  view on Meta::CPAN

340
341
342
343
344
345
346
347
348
349
350
           $block->name ? $block->name : ()
          );
    }
}
 
sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

inc/Test/Base.pm  view on Meta::CPAN

354
355
356
357
358
359
360
361
362
363
364
             $block->name ? $block->name : ()
            );
    }
}
 
sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

inc/Test/Base.pm  view on Meta::CPAN

480
481
482
483
484
485
486
487
488
489
490
        };
    }
    return $spec;
}
 
sub _strict_warnings() {
    require Filter::Util::Call;
    my $done = 0;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;

inc/Test/Base.pm  view on Meta::CPAN

502
503
504
505
506
507
508
509
510
511
            $done = 1;
        }
    );
}
 
sub tie_output() {
    my $handle = shift;
    die "No buffer to tie" unless @_;
    tie $handle, 'Test::Base::Handle', $_[0];
}

inc/Test/Base.pm  view on Meta::CPAN

514
515
516
517
518
519
520
521
522
523
524
    $ENV{TEST_SHOW_NO_DIFFS} = 1;
}
 
package Test::Base::Handle;
 
sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}
 
sub PRINT {

inc/Test/Base.pm  view on Meta::CPAN

537
538
539
540
541
542
543
544
545
546
547
 
sub AUTOLOAD {
    return;
}
 
sub block_accessor() {
    my $accessor = shift;
    no strict 'refs';
    return if defined &$accessor;
    *$accessor = sub {
        my $self = shift;

 view release on metacpan or  search on metacpan

inc/Test/More.pm  view on Meta::CPAN

114
115
116
117
118
119
120
121
122
123
}
 
 
#line 425
 
sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;
 
    $tb->cmp_ok(@_);
}

 view release on metacpan or  search on metacpan

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

130
131
132
133
134
135
136
137
138
139
(This is equivalent to using C<< Future->call >>, but is duplicated here for
completeness).
 
=cut
 
sub call(&)
{
   my ( $code ) = @_;
   return Future->call( $code );
}

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

160
161
162
163
164
165
166
167
168
169
(This can be considered similar to C<call-with-escape-continuation> as found
in some Scheme implementations).
 
=cut
 
sub call_with_escape(&)
{
   my ( $code ) = @_;
 
   my $escape_f = Future->new;

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

335
336
337
338
339
340
341
342
343
344
345
      # redo
      undef $$trialp;
   }
}
 
sub repeat(&@)
{
   my $code = shift;
   my %args = @_;
 
   # This makes it easier to account for other conditions

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

424
425
426
427
428
429
430
431
432
433
Code that specifically wishes to catch failures in trial futures and retry
the block should use C<try_repeat> specifically.
 
=cut
 
sub try_repeat(&@)
{
   # defeat prototype
   &repeat( @_, try => 1 );
}

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

445
446
447
448
449
450
451
452
453
454
455
This function used to be called C<repeat_until_success>, and is currently
aliased as this name as well.
 
=cut
 
sub try_repeat_until_success(&@)
{
   my $code = shift;
   my %args = @_;
 
   # TODO: maybe merge while/until conditions one day...

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

665
666
667
668
669
670
671
672
673
674
675
This function is also available under the name of simply C<fmap> to emphasise
its similarity to perl's C<map> keyword.
 
=cut
 
sub fmap_concat(&@)
{
   my $code = shift;
   my %args = @_;
 
   _fmap( $code, %args, collect => "array" )->then( sub {

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

693
694
695
696
697
698
699
700
701
702
703
 
This function is also available under the shorter name of C<fmap1>.
 
=cut
 
sub fmap_scalar(&@)
{
   my $code = shift;
   my %args = @_;
 
   _fmap( $code, %args, collect => "scalar" )

local/lib/perl5/Future/Utils.pm  view on Meta::CPAN

721
722
723
724
725
726
727
728
729
730
731
 
This function is also available under the shorter name of C<fmap0>.
 
=cut
 
sub fmap_void(&@)
{
   my $code = shift;
   my %args = @_;
 
   _fmap( $code, %args, collect => "void" )

 view release on metacpan or  search on metacpan

lib/Acme/Test/42.pm  view on Meta::CPAN

8
9
10
11
12
13
14
15
16
17
18
19
20
21
our @ISA = qw(Test::Builder::Module);
our @EXPORT = qw(ok not_ok);
 
my $CLASS = __PACKAGE__;
 
sub ok($;$) {
    return $CLASS->builder->ok($_[0] eq 42, $_[1]);
}
 
sub not_ok($;$) {
    return $CLASS->builder->ok($_[0] ne 42, $_[1]);
}
 
42;

 view release on metacpan or  search on metacpan

lib/Acme/Test/Buffy.pm  view on Meta::CPAN

68
69
70
71
72
73
74
75
76
77
78
# here's where we define the subroutine "is_buffy" that will be
# exported.  Note the prototype that does the right thing.  More
# can be found out about prototypes in the 'perlsub' perldoc.
# This one simply says "one scalar argument and possibly another"
 
sub is_buffy($;$)
{
  # simply call the other subroutine.  There's no reason why this
  # couldn't be done here, I just want to show how to call other
  # subroutines in this class.  This supplied a default test
  # description

 view release on metacpan or  search on metacpan

Tools.pm  view on Meta::CPAN

2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
 
    splice @$ar, binsearch($v,$ar,1,$Pushsort_cmpsub)+1, 0, $v;
  }
  0+@$ar
}
sub pushsortstr(\@@){ local $Pushsort_cmpsub=sub{$_[0]cmp$_[1]}; pushsort(@_) } #speedup: copy sub pushsort
 
=head2 binsearch
 
Returns the position of an element in a numerically sorted array. Returns undef if the element is not found.

Tools.pm  view on Meta::CPAN

3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
 print sort(uniq('a','dup','z','dup')); # better, probably what you meant
 print distinct('a','dup','z','dup'));  # same, distinct includes alphanumeric sort
 
=cut
 
sub uniq(@) { my %seen; grep !$seen{$_}++, @_ }
 
=head1 HASHES
 
=head2 subhash

Tools.pm  view on Meta::CPAN

6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
 my @arr = globr "{01..11}b";           # 01b 02b 03b 04b 05b 06b 07b 08b 09b 10b 11b (keep leading zero)
 my @arr = globr "{01..12..3}b";        # 01b 04b 07b 10b
 
=cut
 
sub globr($) {
  my $p=shift;
  $p=~s{
    \{(-?\w+)\.\.(-?\w+)(\.\.(-?\d+))?\}
  }{
    my $i=0;

Tools.pm  view on Meta::CPAN

7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
 sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" }
 
 
=cut
 
sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" }
 
=head2 recursed
 
Returns true or false (actually 1 or 0) depending on whether the
current sub has been called by itself or not.

 view release on metacpan or  search on metacpan

lib/Acme/VarMess.pm  view on Meta::CPAN

25
26
27
28
29
30
31
32
33
34
35
 
sub dont_blow {
    %invar = map{$_=>1} @_;
}
 
sub blow($$;$) {
    my ($src, $outputfile) = @_;
    my $doc;
    if(ref $src){
        $doc = PPI::Document->new($$src);
    }

 view release on metacpan or  search on metacpan

inc/Test/More.pm  view on Meta::CPAN

120
121
122
123
124
125
126
127
128
129
    return $tb->unlike(@_);
}
 
#line 471
 
sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;
 
    return $tb->cmp_ok(@_);
}

inc/Test/More.pm  view on Meta::CPAN

247
248
249
250
251
252
253
254
255
256
257
    return $obj;
}
 
#line 719
 
sub subtest($&) {
    my ($name, $subtests) = @_;
 
    my $tb = Test::More->builder;
    return $tb->subtest(@_);
}

 view release on metacpan or  search on metacpan

lib/Aion/Format.pm  view on Meta::CPAN

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
};
 
#@category Ловушки
 
# Ловушка для STDERR
sub trapperr(&) {
        my $sub = shift;
        local *STDERR;
        open STDERR, '>:utf8', \my $f;
        $sub->();
        close STDERR;
        $f
}
 
# Ловушка для STDOUT
sub trappout(&) {
        my $sub = shift;
        local *STDOUT;
        open STDOUT, '>:utf8', \my $f;
        $sub->();
        close STDOUT;

lib/Aion/Format.pm  view on Meta::CPAN

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
}
 
#@category Цвет
 
# Колоризирует текст escape-последовательностями: coloring("#{BOLD RED}ya#{}100!#RESET"), а затем - заменяет формат sprintf-ом
sub coloring(@) {
        my $s = shift;
        $s =~ s!#\{(?<x>[\w \t]*)\}|#(?<x>\w+)!
                my $x = $+{x};
                $x = "RESET" if $x ~~ [qw/r R/];
                Term::ANSIColor::color($x)
        !nge;
        sprintf $s, @_
}
 
# Печатает в STDOUT вывод coloring
sub printcolor(@) {
        print coloring @_
}
 
# Печатает в STDERR вывод coloring
sub warncolor(@) {
        print STDERR coloring @_
}
 
# Для крона: Пишет в STDOUT
sub accesslog(@) {
        print "[", POSIX::strftime("%F %T", localtime), "] ", coloring @_;
}
 
# Для крона: Пишет в STDIN
sub errorlog(@) {
        print STDERR "[", POSIX::strftime("%F %T", localtime), "] ", coloring @_;
}
 
 
#@category Преобразования
 
# Проводит соответствия
#
# matches "...", qr/.../ => sub {...}, ...
#
sub matches($@) {
        my $s = shift;
        my $i = 0;
        my $re = join "\n| ", map { $i++ % 2 == 0? "(?<I$i> $_ )": () } @_;
        my $arg = \@_;
        my $fn = sub {

lib/Aion/Format.pm  view on Meta::CPAN

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
        Ðµ e  н n  Ñ„ f  Ñ‹ y
        Ñ‘ jo о o  Ñ… kh ÑŒ q
        Ð¶ zh      
        Ð· z
/;
sub transliterate($) {
        my ($s) = @_;
        $s =~ s/[а-яё]/lc($&) eq $&? $TRANS{$&}: ucfirst $TRANS{lc $&}/gier;
}
 
# Транслитетрирует текст, оставляя только латинские буквы и тире
sub trans($) {
        my ($s) = @_;
        $s = transliterate $s;
        $s =~ s{[-\s_]+}{-}g;
        $s =~ s![^a-z-]!!gi;
        $s =~ s!^-*(.*?)-*\z!$1!;

lib/Aion/Format.pm  view on Meta::CPAN

142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
}
 
#@category Строки
 
# Преобразует в строку perl
sub to_str(;$) {
        my ($s) = @_ == 0? $_: @_;
        $s =~ s/[\\']/\\$&/g;
        $s =~ s/^(.*)\z/'$1'/s;
        $s
}
 
# Преобразует из строки perl
sub from_str(;$) {
        my ($s) = @_ == 0? $_: @_;
        $s =~ s/^'(.*)'\z/$1/s;
        $s =~ s/\\([\\'])/$1/g;
        $s
}
 
# Упрощённый язык регулярок
sub nous($) {
        my ($templates) = @_;
        my $x = join "|", map {
                matches $_,
                # Срезаем все пробелы с конца:
                qr!\s*$! => sub {},

lib/Aion/Format.pm  view on Meta::CPAN

192
193
194
195
196
197
198
199
200
201
202
         
        qr/$x/xsmn
}
 
# формирует человекочитабельный интервал
sub sinterval($) {
        my ($interval) = @_;
 
        if(0 == int $interval) {
                return sprintf "%.6f mks", $interval*1000_000 if 0 == int($interval*1000_000);
                return sprintf "%.7f ms", $interval*1000 if 0 == int($interval*1000);

lib/Aion/Format.pm  view on Meta::CPAN

218
219
220
221
222
223
224
225
226
227
228
our @RIM_CIF = (
        [ '', 'I', 'II', 'III', 'IV', 'V', 'VI', 'VII', 'VIII', 'IX' ],
        [ '', 'X', 'XX', 'XXX', 'XL', 'L', 'LX', 'LXX', 'LXXX', 'XC' ],
        [ '', 'C', 'CC', 'CCC', 'CD', 'D', 'DC', 'DCC', 'DCCC', 'CM' ]
);
sub rim($) {
        my ($a) = @_;
        use bigint; $a+=0;
        my $s;
        for ( ; $a != 0 ; $a = int( $a / 1000 ) ) {
                my $v = $a % 1000;

lib/Aion/Format.pm  view on Meta::CPAN

253
254
255
256
257
258
259
260
261
262
263
        " ", # пробел
        (map chr, 0 .. 0x1F, 0x7F), # управляющие символы ASCII
        # символ 152 (0x98) в cp1251 отсутствует.
;
# Переводит натуральное число в заданную систему счисления
sub to_radix($;$) {
        use bigint;
        my ($n, $radix) = @_;
        $radix //= 64;
        die "to_radix: The number system $radix is too large. Use NS before " . (1 + length $CIF) if $radix > length $CIF;
        $n+=0; $radix+=0;

lib/Aion/Format.pm  view on Meta::CPAN

270
271
272
273
274
275
276
277
278
279
280
        }
        return $x;
}
 
# Парсит натуральное число в указанной системе счисления
sub from_radix(@) {
        use bigint;
        my ($s, $radix) = @_;
        $radix //= 64;
        $radix+=0;
        die "from_radix: The number system $radix is too large. Use NS before " . (1 + length $CIF) if $radix > length $CIF;

lib/Aion/Format.pm  view on Meta::CPAN

284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
        }
        return $x;
}
 
# Округляет до указанного разряда числа
sub round($;$) {
        my ($x, $dec) = @_;
        $dec //= 0;
        my $prec = 10**$dec;
        int($x*$prec + 0.5) / $prec
}
 
 
#@category Меры (measure)
 
# добавляет разделители между разрядами числа
sub num($) {
        my ($s) = @_;
 
        my $sep = " "; # Неразрывный пробел
        my $dec = ".";

lib/Aion/Format.pm  view on Meta::CPAN

313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
        $x =~ s!$sep([+-]?)$!$1!;
        reverse($x) . $y;
}
 
# Добавляет разряды чисел и добавляет единицу измерения
sub kb_size($) {
        my ($n) = @_;
 
        return num(round($n / 1024 / 1024 / 1024)) . "G" if $n >= 1024 * 1024 * 1024;
        return num(round($n / 1024 / 1024)) . "M" if $n >= 1024 * 1024;
        return num(round($n / 1024)) . "k" if $n >= 1024;
 
        return num(round($n)) . "b";
}
 
# Оставляет $n цифр до и после точки: 10.11 = 10, 0.00012 = 0.00012, 1.2345 = 1.2, если $n = 2
sub sround($;$) {
        my ($number, $digits) = @_;
        $digits //= 2;
        my $num = sprintf("%.100f", $number);
        $num =~ /^-?0?(\d*)\.(0*)[1-9]/;
        return "" . round($num, $digits + length $2) if length($1) == 0;
        my $k = $digits - length $1;
        return "" . round($num, $k < 0? 0: $k);
}
 
# Кибибайт
sub KiB() { 2**10 }
 
# Мебибайт
sub MiB() { 2**20 }
 
# Гибибайт
sub GiB() { 2**30 }
 
# Тебибайт
sub TiB() { 2**40 }
 
# Максимум в данных TinyText Марии
sub xxS { 255 }
 
# Максимум в данных Text Марии

lib/Aion/Format.pm  view on Meta::CPAN

375
376
377
378
379
380
381
382
383
384
385
        20 => "для магистров",
        10 => "для профессионалов",
        0 => "для академиков",
);
 
sub flesch_index_human($) {
        my ($flesch_index) = @_;
        $FLESCH_INDEX_NAMES{int($flesch_index / 10) * 10} // "несвязный русский текст"
}
 
1;

 view release on metacpan or  search on metacpan

lib/Aion/Fs.pm  view on Meta::CPAN

32
33
34
35
36
37
38
39
40
41
42
43
        RISCOS  => 'riscos',
        MACOS   => 'macos',
        VMESA   => 'vmesa',
};
 
sub _fs();
sub _match($$) {
        my ($match, $fs) = @_;
        my @res; my @remove;
        my $trans = $fs->{before_split} // sub {$_[0]};
        for my $key (@$match) {
                next unless exists $_->{$key};

lib/Aion/Fs.pm  view on Meta::CPAN

55
56
57
58
59
60
61
62
63
64
65
        delete @res{keys %{$fs->{remove}->{$_}}} for @remove;
         
        return %res, %$_;
}
 
sub _join(@) {
        my ($match, @format) = @_;
        my $fs = _fs;
        my $trans = $fs->{before_split} // sub {$_[0]};
        my %f = _match $match, $fs;
        join "", List::Util::pairmap {

lib/Aion/Fs.pm  view on Meta::CPAN

363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
         
        my $x = $_;
        ref $_->{name}? (map { ($_ => $x) } @{$_->{name}}): ($_->{name} => $_)
} @FS;
 
sub _fs() { $FS{lc $^O} // $FS{unix} }
 
# Мы находимся в ОС семейства UNIX
sub isUNIX() { _fs->{name} eq "unix" }
 
# Разбивает директорию на составляющие
sub splitdir(;$) {
        my ($dir) = @_ == 0? $_: @_;
        ($dir) = @$dir if ref $dir;
        my $fs = _fs;
        $dir = $fs->{before_split}->($dir) if exists $fs->{before_split};
        split $fs->{symdirquote}, $dir, -1
}
 
# Объединяет директорию из составляющих
sub joindir(@) {
        join _fs->{symdir}, @_
}
 
# Разбивает расширение (тип файла) на составляющие
sub splitext(;$) {
        my ($ext) = @_ == 0? $_: @_;
        ($ext) = @$ext if ref $ext;
        split _fs->{symextquote}, $ext, -1
}
 
# Объединяет расширение (тип файла) из составляющих
sub joinext(@) {
        join _fs->{symext}, @_
}
 
 
# Выделяет в пути составляющие, а если получает хеш, то объединяет его в путь
sub path(;$) {
        my ($path) = @_ == 0? $_: @_;
         
        my $fs = _fs;
         
        if(ref $path eq "HASH") {

lib/Aion/Fs.pm  view on Meta::CPAN

487
488
489
490
491
492
493
494
495
496
497
         
        $path
}
 
# Считывает файл
sub cat(;$) {
    my ($file) = @_ == 0? $_: @_;
        my $layer = ":utf8";
        ($file, $layer) = @$file if ref $file;
        open my $f, "<$layer", $file or die "cat $file: $!";
        read $f, my $x, -s $f;

lib/Aion/Fs.pm  view on Meta::CPAN

536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
        BLKSIZE_NO      => 11,       # Размер блока ввода-вывода
        BLOCKS_NO       => 12,       # Количество выделенных блоков
};
 
# Вернуть время модификации файла
sub mtime(;$) {
        my ($file) = @_ == 0? $_: @_;
        ($file) = @$file if ref $file;
        (Time::HiRes::stat $file)[MTIME_NO] // die "mtime $file: $!"
}
 
# Информация о файле в виде хеша
sub sta(;$) {
        my ($path) = @_ == 0? $_: @_;
        ($path) = @$path if ref $path;
         
        my %sta = (path => $path);
        @sta{qw/dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks/} = Time::HiRes::stat $path or die "sta $path: $!";

lib/Aion/Fs.pm  view on Meta::CPAN

560
561
562
563
564
565
566
567
568
569
570
#       );
        \%sta
}
 
# Файловые фильтры
sub _filters(@) {
        map {
                if(ref $_ eq "CODE") {$_}
                elsif(ref $_ eq "Regexp") { my $re = $_; sub { $_ =~ $re } }
                elsif(/^-([a-z]+)$/) {
                        eval join "", "sub { ", (join " && ", map "-$_()", split //, $1), " }"

lib/Aion/Fs.pm  view on Meta::CPAN

572
573
574
575
576
577
578
579
580
581
582
                else { my $re = wildcard(); sub { $_ =~ $re } }
        } @_
}
 
# Найти файлы
sub find(;@) {
        my $file = @_? shift: $_;
    $file = [$file] unless ref $file;
 
        my @noenters; my $errorenter = sub {};
        my $ex = @_ && ref($_[$#_]) =~ /^Aion::Fs::(noenter|errorenter)\z/ ? pop: undef;

lib/Aion/Fs.pm  view on Meta::CPAN

633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
 
        wantarray? @ret: $count
}
 
# Не входить в подкаталоги
sub noenter(@) {
        bless [@_], "Aion::Fs::noenter"
}
 
# Вызывается для всех ошибок ввода-вывода
sub errorenter(&) {
        bless shift, "Aion::Fs::errorenter"
}
 
# Останавливает find будучи вызван с одного из его фильтров, errorenter или noenter
sub find_stop() {
        die bless {}, "Aion::Fs::stop"
}
 
# Производит замену во всех указанных файлах. Возвращает файлы в которых замен не было
sub replace(&@) {
    my $fn = shift;
        my @noreplace; local $_; my $pkg = caller;
        my $aref = "${pkg}::a"; my $bref = "${pkg}::b";
    for $$aref (@_) {
                if(ref $$aref) { ($$aref, $$bref) = @$$aref } else { $$bref = ":utf8" }

lib/Aion/Fs.pm  view on Meta::CPAN

662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
    }
        @noreplace
}
 
# Стирает все указанные файлы. Возвращает переданные файлы
sub erase(@) {
    -d? rmdir: unlink or die "erase ${\(-d? 'dir': 'file')} $_: $!" for @_;
        @_
}
 
# Переводит вилдкард в регулярку
sub wildcard(;$) {
        my ($wildcard) = @_;
        $wildcard = $_ if @_ == 0;
        $wildcard =~ s{
                (?<file> \*\*)
                | (?<path> \*)

lib/Aion/Fs.pm  view on Meta::CPAN

695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
        qr/^$wildcard$/ns
}
 
# Открывает файл на указанной строке в редакторе
use config EDITOR => "vscodium %p:%l";
sub goto_editor($$) {
        my ($path, $line) = @_;
        my $p = EDITOR;
        $p =~ s!%p!$path!;
        $p =~ s!%l!$line!;
        my $status = system $p;
        die "$path:$line --> $status" if $status;
        return;
}
 
# Из пакета в файловый путь
sub from_pkg(;$) {
        my ($pkg) = @_ == 0? $_: @_;
        $pkg =~ s!::!/!g;
        "$pkg.pm"
}
 
# Из файлового пути в пакет
sub to_pkg(;$) {
        my ($path) = @_ == 0? $_: @_;
        $path =~ s!\.\w+$!!;
        $path =~ s!/!::!g;
        $path
}
 
# Подключает модуль, если он ещё не подключён, и возвращает его
sub include(;$) {
        my ($pkg) = @_ == 0? $_: @_;
        return $pkg if $pkg->can("new") || $pkg->can("has");
        my $path = from_pkg $pkg;
        return $pkg if exists $INC{$path};
        require $path;

 view release on metacpan or  search on metacpan

lib/Aion/Query.pm  view on Meta::CPAN

33
34
35
36
37
38
39
40
41
42
43
        BQ => 1,
};
 
# Формирует DSN на основе конфига
our $DEFAULT_DSN;
sub default_dsn() {
        $DEFAULT_DSN //= do {
                if(defined DSN) {DSN}
                elsif(DRV =~ /mysql|mariadb/i) {
                        my $sock = SOCK;
                        $sock //= "/var/run/mysqld/mysqld.sock" if !defined HOST;

lib/Aion/Query.pm  view on Meta::CPAN

54
55
56
57
58
59
60
61
62
63
64
                else { die "Using DSN! DRV: ${\ DRV} is'nt supported." }
        }
}
 
my $CONN;
sub default_connect_options() {
    return default_dsn, USER, PASS, $CONN //= CONN // do {
                if(DRV =~ /mysql|mariadb/i) {[
                        "SET NAMES utf8",
                        "SET sql_mode='NO_AUTO_CREATE_USER,NO_ENGINE_SUBSTITUTION'",
                ]}

lib/Aion/Query.pm  view on Meta::CPAN

118
119
120
121
122
123
124
125
126
127
128
}
 
# Запросы к базе
 
our @DEBUG;
sub sql_debug(@) {
        my ($fn, $query) = @_;
        my $msg = "$fn: " . (ref $query? np($query): $query);
        push @DEBUG, $msg;
        print STDERR $msg, "\n" if DEBUG;
}

lib/Aion/Query.pm  view on Meta::CPAN

141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
#       $_[0]->{SQL_DEBUG} = \@DEBUG;
#       return;
# }
 
 
sub LAST_INSERT_ID() {
        $base->last_insert_id
}
 
# Преобразует в бинарную строку принятую в MYSQL
sub _to_hex_str($) {
        my ($s) = @_;
        no utf8;
        use bytes;
        $s =~ s/./sprintf "%02X", ord $&/gaes;
        "X'$s'"

lib/Aion/Query.pm  view on Meta::CPAN

166
167
168
169
170
171
172
173
174
175
176
177
        return $s unless BQ;
        $s =~ s/°|[^\Q$Aion::Format::CIF\E]/"°${\ to_radix(ord $&, 254) }\x7F"/ge;
        $s
}
 
sub quote(;$);
sub quote(;$) {
        my $k = @_ == 0? $_: $_[0];
        my $ref;
 
        !defined($k)? "NULL":
        ref $k eq "ARRAY" && ref $k->[0] eq "ARRAY"?

lib/Aion/Query.pm  view on Meta::CPAN

250
251
252
253
254
255
256
257
258
259
260
        !imgex;
        $query
}
 
# Выполняет sql-запрос
sub query_do($;$) {
        my ($query, $columns) = @_;
        sql_debug query => $query;
        connect_respavn($base, $base_connection_id);
 
        my $res = eval {

lib/Aion/Query.pm  view on Meta::CPAN

284
285
286
287
288
289
290
291
292
293
294
        die +(length($query)>MAX_QUERY_ERROR? substr($query, 0, MAX_QUERY_ERROR) . " ...": $query) . "\n\n$@" if $@;
 
        $res
}
 
sub query_ref(@) {
        my ($query, %kw) = @_;
        my $map = delete $kw{MAP};
        $query = query_prepare($query, %kw) if @_>1;
        my $res = query_do($query);
        if($map && ref $res eq "ARRAY") {

lib/Aion/Query.pm  view on Meta::CPAN

297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
        } else {
                $res
        }
}
 
sub query(@) {
        my $ref = query_ref(@_);
        wantarray && ref $ref? @$ref: $ref;
}
 
# Возвращает sth
sub query_sth(@) {
        my ($query, %kw) = @_;
        $query = query_prepare($query, %kw) if @_>1;
        my $sth = $base->prepare($query);
        $sth->execute;
        $sth

lib/Aion/Query.pm  view on Meta::CPAN

327
328
329
330
331
332
333
334
335
336
337
338
#
#       TODO: query_slice [] => word, "SELECT word, id FROM word WHERE word in (1,2,3)"              ->   [{id => 10, word => 1}, {id => 20, word => 2}]
#
#   TODO: [ "id", "name", "jinni" ] -> [{ id=>1, items => [{ name => "hi!", items => [{ jinni=>2, items => [{...}] }] }] }]
#
sub query_slice(@);
sub query_slice(@) {
        my ($key, $val, @args) = @_;
 
        my $is_array = ref $val eq "ARRAY" && @$val && ref $val->[0] eq "ARRAY";
 
        return $is_array? [ query_slice @_ ]: +{ query_slice @_ } if !wantarray;

lib/Aion/Query.pm  view on Meta::CPAN

395
396
397
398
399
400
401
402
403
404
405
 
# Выбрать один колумн
#
#   query_col "SELECT id FROM word WHERE word in (1,2,3)"       ->   [1,2,3]
#
sub query_col(@);
sub query_col(@) {
        return [query_col @_] if !wantarray;
 
        my $rows = query_ref(@_);
        die "Only one column is acceptable!" if @$rows and 1 != keys %{$rows->[0]};

lib/Aion/Query.pm  view on Meta::CPAN

409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
 
# Выбрать строку
#
#   query_row_ref "SELECT id, word FROM word WHERE word = 1"    ->   {id=>1, word=>"серебро"}
#
sub query_row_ref(@) {
        my $rows = query_ref(@_);
        die "A few lines!" if @$rows>1;
        $rows->[0]
}
 
# Выбрать строку
#
#   ($id, $word) = query_row_ref "SELECT id, word FROM word WHERE word = 1"
#
sub query_row(@) {
        return query_row_ref(@_) unless wantarray;
        my $sql = query_prepare(@_);
        my $rows  = query_do($sql, my $columns);
        die "A few lines!" if @$rows > 1;
        my $row = $rows->[0];

lib/Aion/Query.pm  view on Meta::CPAN

432
433
434
435
436
437
438
439
440
441
442
 
# Выбрать значение
#
#   query_scalar "SELECT word FROM word WHERE id = 1"   ->   "золото"
#
sub query_scalar(@) {
        my $rows = query_ref(@_);
        die "A few lines!" if @$rows>1;
        die "Only one column is acceptable! " . keys %{$rows->[0]} if @$rows and 1 != keys %{$rows->[0]};
        my ($k, $v) = %{$rows->[0]};
        $v

lib/Aion/Query.pm  view on Meta::CPAN

446
447
448
449
450
451
452
453
454
455
456
#
# ("concat(size,',',likes)", "(size < 10 OR size = 10 AND likes >= 12)", ["size", "likes"]) = make_query_for_order "size desc, likes", "10,12"
#
# ("concat(size,',',likes)", 1) = make_query_for_order "size desc, likes", ""
#
sub make_query_for_order(@) {
        my ($order, $next) = @_;
 
        my @orders = split /\s*,\s*/, $order;
        my @order_direct;
        my @order_sel = map { my $x=$_; push @order_direct, $x=~s/\s+(asc|desc)\s*$//ie ? lc $1: "asc"; $x } @orders;

lib/Aion/Query.pm  view on Meta::CPAN

489
490
491
492
493
494
495
496
497
498
499
 
        return $select, "($where)", \@order_sel;
}
 
# Устанавливает или возвращает ключ из таблицы settings
sub settings($;$) {
        my ($id, $value) = @_;
        if(@_ == 1) {
                my $v = query_scalar("SELECT value FROM settings WHERE id=:id", id => $id);
                return defined($v)? Aion::Format::Json::from_json($v): $v;
        }

lib/Aion/Query.pm  view on Meta::CPAN

505
506
507
508
509
510
511
512
513
514
                value => Aion::Format::Json::to_json($value),
        );
}
 
# возвращает запись по её pk
sub load_by_id(@) {
        my ($tab, $pk, $fields, @options) = @_;
        $fields //= "*";
        query_row("SELECT $fields FROM $tab WHERE id=:id LIMIT 2", @options, id=>$pk)
}

lib/Aion/Query.pm  view on Meta::CPAN

518
519
520
521
522
523
524
525
526
527
528
        my ($dbh, $drv) = @_;
        $dbh->{Driver}{Name} =~ /^($drv)/ain
}
 
# Добавляет запись и возвращает её id
sub insert(@) {
        my ($tab, %x) = @_;
        if(_check_drv($base, "mysql|mariadb")) {
                query "INSERT INTO $tab SET :set", set => \%x;
        } else {
                stores($tab, [\%x], insert => 1);

lib/Aion/Query.pm  view on Meta::CPAN

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
 
# Обновляет запись по её id
#
#       update "tab" => 123, word => 123                                          -> 6
#
sub update(@) {
        my ($tab, $id, %x) = @_;
        die "Row $tab.id=$id is not!" if !query "UPDATE $tab SET :set WHERE id=:id", id=>$id, set => \%x;
        $id
}
 
# Удаляет запись по её id
#
#       remove "tab" => 123          -> 123
#
sub remove(@) {
        my ($tab, $id) = @_;
        die "Row $tab.id=$id does not exist!" if !query "DELETE FROM $tab WHERE id=:id", id=>$id;
        $id
}
 
# Возвращает ключ по другим полям
#
#       query_id "tab", word => 123                                          -> 6
#
sub query_id(@) {
        my $tab = shift; my %row = @_;
 
        my $pk = delete($row{'-pk'}) // "id";
        my $fields = ref $pk? join(", ", @$pk): $pk;

lib/Aion/Query.pm  view on Meta::CPAN

570
571
572
573
574
575
576
577
578
579
580
 
# UPSERT: сохраняет данные (update или insert)
#
#       stores "tab", [{word=>1}, {word=>2}];
#
sub stores(@);
sub stores(@) {
        my ($tab, $rows, %opt) = @_;
 
        my ($ignore, $insert) = delete @opt{qw/ignore insert/};
        die "Keys ${\ join('', )}" if keys %opt;

lib/Aion/Query.pm  view on Meta::CPAN

632
633
634
635
636
637
638
639
640
641
642
        my $tab = shift;
        stores $tab, [+{@_}];
}
 
# Сверхмощная функция: возвращает pk, а если его нет - создаёт или обновляет запись и всё равно возвращает
sub touch(@) {
        my $sub;
        $sub = pop @_ if ref $_[$#_] eq "CODE";
 
        my $pk = query_id @_;
        return $pk if defined $pk;

 view release on metacpan or  search on metacpan

lib/Aion/Spirit.pm  view on Meta::CPAN

15
16
17
18
19
20
21
22
23
24
25
 
#@category Аспект-ориентированное программирование
 
# Оборачивает функции в пакете в указанную по регулярке. 
# Имя функции идёт вместе с пакетом
sub aroundsub($$;$) {
        my ($pkg, $re, $around) = @_==3? @_: (scalar caller, @_);
        my $x = \%{"${pkg}::"};
 
        for my $g (values %$x) {
                next if ref \$g ne "GLOB";

lib/Aion/Spirit.pm  view on Meta::CPAN

30
31
32
33
34
35
36
37
38
39
40
                }
        }
}
 
# Оборачивает функцию в другую
sub wrapsub($$) {
        my ($sub, $around) = @_;
 
        my $s = sub { unshift @_, $sub; goto &$around };
 
        my $subname = Sub::Util::subname $sub;

 view release on metacpan or  search on metacpan

lib/Aion/Surf.pm  view on Meta::CPAN

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
$ua->cookie_jar(HTTP::Cookies->new);
 
# Между вызовами делаем случайный интервал (для граббинга - чтобы не быть заблокированным за автоматические обращения)
our $SLEEP = 0;
our $LAST_REQUEST = Time::HiRes::time();
sub _sleep(;$) {
        Time::HiRes::sleep(rand + .5) if Time::HiRes::time() - $LAST_REQUEST < 2;
        $LAST_REQUEST = Time::HiRes::time();
}
 
sub surf(@) {
        my $method = $_[0] =~ /^(\w+)\z/ ? shift: "GET";
        my $url = shift;
        my $headers;
        my $data = ref $_[0]? shift: undef;
        $headers = $data, undef $data if $method =~ /^(GET|HEAD)\z/n;

lib/Aion/Surf.pm  view on Meta::CPAN

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
 
sub head (;$) { my $x = @_ == 0? $_: shift;     surf HEAD   => ref $x? @{$x}: $x }
sub get  (;$) { my $x = @_ == 0? $_: shift; surf GET    => ref $x? @{$x}: $x }
sub post (@)  { my $x = @_ == 0? $_: \@_;   surf POST   => ref $x? @{$x}: $x }
sub put  (@)  { my $x = @_ == 0? $_: \@_;   surf PUT    => ref $x? @{$x}: $x }
sub patch(@)  { my $x = @_ == 0? $_: \@_;   surf PATCH  => ref $x? @{$x}: $x }
sub del  (;$) { my $x = @_ == 0? $_: shift; surf DELETE => ref $x? @{$x}: $x }
 
 
use config TELEGRAM_BOT_TOKEN => undef;
 
# Отправляет сообщение телеграм
sub chat_message($$) {
        my ($chat_id, $message) = @_;
 
        my $ok = post "https://api.telegram.org/bot${\ TELEGRAM_BOT_TOKEN}/sendMessage", response => \my $response, json => {
                chat_id => $chat_id,
                text => $message,

lib/Aion/Surf.pm  view on Meta::CPAN

174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
 
use config TELEGRAM_BOT_CHAT_ID => undef;
use config TELEGRAM_BOT_TECH_ID => undef;
 
# Отправляет сообщение в телеграм-бот
sub bot_message(;$) { chat_message TELEGRAM_BOT_CHAT_ID, @_ == 0? $_: $_[0] }
# Отправляет сообщение в технический телеграм канал
sub tech_message(;$) { chat_message TELEGRAM_BOT_TECH_ID, @_ == 0? $_: $_[0] }
 
 
# Получает последние сообщения отправленные боту
sub bot_update() {
        my @updates;
 
        for(my $offset = 0;;) {
 
                my $ok = post "https://api.telegram.org/bot${\ TELEGRAM_BOT_TOKEN}/getUpdates", json => {