File Coverage

blib/lib/Einformixv6als.pm
Criterion Covered Total %
statement 1206 4693 25.7
branch 1360 4684 29.0
condition 162 496 32.6
subroutine 68 190 35.7
pod 8 148 5.4
total 2804 10211 27.4


line stmt bran cond sub pod time code
1             package Einformixv6als;
2 389     389   12229 use strict;
  389         2617  
  389         14725  
3             ######################################################################
4             #
5             # Einformixv6als - Run-time routines for INFORMIXV6ALS.pm
6             #
7             # http://search.cpan.org/dist/Char-INFORMIXV6ALS/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 389     389   7378 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         1379  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 389     389   3789 use vars qw($VERSION);
  389         729  
  389         57426  
28             $VERSION = '1.15';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   6303 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         2226 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         53333 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 389     389   34130 CORE::eval q{
  389     389   2563  
  389     144   2646  
  389         45178  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 389 50       149897 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0 0   0 0 0 if ($] < 5.006) {
69 0         0 return \do { local *_ };
  0         0  
70             }
71             else {
72 0         0 return undef;
73             }
74             }
75              
76             sub qualify ($$) {
77 0     1152 0 0 my($name) = @_;
78              
79 1152 50       3016 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
80 1152         4780 return $name;
81             }
82             elsif (Einformixv6als::index($name,'::') >= 0) {
83 0         0 return $name;
84             }
85             elsif (Einformixv6als::index($name,"'") >= 0) {
86 0         0 return $name;
87             }
88              
89             # special character, "^xyz"
90             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
91              
92             # RGS 2001-11-05 : translate leading ^X to control-char
93 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
94 0         0 return 'main::' . $name;
95             }
96              
97             # Global names
98             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             # or other
103             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
104 0         0 return 'main::' . $name;
105             }
106              
107             elsif (defined $_[1]) {
108 0         0 return $_[1] . '::' . $name;
109             }
110             else {
111 1152         10009 return (caller)[0] . '::' . $name;
112             }
113             }
114              
115             sub qualify_to_ref ($;$) {
116 0 50   1152 0 0 if (defined $_[1]) {
117 389     389   4752 no strict qw(refs);
  389         4643  
  389         29526  
118 1152         3820 return \*{ qualify $_[0], $_[1] };
  0         0  
119             }
120             else {
121 389     389   2477 no strict qw(refs);
  389     0   4537  
  389         74268  
122 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         2139  
123             }
124             }
125             }
126              
127             # P.714 29.2.39. flock
128             # in Chapter 29: Functions
129             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
130              
131             # P.863 flock
132             # in Chapter 27: Functions
133             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
134              
135             sub LOCK_SH() {1}
136             sub LOCK_EX() {2}
137             sub LOCK_UN() {8}
138             sub LOCK_NB() {4}
139              
140             # instead of Carp.pm
141             sub carp;
142             sub croak;
143             sub cluck;
144             sub confess;
145              
146             # 6.18. Matching Multiple-Byte Characters
147             # in Chapter 6. Pattern Matching
148             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
149             # (and so on)
150              
151             # regexp of character
152             my $your_char = q{[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]|[\x00-\xFF]};
153 389     389   4801 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         2592  
  389         27910  
154 389     389   4499 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         834  
  389         633678  
155              
156             #
157             # INFORMIX V6 ALS character range per length
158             #
159             my %range_tr = ();
160              
161             #
162             # INFORMIX V6 ALS case conversion
163             #
164             my %lc = ();
165             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
166             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
167             my %uc = ();
168             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
169             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
170             my %fc = ();
171             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
172             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
173              
174             if (0) {
175             }
176              
177             elsif (__PACKAGE__ =~ / \b Einformixv6als \z/oxms) {
178             %range_tr = (
179             1 => [ [0x00..0x80],
180             [0xA0..0xDF],
181             [0xFE..0xFF],
182             ],
183             2 => [ [0x81..0x9F],[0x40..0x7E],
184             [0x81..0x9F],[0x80..0xFC],
185             [0xE0..0xFC],[0x40..0x7E],
186             [0xE0..0xFC],[0x80..0xFC],
187             ],
188             3 => [ [0xFD..0xFD],[0xA1..0xFE],[0xA1..0xFE],
189             ],
190             );
191             }
192              
193             else {
194             croak "Don't know my package name '@{[__PACKAGE__]}'";
195             }
196              
197             #
198             # @ARGV wildcard globbing
199             #
200             sub import {
201              
202 1152 50   5   6293 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
203 5         87 my @argv = ();
204 0         0 for (@ARGV) {
205              
206             # has space
207 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
208 0 0       0 if (my @glob = Einformixv6als::glob(qq{"$_"})) {
209 0         0 push @argv, @glob;
210             }
211             else {
212 0         0 push @argv, $_;
213             }
214             }
215              
216             # has wildcard metachar
217             elsif (/\A (?:$q_char)*? [*?] /oxms) {
218 0 0       0 if (my @glob = Einformixv6als::glob($_)) {
219 0         0 push @argv, @glob;
220             }
221             else {
222 0         0 push @argv, $_;
223             }
224             }
225              
226             # no wildcard globbing
227             else {
228 0         0 push @argv, $_;
229             }
230             }
231 0         0 @ARGV = @argv;
232             }
233              
234 0         0 *Char::ord = \&INFORMIXV6ALS::ord;
235 5         31 *Char::ord_ = \&INFORMIXV6ALS::ord_;
236 5         13 *Char::reverse = \&INFORMIXV6ALS::reverse;
237 5         15 *Char::getc = \&INFORMIXV6ALS::getc;
238 5         10 *Char::length = \&INFORMIXV6ALS::length;
239 5         12 *Char::substr = \&INFORMIXV6ALS::substr;
240 5         11 *Char::index = \&INFORMIXV6ALS::index;
241 5         9 *Char::rindex = \&INFORMIXV6ALS::rindex;
242 5         12 *Char::eval = \&INFORMIXV6ALS::eval;
243 5         35 *Char::escape = \&INFORMIXV6ALS::escape;
244 5         12 *Char::escape_token = \&INFORMIXV6ALS::escape_token;
245 5         92 *Char::escape_script = \&INFORMIXV6ALS::escape_script;
246             }
247              
248             # P.230 Care with Prototypes
249             # in Chapter 6: Subroutines
250             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
251             #
252             # If you aren't careful, you can get yourself into trouble with prototypes.
253             # But if you are careful, you can do a lot of neat things with them. This is
254             # all very powerful, of course, and should only be used in moderation to make
255             # the world a better place.
256              
257             # P.332 Care with Prototypes
258             # in Chapter 7: Subroutines
259             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
260             #
261             # If you aren't careful, you can get yourself into trouble with prototypes.
262             # But if you are careful, you can do a lot of neat things with them. This is
263             # all very powerful, of course, and should only be used in moderation to make
264             # the world a better place.
265              
266             #
267             # Prototypes of subroutines
268             #
269       0     sub unimport {}
270             sub Einformixv6als::split(;$$$);
271             sub Einformixv6als::tr($$$$;$);
272             sub Einformixv6als::chop(@);
273             sub Einformixv6als::index($$;$);
274             sub Einformixv6als::rindex($$;$);
275             sub Einformixv6als::lcfirst(@);
276             sub Einformixv6als::lcfirst_();
277             sub Einformixv6als::lc(@);
278             sub Einformixv6als::lc_();
279             sub Einformixv6als::ucfirst(@);
280             sub Einformixv6als::ucfirst_();
281             sub Einformixv6als::uc(@);
282             sub Einformixv6als::uc_();
283             sub Einformixv6als::fc(@);
284             sub Einformixv6als::fc_();
285             sub Einformixv6als::ignorecase;
286             sub Einformixv6als::classic_character_class;
287             sub Einformixv6als::capture;
288             sub Einformixv6als::chr(;$);
289             sub Einformixv6als::chr_();
290             sub Einformixv6als::filetest;
291             sub Einformixv6als::r(;*@);
292             sub Einformixv6als::w(;*@);
293             sub Einformixv6als::x(;*@);
294             sub Einformixv6als::o(;*@);
295             sub Einformixv6als::R(;*@);
296             sub Einformixv6als::W(;*@);
297             sub Einformixv6als::X(;*@);
298             sub Einformixv6als::O(;*@);
299             sub Einformixv6als::e(;*@);
300             sub Einformixv6als::z(;*@);
301             sub Einformixv6als::s(;*@);
302             sub Einformixv6als::f(;*@);
303             sub Einformixv6als::d(;*@);
304             sub Einformixv6als::l(;*@);
305             sub Einformixv6als::p(;*@);
306             sub Einformixv6als::S(;*@);
307             sub Einformixv6als::b(;*@);
308             sub Einformixv6als::c(;*@);
309             sub Einformixv6als::u(;*@);
310             sub Einformixv6als::g(;*@);
311             sub Einformixv6als::k(;*@);
312             sub Einformixv6als::T(;*@);
313             sub Einformixv6als::B(;*@);
314             sub Einformixv6als::M(;*@);
315             sub Einformixv6als::A(;*@);
316             sub Einformixv6als::C(;*@);
317             sub Einformixv6als::filetest_;
318             sub Einformixv6als::r_();
319             sub Einformixv6als::w_();
320             sub Einformixv6als::x_();
321             sub Einformixv6als::o_();
322             sub Einformixv6als::R_();
323             sub Einformixv6als::W_();
324             sub Einformixv6als::X_();
325             sub Einformixv6als::O_();
326             sub Einformixv6als::e_();
327             sub Einformixv6als::z_();
328             sub Einformixv6als::s_();
329             sub Einformixv6als::f_();
330             sub Einformixv6als::d_();
331             sub Einformixv6als::l_();
332             sub Einformixv6als::p_();
333             sub Einformixv6als::S_();
334             sub Einformixv6als::b_();
335             sub Einformixv6als::c_();
336             sub Einformixv6als::u_();
337             sub Einformixv6als::g_();
338             sub Einformixv6als::k_();
339             sub Einformixv6als::T_();
340             sub Einformixv6als::B_();
341             sub Einformixv6als::M_();
342             sub Einformixv6als::A_();
343             sub Einformixv6als::C_();
344             sub Einformixv6als::glob($);
345             sub Einformixv6als::glob_();
346             sub Einformixv6als::lstat(*);
347             sub Einformixv6als::lstat_();
348             sub Einformixv6als::opendir(*$);
349             sub Einformixv6als::stat(*);
350             sub Einformixv6als::stat_();
351             sub Einformixv6als::unlink(@);
352             sub Einformixv6als::chdir(;$);
353             sub Einformixv6als::do($);
354             sub Einformixv6als::require(;$);
355             sub Einformixv6als::telldir(*);
356              
357             sub INFORMIXV6ALS::ord(;$);
358             sub INFORMIXV6ALS::ord_();
359             sub INFORMIXV6ALS::reverse(@);
360             sub INFORMIXV6ALS::getc(;*@);
361             sub INFORMIXV6ALS::length(;$);
362             sub INFORMIXV6ALS::substr($$;$$);
363             sub INFORMIXV6ALS::index($$;$);
364             sub INFORMIXV6ALS::rindex($$;$);
365             sub INFORMIXV6ALS::escape(;$);
366              
367             #
368             # Regexp work
369             #
370 389         42978 use vars qw(
371             $re_a
372             $re_t
373             $re_n
374             $re_r
375 389     389   4975 );
  389         784  
376              
377             #
378             # Character class
379             #
380 389         105123 use vars qw(
381             $dot
382             $dot_s
383             $eD
384             $eS
385             $eW
386             $eH
387             $eV
388             $eR
389             $eN
390             $not_alnum
391             $not_alpha
392             $not_ascii
393             $not_blank
394             $not_cntrl
395             $not_digit
396             $not_graph
397             $not_lower
398             $not_lower_i
399             $not_print
400             $not_punct
401             $not_space
402             $not_upper
403             $not_upper_i
404             $not_word
405             $not_xdigit
406             $eb
407             $eB
408 389     389   4173 );
  389         3730  
409              
410 389         4398351 use vars qw(
411             $anchor
412             $matched
413 389     389   3862 );
  389         2390  
414             ${Einformixv6als::anchor} = qr{\G(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])*?}oxms;
415              
416             # unless LONG_STRING_FOR_RE
417             if (1) {
418             }
419              
420             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
421              
422             # Quantifiers
423             # {n,m} --- Match at least n but not more than m times
424             #
425             # n and m are limited to non-negative integral values less than a
426             # preset limit defined when perl is built. This is usually 32766 on
427             # the most common platforms.
428             #
429             # The following code is an attempt to solve the above limitations
430             # in a multi-byte anchoring.
431              
432             # avoid "Segmentation fault" and "Error: Parse exception"
433              
434             # perl5101delta
435             # http://perldoc.perl.org/perl5101delta.html
436             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
437             # [RT #60034, #60464]. For example, this match would fail:
438             # ("ab" x 32768) =~ /^(ab)*$/
439              
440             # SEE ALSO
441             #
442             # Complex regular subexpression recursion limit
443             # http://www.perlmonks.org/?node_id=810857
444             #
445             # regexp iteration limits
446             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
447             #
448             # latest Perl won't match certain regexes more than 32768 characters long
449             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
450             #
451             # Break through the limitations of regular expressions of Perl
452             # http://d.hatena.ne.jp/gfx/20110212/1297512479
453              
454             if (($] >= 5.010001) or
455             # ActivePerl 5.6 or later (include 5.10.0)
456             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
457             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
458             ) {
459             my $sbcs = ''; # Single Byte Character Set
460             for my $range (@{ $range_tr{1} }) {
461             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
462             }
463              
464             if (0) {
465             }
466              
467             # INFORMIX V6 ALS encoding
468             elsif (__PACKAGE__ =~ / \b Einformixv6als \z/oxms) {
469             ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[\x00-\x80\xA0-\xDF\xFF](?>[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x40-\x7E\x80-\xFC]|\xFD[\xA1-\xFE][\xA1-\xFE]|\xFE)*?}oxms;
470             # ************************ octets not in multiple octet char (always char boundary)
471             # **************************************** 2 octet chars
472             # ************************** 3 octet chars
473             # **** malformed octet?
474             }
475              
476             # other encoding
477             else {
478             ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
479             # ******* octets not in multiple octet char (always char boundary)
480             # **************** 2 octet chars
481             }
482              
483             ${Einformixv6als::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
484             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
485             # qr{
486             # \G # (1), (2)
487             # (? # (3)
488             # (?=.{0,32766}\z) # (4)
489             # (?:[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])*?| # (5)
490             # (?(?=[$sbcs]+\z) # (6)
491             # .*?| #(7)
492             # (?:${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
493             # ))}oxms;
494              
495             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
496             local $^W = 0;
497              
498             if (((('A' x 32768).'B') !~ / ${Einformixv6als::anchor} B /oxms) and
499             ((('A' x 32768).'B') =~ / ${Einformixv6als::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
500             ) {
501             ${Einformixv6als::anchor} = ${Einformixv6als::anchor_SADAHIRO_Tomoyuki_2002_01_17};
502             }
503             else {
504             undef ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17};
505             }
506             }
507              
508             # (1)
509             # P.128 Start of match (or end of previous match): \G
510             # P.130 Advanced Use of \G with Perl
511             # in Chapter3: Over view of Regular Expression Features and Flavors
512             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
513              
514             # (2)
515             # P.255 Use leading anchors
516             # P.256 Expose ^ and \G at the front of expressions
517             # in Chapter6: Crafting an Efficient Expression
518             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
519              
520             # (3)
521             # P.138 Conditional: (? if then| else)
522             # in Chapter3: Over view of Regular Expression Features and Flavors
523             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
524              
525             # (4)
526             # perlre
527             # http://perldoc.perl.org/perlre.html
528             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
529             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
530             # integral values less than a preset limit defined when perl is built.
531             # This is usually 32766 on the most common platforms. The actual limit
532             # can be seen in the error message generated by code such as this:
533             # $_ **= $_ , / {$_} / for 2 .. 42;
534              
535             # (5)
536             # P.1023 Multiple-Byte Anchoring
537             # in Appendix W Perl Code Examples
538             # of ISBN 1-56592-224-7 CJKV Information Processing
539              
540             # (6)
541             # if string has only SBCS (Single Byte Character Set)
542              
543             # (7)
544             # then .*? (isn't limited to 32766)
545              
546             # (8)
547             # else INFORMIX V6 ALS::Regexp::Const (SADAHIRO Tomoyuki)
548             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
549             # http://search.cpan.org/~sadahiro/INFORMIX V6 ALS-Regexp/
550             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE]{2})*?';
551             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE]{2})*?';
552             # $PadGA = '\G(?:\A|(?:[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE]{2})*?)';
553              
554             ${Einformixv6als::dot} = qr{(?>[^\x81-\x9F\xE0-\xFD\x0A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
555             ${Einformixv6als::dot_s} = qr{(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
556             ${Einformixv6als::eD} = qr{(?>[^\x81-\x9F\xE0-\xFD0-9]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
557              
558             # Vertical tabs are now whitespace
559             # \s in a regex now matches a vertical tab in all circumstances.
560             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
561             # ${Einformixv6als::eS} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x0A \x0C\x0D\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
562             # ${Einformixv6als::eS} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
563             ${Einformixv6als::eS} = qr{(?>[^\x81-\x9F\xE0-\xFD\s]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
564              
565             ${Einformixv6als::eW} = qr{(?>[^\x81-\x9F\xE0-\xFD0-9A-Z_a-z]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
566             ${Einformixv6als::eH} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
567             ${Einformixv6als::eV} = qr{(?>[^\x81-\x9F\xE0-\xFD\x0A\x0B\x0C\x0D]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
568             ${Einformixv6als::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
569             ${Einformixv6als::eN} = qr{(?>[^\x81-\x9F\xE0-\xFD\x0A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
570             ${Einformixv6als::not_alnum} = qr{(?>[^\x81-\x9F\xE0-\xFD\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
571             ${Einformixv6als::not_alpha} = qr{(?>[^\x81-\x9F\xE0-\xFD\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
572             ${Einformixv6als::not_ascii} = qr{(?>[^\x81-\x9F\xE0-\xFD\x00-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
573             ${Einformixv6als::not_blank} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
574             ${Einformixv6als::not_cntrl} = qr{(?>[^\x81-\x9F\xE0-\xFD\x00-\x1F\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
575             ${Einformixv6als::not_digit} = qr{(?>[^\x81-\x9F\xE0-\xFD\x30-\x39]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
576             ${Einformixv6als::not_graph} = qr{(?>[^\x81-\x9F\xE0-\xFD\x21-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
577             ${Einformixv6als::not_lower} = qr{(?>[^\x81-\x9F\xE0-\xFD\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
578             ${Einformixv6als::not_lower_i} = qr{(?>[^\x81-\x9F\xE0-\xFD\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
579             # ${Einformixv6als::not_lower_i} = qr{(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])}; # older Perl compatible
580             ${Einformixv6als::not_print} = qr{(?>[^\x81-\x9F\xE0-\xFD\x20-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
581             ${Einformixv6als::not_punct} = qr{(?>[^\x81-\x9F\xE0-\xFD\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
582             ${Einformixv6als::not_space} = qr{(?>[^\x81-\x9F\xE0-\xFD\s\x0B]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
583             ${Einformixv6als::not_upper} = qr{(?>[^\x81-\x9F\xE0-\xFD\x41-\x5A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
584             ${Einformixv6als::not_upper_i} = qr{(?>[^\x81-\x9F\xE0-\xFD\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
585             # ${Einformixv6als::not_upper_i} = qr{(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])}; # older Perl compatible
586             ${Einformixv6als::not_word} = qr{(?>[^\x81-\x9F\xE0-\xFD\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
587             ${Einformixv6als::not_xdigit} = qr{(?>[^\x81-\x9F\xE0-\xFD\x30-\x39\x41-\x46\x61-\x66]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
588             ${Einformixv6als::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
589             ${Einformixv6als::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
590              
591             # avoid: Name "Einformixv6als::foo" used only once: possible typo at here.
592             ${Einformixv6als::dot} = ${Einformixv6als::dot};
593             ${Einformixv6als::dot_s} = ${Einformixv6als::dot_s};
594             ${Einformixv6als::eD} = ${Einformixv6als::eD};
595             ${Einformixv6als::eS} = ${Einformixv6als::eS};
596             ${Einformixv6als::eW} = ${Einformixv6als::eW};
597             ${Einformixv6als::eH} = ${Einformixv6als::eH};
598             ${Einformixv6als::eV} = ${Einformixv6als::eV};
599             ${Einformixv6als::eR} = ${Einformixv6als::eR};
600             ${Einformixv6als::eN} = ${Einformixv6als::eN};
601             ${Einformixv6als::not_alnum} = ${Einformixv6als::not_alnum};
602             ${Einformixv6als::not_alpha} = ${Einformixv6als::not_alpha};
603             ${Einformixv6als::not_ascii} = ${Einformixv6als::not_ascii};
604             ${Einformixv6als::not_blank} = ${Einformixv6als::not_blank};
605             ${Einformixv6als::not_cntrl} = ${Einformixv6als::not_cntrl};
606             ${Einformixv6als::not_digit} = ${Einformixv6als::not_digit};
607             ${Einformixv6als::not_graph} = ${Einformixv6als::not_graph};
608             ${Einformixv6als::not_lower} = ${Einformixv6als::not_lower};
609             ${Einformixv6als::not_lower_i} = ${Einformixv6als::not_lower_i};
610             ${Einformixv6als::not_print} = ${Einformixv6als::not_print};
611             ${Einformixv6als::not_punct} = ${Einformixv6als::not_punct};
612             ${Einformixv6als::not_space} = ${Einformixv6als::not_space};
613             ${Einformixv6als::not_upper} = ${Einformixv6als::not_upper};
614             ${Einformixv6als::not_upper_i} = ${Einformixv6als::not_upper_i};
615             ${Einformixv6als::not_word} = ${Einformixv6als::not_word};
616             ${Einformixv6als::not_xdigit} = ${Einformixv6als::not_xdigit};
617             ${Einformixv6als::eb} = ${Einformixv6als::eb};
618             ${Einformixv6als::eB} = ${Einformixv6als::eB};
619              
620             #
621             # INFORMIX V6 ALS split
622             #
623             sub Einformixv6als::split(;$$$) {
624              
625             # P.794 29.2.161. split
626             # in Chapter 29: Functions
627             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
628              
629             # P.951 split
630             # in Chapter 27: Functions
631             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
632              
633 5     0 0 11719 my $pattern = $_[0];
634 0         0 my $string = $_[1];
635 0         0 my $limit = $_[2];
636              
637             # if $pattern is also omitted or is the literal space, " "
638 0 0       0 if (not defined $pattern) {
639 0         0 $pattern = ' ';
640             }
641              
642             # if $string is omitted, the function splits the $_ string
643 0 0       0 if (not defined $string) {
644 0 0       0 if (defined $_) {
645 0         0 $string = $_;
646             }
647             else {
648 0         0 $string = '';
649             }
650             }
651              
652 0         0 my @split = ();
653              
654             # when string is empty
655 0 0       0 if ($string eq '') {
    0          
656              
657             # resulting list value in list context
658 0 0       0 if (wantarray) {
659 0         0 return @split;
660             }
661              
662             # count of substrings in scalar context
663             else {
664 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
665 0         0 @_ = @split;
666 0         0 return scalar @_;
667             }
668             }
669              
670             # split's first argument is more consistently interpreted
671             #
672             # After some changes earlier in v5.17, split's behavior has been simplified:
673             # if the PATTERN argument evaluates to a string containing one space, it is
674             # treated the way that a literal string containing one space once was.
675             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
676              
677             # if $pattern is also omitted or is the literal space, " ", the function splits
678             # on whitespace, /\s+/, after skipping any leading whitespace
679             # (and so on)
680              
681             elsif ($pattern eq ' ') {
682 0 0       0 if (not defined $limit) {
683 0         0 return CORE::split(' ', $string);
684             }
685             else {
686 0         0 return CORE::split(' ', $string, $limit);
687             }
688             }
689              
690 0         0 local $q_char = $q_char;
691 0 0       0 if (CORE::length($string) > 32766) {
692 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
693 0         0 $q_char = qr{.}s;
694             }
695             elsif (defined ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
696 0         0 $q_char = ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17};
697             }
698             }
699              
700             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
701 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
702              
703             # a pattern capable of matching either the null string or something longer than the
704             # null string will split the value of $string into separate characters wherever it
705             # matches the null string between characters
706             # (and so on)
707              
708 0 0       0 if ('' =~ / \A $pattern \z /xms) {
709 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
710 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
711              
712             # P.1024 Appendix W.10 Multibyte Processing
713             # of ISBN 1-56592-224-7 CJKV Information Processing
714             # (and so on)
715              
716             # the //m modifier is assumed when you split on the pattern /^/
717             # (and so on)
718              
719             # V
720 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
721              
722             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
723             # is included in the resulting list, interspersed with the fields that are ordinarily returned
724             # (and so on)
725              
726 0         0 local $@;
727 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
728 0         0 push @split, CORE::eval('$' . $digit);
729             }
730             }
731             }
732              
733             else {
734 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
735              
736             # V
737 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
738 0         0 local $@;
739 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
740 0         0 push @split, CORE::eval('$' . $digit);
741             }
742             }
743             }
744             }
745              
746             elsif ($limit > 0) {
747 0 0       0 if ('' =~ / \A $pattern \z /xms) {
748 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
749 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
750              
751             # V
752 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
753 0         0 local $@;
754 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
755 0         0 push @split, CORE::eval('$' . $digit);
756             }
757             }
758             }
759             }
760             else {
761 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
762 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
763              
764             # V
765 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
766 0         0 local $@;
767 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
768 0         0 push @split, CORE::eval('$' . $digit);
769             }
770             }
771             }
772             }
773             }
774              
775 0 0       0 if (CORE::length($string) > 0) {
776 0         0 push @split, $string;
777             }
778              
779             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
780 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
781 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
782 0         0 pop @split;
783             }
784             }
785              
786             # resulting list value in list context
787 0 0       0 if (wantarray) {
788 0         0 return @split;
789             }
790              
791             # count of substrings in scalar context
792             else {
793 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
794 0         0 @_ = @split;
795 0         0 return scalar @_;
796             }
797             }
798              
799             #
800             # get last subexpression offsets
801             #
802             sub _last_subexpression_offsets {
803 0     0   0 my $pattern = $_[0];
804              
805             # remove comment
806 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
807              
808 0         0 my $modifier = '';
809 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
810 0         0 $modifier = $1;
811 0         0 $modifier =~ s/-[A-Za-z]*//;
812             }
813              
814             # with /x modifier
815 0         0 my @char = ();
816 0 0       0 if ($modifier =~ /x/oxms) {
817 0         0 @char = $pattern =~ /\G((?>
818             [^\x81-\x9F\xE0-\xFD\\\#\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
819             \\ $q_char |
820             \# (?>[^\n]*) $ |
821             \[ (?>(?:[^\x81-\x9F\xE0-\xFD\\\]]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
822             \(\? |
823             $q_char
824             ))/oxmsg;
825             }
826              
827             # without /x modifier
828             else {
829 0         0 @char = $pattern =~ /\G((?>
830             [^\x81-\x9F\xE0-\xFD\\\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
831             \\ $q_char |
832             \[ (?>(?:[^\x81-\x9F\xE0-\xFD\\\]]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
833             \(\? |
834             $q_char
835             ))/oxmsg;
836             }
837              
838 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
839             }
840              
841             #
842             # INFORMIX V6 ALS transliteration (tr///)
843             #
844             sub Einformixv6als::tr($$$$;$) {
845              
846 0     0 0 0 my $bind_operator = $_[1];
847 0         0 my $searchlist = $_[2];
848 0         0 my $replacementlist = $_[3];
849 0   0     0 my $modifier = $_[4] || '';
850              
851 0 0       0 if ($modifier =~ /r/oxms) {
852 0 0       0 if ($bind_operator =~ / !~ /oxms) {
853 0         0 croak "Using !~ with tr///r doesn't make sense";
854             }
855             }
856              
857 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
858 0         0 my @searchlist = _charlist_tr($searchlist);
859 0         0 my @replacementlist = _charlist_tr($replacementlist);
860              
861 0         0 my %tr = ();
862 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
863 0 0       0 if (not exists $tr{$searchlist[$i]}) {
864 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
865 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
866             }
867             elsif ($modifier =~ /d/oxms) {
868 0         0 $tr{$searchlist[$i]} = '';
869             }
870             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
871 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
872             }
873             else {
874 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
875             }
876             }
877             }
878              
879 0         0 my $tr = 0;
880 0         0 my $replaced = '';
881 0 0       0 if ($modifier =~ /c/oxms) {
882 0         0 while (defined(my $char = shift @char)) {
883 0 0       0 if (not exists $tr{$char}) {
884 0 0       0 if (defined $replacementlist[0]) {
885 0         0 $replaced .= $replacementlist[0];
886             }
887 0         0 $tr++;
888 0 0       0 if ($modifier =~ /s/oxms) {
889 0   0     0 while (@char and (not exists $tr{$char[0]})) {
890 0         0 shift @char;
891 0         0 $tr++;
892             }
893             }
894             }
895             else {
896 0         0 $replaced .= $char;
897             }
898             }
899             }
900             else {
901 0         0 while (defined(my $char = shift @char)) {
902 0 0       0 if (exists $tr{$char}) {
903 0         0 $replaced .= $tr{$char};
904 0         0 $tr++;
905 0 0       0 if ($modifier =~ /s/oxms) {
906 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
907 0         0 shift @char;
908 0         0 $tr++;
909             }
910             }
911             }
912             else {
913 0         0 $replaced .= $char;
914             }
915             }
916             }
917              
918 0 0       0 if ($modifier =~ /r/oxms) {
919 0         0 return $replaced;
920             }
921             else {
922 0         0 $_[0] = $replaced;
923 0 0       0 if ($bind_operator =~ / !~ /oxms) {
924 0         0 return not $tr;
925             }
926             else {
927 0         0 return $tr;
928             }
929             }
930             }
931              
932             #
933             # INFORMIX V6 ALS chop
934             #
935             sub Einformixv6als::chop(@) {
936              
937 0     0 0 0 my $chop;
938 0 0       0 if (@_ == 0) {
939 0         0 my @char = /\G (?>$q_char) /oxmsg;
940 0         0 $chop = pop @char;
941 0         0 $_ = join '', @char;
942             }
943             else {
944 0         0 for (@_) {
945 0         0 my @char = /\G (?>$q_char) /oxmsg;
946 0         0 $chop = pop @char;
947 0         0 $_ = join '', @char;
948             }
949             }
950 0         0 return $chop;
951             }
952              
953             #
954             # INFORMIX V6 ALS index by octet
955             #
956             sub Einformixv6als::index($$;$) {
957              
958 0     2304 1 0 my($str,$substr,$position) = @_;
959 2304   50     5237 $position ||= 0;
960 2304         9520 my $pos = 0;
961              
962 2304         3269 while ($pos < CORE::length($str)) {
963 2304 50       5498 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
964 73608 0       119682 if ($pos >= $position) {
965 0         0 return $pos;
966             }
967             }
968 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
969 73608         195674 $pos += CORE::length($1);
970             }
971             else {
972 73608         136209 $pos += 1;
973             }
974             }
975 0         0 return -1;
976             }
977              
978             #
979             # INFORMIX V6 ALS reverse index
980             #
981             sub Einformixv6als::rindex($$;$) {
982              
983 2304     0 0 14302 my($str,$substr,$position) = @_;
984 0   0     0 $position ||= CORE::length($str) - 1;
985 0         0 my $pos = 0;
986 0         0 my $rindex = -1;
987              
988 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
989 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
990 0         0 $rindex = $pos;
991             }
992 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
993 0         0 $pos += CORE::length($1);
994             }
995             else {
996 0         0 $pos += 1;
997             }
998             }
999 0         0 return $rindex;
1000             }
1001              
1002             #
1003             # INFORMIX V6 ALS lower case first with parameter
1004             #
1005             sub Einformixv6als::lcfirst(@) {
1006 0 0   0 0 0 if (@_) {
1007 0         0 my $s = shift @_;
1008 0 0 0     0 if (@_ and wantarray) {
1009 0         0 return Einformixv6als::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1010             }
1011             else {
1012 0         0 return Einformixv6als::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1013             }
1014             }
1015             else {
1016 0         0 return Einformixv6als::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1017             }
1018             }
1019              
1020             #
1021             # INFORMIX V6 ALS lower case first without parameter
1022             #
1023             sub Einformixv6als::lcfirst_() {
1024 0     0 0 0 return Einformixv6als::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1025             }
1026              
1027             #
1028             # INFORMIX V6 ALS lower case with parameter
1029             #
1030             sub Einformixv6als::lc(@) {
1031 0 0   0 0 0 if (@_) {
1032 0         0 my $s = shift @_;
1033 0 0 0     0 if (@_ and wantarray) {
1034 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1035             }
1036             else {
1037 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1038             }
1039             }
1040             else {
1041 0         0 return Einformixv6als::lc_();
1042             }
1043             }
1044              
1045             #
1046             # INFORMIX V6 ALS lower case without parameter
1047             #
1048             sub Einformixv6als::lc_() {
1049 0     0 0 0 my $s = $_;
1050 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1051             }
1052              
1053             #
1054             # INFORMIX V6 ALS upper case first with parameter
1055             #
1056             sub Einformixv6als::ucfirst(@) {
1057 0 0   0 0 0 if (@_) {
1058 0         0 my $s = shift @_;
1059 0 0 0     0 if (@_ and wantarray) {
1060 0         0 return Einformixv6als::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1061             }
1062             else {
1063 0         0 return Einformixv6als::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1064             }
1065             }
1066             else {
1067 0         0 return Einformixv6als::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1068             }
1069             }
1070              
1071             #
1072             # INFORMIX V6 ALS upper case first without parameter
1073             #
1074             sub Einformixv6als::ucfirst_() {
1075 0     0 0 0 return Einformixv6als::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1076             }
1077              
1078             #
1079             # INFORMIX V6 ALS upper case with parameter
1080             #
1081             sub Einformixv6als::uc(@) {
1082 0 50   3618 0 0 if (@_) {
1083 3618         5688 my $s = shift @_;
1084 3618 50 33     4975 if (@_ and wantarray) {
1085 3618 0       6825 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1086             }
1087             else {
1088 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3618         11022  
1089             }
1090             }
1091             else {
1092 3618         12567 return Einformixv6als::uc_();
1093             }
1094             }
1095              
1096             #
1097             # INFORMIX V6 ALS upper case without parameter
1098             #
1099             sub Einformixv6als::uc_() {
1100 0     0 0 0 my $s = $_;
1101 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1102             }
1103              
1104             #
1105             # INFORMIX V6 ALS fold case with parameter
1106             #
1107             sub Einformixv6als::fc(@) {
1108 0 50   3921 0 0 if (@_) {
1109 3921         6034 my $s = shift @_;
1110 3921 50 33     5213 if (@_ and wantarray) {
1111 3921 0       7501 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1112             }
1113             else {
1114 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3921         10829  
1115             }
1116             }
1117             else {
1118 3921         15342 return Einformixv6als::fc_();
1119             }
1120             }
1121              
1122             #
1123             # INFORMIX V6 ALS fold case without parameter
1124             #
1125             sub Einformixv6als::fc_() {
1126 0     0 0 0 my $s = $_;
1127 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1128             }
1129              
1130             #
1131             # INFORMIX V6 ALS regexp capture
1132             #
1133             {
1134             # 10.3. Creating Persistent Private Variables
1135             # in Chapter 10. Subroutines
1136             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1137              
1138             my $last_s_matched = 0;
1139              
1140             sub Einformixv6als::capture {
1141 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1142 0         0 return $_[0] + 1;
1143             }
1144 0         0 return $_[0];
1145             }
1146              
1147             # INFORMIX V6 ALS mark last regexp matched
1148             sub Einformixv6als::matched() {
1149 0     0 0 0 $last_s_matched = 0;
1150             }
1151              
1152             # INFORMIX V6 ALS mark last s/// matched
1153             sub Einformixv6als::s_matched() {
1154 0     0 0 0 $last_s_matched = 1;
1155             }
1156              
1157             # P.854 31.17. use re
1158             # in Chapter 31. Pragmatic Modules
1159             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1160              
1161             # P.1026 re
1162             # in Chapter 29. Pragmatic Modules
1163             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1164              
1165             $Einformixv6als::matched = qr/(?{Einformixv6als::matched})/;
1166             }
1167              
1168             #
1169             # INFORMIX V6 ALS regexp ignore case modifier
1170             #
1171             sub Einformixv6als::ignorecase {
1172              
1173 0     0 0 0 my @string = @_;
1174 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1175              
1176             # ignore case of $scalar or @array
1177 0         0 for my $string (@string) {
1178              
1179             # split regexp
1180 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1181              
1182             # unescape character
1183 0         0 for (my $i=0; $i <= $#char; $i++) {
1184 0 0       0 next if not defined $char[$i];
1185              
1186             # open character class [...]
1187 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1188 0         0 my $left = $i;
1189              
1190             # [] make die "unmatched [] in regexp ...\n"
1191              
1192 0 0       0 if ($char[$i+1] eq ']') {
1193 0         0 $i++;
1194             }
1195              
1196 0         0 while (1) {
1197 0 0       0 if (++$i > $#char) {
1198 0         0 croak "Unmatched [] in regexp";
1199             }
1200 0 0       0 if ($char[$i] eq ']') {
1201 0         0 my $right = $i;
1202 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1203              
1204             # escape character
1205 0         0 for my $char (@charlist) {
1206 0 0       0 if (0) {
    0          
1207             }
1208              
1209             # do not use quotemeta here
1210 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1211 0         0 $char = $1 . '\\' . $2;
1212             }
1213             elsif ($char =~ /\A [.|)] \z/oxms) {
1214 0         0 $char = '\\' . $char;
1215             }
1216             }
1217              
1218             # [...]
1219 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1220              
1221 0         0 $i = $left;
1222 0         0 last;
1223             }
1224             }
1225             }
1226              
1227             # open character class [^...]
1228             elsif ($char[$i] eq '[^') {
1229 0         0 my $left = $i;
1230              
1231             # [^] make die "unmatched [] in regexp ...\n"
1232              
1233 0 0       0 if ($char[$i+1] eq ']') {
1234 0         0 $i++;
1235             }
1236              
1237 0         0 while (1) {
1238 0 0       0 if (++$i > $#char) {
1239 0         0 croak "Unmatched [] in regexp";
1240             }
1241 0 0       0 if ($char[$i] eq ']') {
1242 0         0 my $right = $i;
1243 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1244              
1245             # escape character
1246 0         0 for my $char (@charlist) {
1247 0 0       0 if (0) {
    0          
1248             }
1249              
1250             # do not use quotemeta here
1251 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1252 0         0 $char = $1 . '\\' . $2;
1253             }
1254             elsif ($char =~ /\A [.|)] \z/oxms) {
1255 0         0 $char = '\\' . $char;
1256             }
1257             }
1258              
1259             # [^...]
1260 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1261              
1262 0         0 $i = $left;
1263 0         0 last;
1264             }
1265             }
1266             }
1267              
1268             # rewrite classic character class or escape character
1269             elsif (my $char = classic_character_class($char[$i])) {
1270 0         0 $char[$i] = $char;
1271             }
1272              
1273             # with /i modifier
1274             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1275 0         0 my $uc = Einformixv6als::uc($char[$i]);
1276 0         0 my $fc = Einformixv6als::fc($char[$i]);
1277 0 0       0 if ($uc ne $fc) {
1278 0 0       0 if (CORE::length($fc) == 1) {
1279 0         0 $char[$i] = '[' . $uc . $fc . ']';
1280             }
1281             else {
1282 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1283             }
1284             }
1285             }
1286             }
1287              
1288             # characterize
1289 0         0 for (my $i=0; $i <= $#char; $i++) {
1290 0 0       0 next if not defined $char[$i];
1291              
1292 0 0 0     0 if (0) {
    0          
1293             }
1294              
1295             # escape last octet of multiple-octet
1296 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1297 0         0 $char[$i] = $1 . '\\' . $2;
1298             }
1299              
1300             # quote character before ? + * {
1301             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1302 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1303 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1304             }
1305             }
1306             }
1307              
1308 0         0 $string = join '', @char;
1309             }
1310              
1311             # make regexp string
1312 0         0 return @string;
1313             }
1314              
1315             #
1316             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1317             #
1318             sub Einformixv6als::classic_character_class {
1319 0     5227 0 0 my($char) = @_;
1320              
1321             return {
1322             '\D' => '${Einformixv6als::eD}',
1323             '\S' => '${Einformixv6als::eS}',
1324             '\W' => '${Einformixv6als::eW}',
1325             '\d' => '[0-9]',
1326              
1327             # Before Perl 5.6, \s only matched the five whitespace characters
1328             # tab, newline, form-feed, carriage return, and the space character
1329             # itself, which, taken together, is the character class [\t\n\f\r ].
1330              
1331             # Vertical tabs are now whitespace
1332             # \s in a regex now matches a vertical tab in all circumstances.
1333             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1334             # \t \n \v \f \r space
1335             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1336             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1337             '\s' => '\s',
1338              
1339             '\w' => '[0-9A-Z_a-z]',
1340             '\C' => '[\x00-\xFF]',
1341             '\X' => 'X',
1342              
1343             # \h \v \H \V
1344              
1345             # P.114 Character Class Shortcuts
1346             # in Chapter 7: In the World of Regular Expressions
1347             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1348              
1349             # P.357 13.2.3 Whitespace
1350             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1351             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1352             #
1353             # 0x00009 CHARACTER TABULATION h s
1354             # 0x0000a LINE FEED (LF) vs
1355             # 0x0000b LINE TABULATION v
1356             # 0x0000c FORM FEED (FF) vs
1357             # 0x0000d CARRIAGE RETURN (CR) vs
1358             # 0x00020 SPACE h s
1359              
1360             # P.196 Table 5-9. Alphanumeric regex metasymbols
1361             # in Chapter 5. Pattern Matching
1362             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1363              
1364             # (and so on)
1365              
1366             '\H' => '${Einformixv6als::eH}',
1367             '\V' => '${Einformixv6als::eV}',
1368             '\h' => '[\x09\x20]',
1369             '\v' => '[\x0A\x0B\x0C\x0D]',
1370             '\R' => '${Einformixv6als::eR}',
1371              
1372             # \N
1373             #
1374             # http://perldoc.perl.org/perlre.html
1375             # Character Classes and other Special Escapes
1376             # Any character but \n (experimental). Not affected by /s modifier
1377              
1378             '\N' => '${Einformixv6als::eN}',
1379              
1380             # \b \B
1381              
1382             # P.180 Boundaries: The \b and \B Assertions
1383             # in Chapter 5: Pattern Matching
1384             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1385              
1386             # P.219 Boundaries: The \b and \B Assertions
1387             # in Chapter 5: Pattern Matching
1388             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1389              
1390             # \b really means (?:(?<=\w)(?!\w)|(?
1391             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1392             '\b' => '${Einformixv6als::eb}',
1393              
1394             # \B really means (?:(?<=\w)(?=\w)|(?
1395             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1396             '\B' => '${Einformixv6als::eB}',
1397              
1398 5227   100     7955 }->{$char} || '';
1399             }
1400              
1401             #
1402             # prepare INFORMIX V6 ALS characters per length
1403             #
1404              
1405             # 1 octet characters
1406             my @chars1 = ();
1407             sub chars1 {
1408 5227 0   0 0 181801 if (@chars1) {
1409 0         0 return @chars1;
1410             }
1411 0 0       0 if (exists $range_tr{1}) {
1412 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1413 0         0 while (my @range = splice(@ranges,0,1)) {
1414 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1415 0         0 push @chars1, pack 'C', $oct0;
1416             }
1417             }
1418             }
1419 0         0 return @chars1;
1420             }
1421              
1422             # 2 octets characters
1423             my @chars2 = ();
1424             sub chars2 {
1425 0 0   0 0 0 if (@chars2) {
1426 0         0 return @chars2;
1427             }
1428 0 0       0 if (exists $range_tr{2}) {
1429 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1430 0         0 while (my @range = splice(@ranges,0,2)) {
1431 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1432 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1433 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1434             }
1435             }
1436             }
1437             }
1438 0         0 return @chars2;
1439             }
1440              
1441             # 3 octets characters
1442             my @chars3 = ();
1443             sub chars3 {
1444 0 0   0 0 0 if (@chars3) {
1445 0         0 return @chars3;
1446             }
1447 0 0       0 if (exists $range_tr{3}) {
1448 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1449 0         0 while (my @range = splice(@ranges,0,3)) {
1450 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1451 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1452 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1453 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1454             }
1455             }
1456             }
1457             }
1458             }
1459 0         0 return @chars3;
1460             }
1461              
1462             # 4 octets characters
1463             my @chars4 = ();
1464             sub chars4 {
1465 0 0   0 0 0 if (@chars4) {
1466 0         0 return @chars4;
1467             }
1468 0 0       0 if (exists $range_tr{4}) {
1469 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1470 0         0 while (my @range = splice(@ranges,0,4)) {
1471 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1472 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1473 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1474 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1475 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1476             }
1477             }
1478             }
1479             }
1480             }
1481             }
1482 0         0 return @chars4;
1483             }
1484              
1485             #
1486             # INFORMIX V6 ALS open character list for tr
1487             #
1488             sub _charlist_tr {
1489              
1490 0     0   0 local $_ = shift @_;
1491              
1492             # unescape character
1493 0         0 my @char = ();
1494 0         0 while (not /\G \z/oxmsgc) {
1495 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1496 0         0 push @char, '\-';
1497             }
1498             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1499 0         0 push @char, CORE::chr(oct $1);
1500             }
1501             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1502 0         0 push @char, CORE::chr(hex $1);
1503             }
1504             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1505 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1506             }
1507             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1508             push @char, {
1509             '\0' => "\0",
1510             '\n' => "\n",
1511             '\r' => "\r",
1512             '\t' => "\t",
1513             '\f' => "\f",
1514             '\b' => "\x08", # \b means backspace in character class
1515             '\a' => "\a",
1516             '\e' => "\e",
1517 0         0 }->{$1};
1518             }
1519             elsif (/\G \\ ($q_char) /oxmsgc) {
1520 0         0 push @char, $1;
1521             }
1522             elsif (/\G ($q_char) /oxmsgc) {
1523 0         0 push @char, $1;
1524             }
1525             }
1526              
1527             # join separated multiple-octet
1528 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1529              
1530             # unescape '-'
1531 0         0 my @i = ();
1532 0         0 for my $i (0 .. $#char) {
1533 0 0       0 if ($char[$i] eq '\-') {
    0          
1534 0         0 $char[$i] = '-';
1535             }
1536             elsif ($char[$i] eq '-') {
1537 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1538 0         0 push @i, $i;
1539             }
1540             }
1541             }
1542              
1543             # open character list (reverse for splice)
1544 0         0 for my $i (CORE::reverse @i) {
1545 0         0 my @range = ();
1546              
1547             # range error
1548 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1549 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1550             }
1551              
1552             # range of multiple-octet code
1553 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1554 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1555 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1556             }
1557             elsif (CORE::length($char[$i+1]) == 2) {
1558 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1559 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1560             }
1561             elsif (CORE::length($char[$i+1]) == 3) {
1562 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1563 0         0 push @range, chars2();
1564 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1565             }
1566             elsif (CORE::length($char[$i+1]) == 4) {
1567 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1568 0         0 push @range, chars2();
1569 0         0 push @range, chars3();
1570 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1571             }
1572             else {
1573 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1574             }
1575             }
1576             elsif (CORE::length($char[$i-1]) == 2) {
1577 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1578 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1579             }
1580             elsif (CORE::length($char[$i+1]) == 3) {
1581 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1582 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1583             }
1584             elsif (CORE::length($char[$i+1]) == 4) {
1585 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1586 0         0 push @range, chars3();
1587 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1588             }
1589             else {
1590 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1591             }
1592             }
1593             elsif (CORE::length($char[$i-1]) == 3) {
1594 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1595 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1596             }
1597             elsif (CORE::length($char[$i+1]) == 4) {
1598 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1599 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1600             }
1601             else {
1602 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1603             }
1604             }
1605             elsif (CORE::length($char[$i-1]) == 4) {
1606 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1607 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1608             }
1609             else {
1610 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1611             }
1612             }
1613             else {
1614 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1615             }
1616              
1617 0         0 splice @char, $i-1, 3, @range;
1618             }
1619              
1620 0         0 return @char;
1621             }
1622              
1623             #
1624             # INFORMIX V6 ALS open character class
1625             #
1626             sub _cc {
1627 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1628 604         1429 die __FILE__, ": subroutine cc got no parameter.\n";
1629             }
1630             elsif (scalar(@_) == 1) {
1631 0         0 return sprintf('\x%02X',$_[0]);
1632             }
1633             elsif (scalar(@_) == 2) {
1634 302 50       1095 if ($_[0] > $_[1]) {
    50          
    50          
1635 302         805 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1636             }
1637             elsif ($_[0] == $_[1]) {
1638 0         0 return sprintf('\x%02X',$_[0]);
1639             }
1640             elsif (($_[0]+1) == $_[1]) {
1641 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1642             }
1643             else {
1644 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1645             }
1646             }
1647             else {
1648 302         1652 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1649             }
1650             }
1651              
1652             #
1653             # INFORMIX V6 ALS octet range
1654             #
1655             sub _octets {
1656 0     688   0 my $length = shift @_;
1657              
1658 688 100       1257 if ($length == 1) {
    50          
    0          
    0          
1659 688         1633 my($a1) = unpack 'C', $_[0];
1660 426         1203 my($z1) = unpack 'C', $_[1];
1661              
1662 426 50       877 if ($a1 > $z1) {
1663 426         908 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1664             }
1665              
1666 0 50       0 if ($a1 == $z1) {
    100          
1667 426         1150 return sprintf('\x%02X',$a1);
1668             }
1669             elsif (($a1+1) == $z1) {
1670 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1671             }
1672             else {
1673 20         103 return sprintf('\x%02X-\x%02X',$a1,$z1);
1674             }
1675             }
1676             elsif ($length == 2) {
1677 406         2736 my($a1,$a2) = unpack 'CC', $_[0];
1678 262         750 my($z1,$z2) = unpack 'CC', $_[1];
1679 262         528 my($A1,$A2) = unpack 'CC', $_[2];
1680 262         503 my($Z1,$Z2) = unpack 'CC', $_[3];
1681              
1682 262 100       489 if ($a1 == $z1) {
    50          
1683             return (
1684             # 11111111 222222222222
1685             # A A Z
1686 262         523 _cc($a1) . _cc($a2,$z2), # a2-z2
1687             );
1688             }
1689             elsif (($a1+1) == $z1) {
1690             return (
1691             # 11111111111 222222222222
1692             # A Z A Z
1693 222         423 _cc($a1) . _cc($a2,$Z2), # a2-
1694             _cc( $z1) . _cc($A2,$z2), # -z2
1695             );
1696             }
1697             else {
1698             return (
1699             # 1111111111111111 222222222222
1700             # A Z A Z
1701 40         76 _cc($a1) . _cc($a2,$Z2), # a2-
1702             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1703             _cc( $z1) . _cc($A2,$z2), # -z2
1704             );
1705             }
1706             }
1707             elsif ($length == 3) {
1708 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1709 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1710 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1711 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1712              
1713 0 0       0 if ($a1 == $z1) {
    0          
1714 0 0       0 if ($a2 == $z2) {
    0          
1715             return (
1716             # 11111111 22222222 333333333333
1717             # A A A Z
1718 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1719             );
1720             }
1721             elsif (($a2+1) == $z2) {
1722             return (
1723             # 11111111 22222222222 333333333333
1724             # A A Z A Z
1725 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1726             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1727             );
1728             }
1729             else {
1730             return (
1731             # 11111111 2222222222222222 333333333333
1732             # A A Z A Z
1733 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1734             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1735             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1736             );
1737             }
1738             }
1739             elsif (($a1+1) == $z1) {
1740             return (
1741             # 11111111111 22222222222222 333333333333
1742             # A Z A Z A Z
1743 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1744             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1745             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1746             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1747             );
1748             }
1749             else {
1750             return (
1751             # 1111111111111111 22222222222222 333333333333
1752             # A Z A Z A Z
1753 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1754             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1755             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1756             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1757             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1758             );
1759             }
1760             }
1761             elsif ($length == 4) {
1762 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1763 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1764 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1765 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1766              
1767 0 0       0 if ($a1 == $z1) {
    0          
1768 0 0       0 if ($a2 == $z2) {
    0          
1769 0 0       0 if ($a3 == $z3) {
    0          
1770             return (
1771             # 11111111 22222222 33333333 444444444444
1772             # A A A A Z
1773 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1774             );
1775             }
1776             elsif (($a3+1) == $z3) {
1777             return (
1778             # 11111111 22222222 33333333333 444444444444
1779             # A A A Z A Z
1780 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1781             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1782             );
1783             }
1784             else {
1785             return (
1786             # 11111111 22222222 3333333333333333 444444444444
1787             # A A A Z A Z
1788 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1789             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1790             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1791             );
1792             }
1793             }
1794             elsif (($a2+1) == $z2) {
1795             return (
1796             # 11111111 22222222222 33333333333333 444444444444
1797             # A A Z A Z A Z
1798 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1799             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1800             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1801             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1802             );
1803             }
1804             else {
1805             return (
1806             # 11111111 2222222222222222 33333333333333 444444444444
1807             # A A Z A Z A Z
1808 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1809             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1810             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1811             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1812             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1813             );
1814             }
1815             }
1816             elsif (($a1+1) == $z1) {
1817             return (
1818             # 11111111111 22222222222222 33333333333333 444444444444
1819             # A Z A Z A Z A Z
1820 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1821             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1822             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1823             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1824             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1825             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1826             );
1827             }
1828             else {
1829             return (
1830             # 1111111111111111 22222222222222 33333333333333 444444444444
1831             # A Z A Z A Z A Z
1832 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1833             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1834             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1835             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1836             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1837             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1838             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1839             );
1840             }
1841             }
1842             else {
1843 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1844             }
1845             }
1846              
1847             #
1848             # INFORMIX V6 ALS range regexp
1849             #
1850             sub _range_regexp {
1851 0     517   0 my($length,$first,$last) = @_;
1852              
1853 517         1217 my @range_regexp = ();
1854 517 50       814 if (not exists $range_tr{$length}) {
1855 517         1404 return @range_regexp;
1856             }
1857              
1858 0         0 my @ranges = @{ $range_tr{$length} };
  517         825  
1859 517         1359 while (my @range = splice(@ranges,0,$length)) {
1860 517         1731 my $min = '';
1861 1682         2691 my $max = '';
1862 1682         2205 for (my $i=0; $i < $length; $i++) {
1863 1682         3523 $min .= pack 'C', $range[$i][0];
1864 2206         4684 $max .= pack 'C', $range[$i][-1];
1865             }
1866              
1867             # min___max
1868             # FIRST_____________LAST
1869             # (nothing)
1870              
1871 2206 50 66     4612 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1872             }
1873              
1874             # **********
1875             # min_________max
1876             # FIRST_____________LAST
1877             # **********
1878              
1879             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1880 1682         15292 push @range_regexp, _octets($length,$first,$max,$min,$max);
1881             }
1882              
1883             # **********************
1884             # min________________max
1885             # FIRST_____________LAST
1886             # **********************
1887              
1888             elsif (($min eq $first) and ($max eq $last)) {
1889 20         60 push @range_regexp, _octets($length,$first,$last,$min,$max);
1890             }
1891              
1892             # *********
1893             # min___max
1894             # FIRST_____________LAST
1895             # *********
1896              
1897             elsif (($first le $min) and ($max le $last)) {
1898 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1899             }
1900              
1901             # **********************
1902             # min__________________________max
1903             # FIRST_____________LAST
1904             # **********************
1905              
1906             elsif (($min le $first) and ($last le $max)) {
1907 40         81 push @range_regexp, _octets($length,$first,$last,$min,$max);
1908             }
1909              
1910             # *********
1911             # min________max
1912             # FIRST_____________LAST
1913             # *********
1914              
1915             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1916 588         1544 push @range_regexp, _octets($length,$min,$last,$min,$max);
1917             }
1918              
1919             # min___max
1920             # FIRST_____________LAST
1921             # (nothing)
1922              
1923             elsif ($last lt $min) {
1924             }
1925              
1926             else {
1927 40         69 die __FILE__, ": subroutine _range_regexp panic.\n";
1928             }
1929             }
1930              
1931 0         0 return @range_regexp;
1932             }
1933              
1934             #
1935             # INFORMIX V6 ALS open character list for qr and not qr
1936             #
1937             sub _charlist {
1938              
1939 517     758   1466 my $modifier = pop @_;
1940 758         1294 my @char = @_;
1941              
1942 758 100       1879 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1943              
1944             # unescape character
1945 758         1894 for (my $i=0; $i <= $#char; $i++) {
1946              
1947             # escape - to ...
1948 758 100 100     2599 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1949 2648 100 100     20013 if ((0 < $i) and ($i < $#char)) {
1950 522         2169 $char[$i] = '...';
1951             }
1952             }
1953              
1954             # octal escape sequence
1955             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1956 497         1242 $char[$i] = octchr($1);
1957             }
1958              
1959             # hexadecimal escape sequence
1960             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1961 0         0 $char[$i] = hexchr($1);
1962             }
1963              
1964             # \b{...} --> b\{...}
1965             # \B{...} --> B\{...}
1966             # \N{CHARNAME} --> N\{CHARNAME}
1967             # \p{PROPERTY} --> p\{PROPERTY}
1968             # \P{PROPERTY} --> P\{PROPERTY}
1969             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
1970 0         0 $char[$i] = $1 . '\\' . $2;
1971             }
1972              
1973             # \p, \P, \X --> p, P, X
1974             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1975 0         0 $char[$i] = $1;
1976             }
1977              
1978             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1979 0         0 $char[$i] = CORE::chr oct $1;
1980             }
1981             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1982 0         0 $char[$i] = CORE::chr hex $1;
1983             }
1984             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1985 206         873 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1986             }
1987             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1988             $char[$i] = {
1989             '\0' => "\0",
1990             '\n' => "\n",
1991             '\r' => "\r",
1992             '\t' => "\t",
1993             '\f' => "\f",
1994             '\b' => "\x08", # \b means backspace in character class
1995             '\a' => "\a",
1996             '\e' => "\e",
1997             '\d' => '[0-9]',
1998              
1999             # Vertical tabs are now whitespace
2000             # \s in a regex now matches a vertical tab in all circumstances.
2001             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
2002             # \t \n \v \f \r space
2003             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
2004             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
2005             '\s' => '\s',
2006              
2007             '\w' => '[0-9A-Z_a-z]',
2008             '\D' => '${Einformixv6als::eD}',
2009             '\S' => '${Einformixv6als::eS}',
2010             '\W' => '${Einformixv6als::eW}',
2011              
2012             '\H' => '${Einformixv6als::eH}',
2013             '\V' => '${Einformixv6als::eV}',
2014             '\h' => '[\x09\x20]',
2015             '\v' => '[\x0A\x0B\x0C\x0D]',
2016             '\R' => '${Einformixv6als::eR}',
2017              
2018 0         0 }->{$1};
2019             }
2020              
2021             # POSIX-style character classes
2022             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2023             $char[$i] = {
2024              
2025             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2026             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2027             '[:^lower:]' => '${Einformixv6als::not_lower_i}',
2028             '[:^upper:]' => '${Einformixv6als::not_upper_i}',
2029              
2030 33         606 }->{$1};
2031             }
2032             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2033             $char[$i] = {
2034              
2035             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2036             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2037             '[:ascii:]' => '[\x00-\x7F]',
2038             '[:blank:]' => '[\x09\x20]',
2039             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2040             '[:digit:]' => '[\x30-\x39]',
2041             '[:graph:]' => '[\x21-\x7F]',
2042             '[:lower:]' => '[\x61-\x7A]',
2043             '[:print:]' => '[\x20-\x7F]',
2044             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2045              
2046             # P.174 POSIX-Style Character Classes
2047             # in Chapter 5: Pattern Matching
2048             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2049              
2050             # P.311 11.2.4 Character Classes and other Special Escapes
2051             # in Chapter 11: perlre: Perl regular expressions
2052             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2053              
2054             # P.210 POSIX-Style Character Classes
2055             # in Chapter 5: Pattern Matching
2056             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2057              
2058             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2059              
2060             '[:upper:]' => '[\x41-\x5A]',
2061             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2062             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2063             '[:^alnum:]' => '${Einformixv6als::not_alnum}',
2064             '[:^alpha:]' => '${Einformixv6als::not_alpha}',
2065             '[:^ascii:]' => '${Einformixv6als::not_ascii}',
2066             '[:^blank:]' => '${Einformixv6als::not_blank}',
2067             '[:^cntrl:]' => '${Einformixv6als::not_cntrl}',
2068             '[:^digit:]' => '${Einformixv6als::not_digit}',
2069             '[:^graph:]' => '${Einformixv6als::not_graph}',
2070             '[:^lower:]' => '${Einformixv6als::not_lower}',
2071             '[:^print:]' => '${Einformixv6als::not_print}',
2072             '[:^punct:]' => '${Einformixv6als::not_punct}',
2073             '[:^space:]' => '${Einformixv6als::not_space}',
2074             '[:^upper:]' => '${Einformixv6als::not_upper}',
2075             '[:^word:]' => '${Einformixv6als::not_word}',
2076             '[:^xdigit:]' => '${Einformixv6als::not_xdigit}',
2077              
2078 8         55 }->{$1};
2079             }
2080             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2081 70         1497 $char[$i] = $1;
2082             }
2083             }
2084              
2085             # open character list
2086 7         34 my @singleoctet = ();
2087 758         1394 my @multipleoctet = ();
2088 758         1178 for (my $i=0; $i <= $#char; ) {
2089              
2090             # escaped -
2091 758 100 100     1914 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2092 2151         9795 $i += 1;
2093 497         750 next;
2094             }
2095              
2096             # make range regexp
2097             elsif ($char[$i] eq '...') {
2098              
2099             # range error
2100 497 50       1100 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2101 497         1935 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2102             }
2103             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2104 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2105 477         1252 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2106             }
2107             }
2108              
2109             # make range regexp per length
2110 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2111 497         1512 my @regexp = ();
2112              
2113             # is first and last
2114 517 100 100     832 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2115 517         2013 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2116             }
2117              
2118             # is first
2119             elsif ($length == CORE::length($char[$i-1])) {
2120 477         1393 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2121             }
2122              
2123             # is inside in first and last
2124             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2125 20         73 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2126             }
2127              
2128             # is last
2129             elsif ($length == CORE::length($char[$i+1])) {
2130 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2131             }
2132              
2133             else {
2134 20         96 die __FILE__, ": subroutine make_regexp panic.\n";
2135             }
2136              
2137 0 100       0 if ($length == 1) {
2138 517         1106 push @singleoctet, @regexp;
2139             }
2140             else {
2141 386         1041 push @multipleoctet, @regexp;
2142             }
2143             }
2144              
2145 131         381 $i += 2;
2146             }
2147              
2148             # with /i modifier
2149             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2150 497 100       1198 if ($modifier =~ /i/oxms) {
2151 764         1331 my $uc = Einformixv6als::uc($char[$i]);
2152 192         373 my $fc = Einformixv6als::fc($char[$i]);
2153 192 50       383 if ($uc ne $fc) {
2154 192 50       365 if (CORE::length($fc) == 1) {
2155 192         314 push @singleoctet, $uc, $fc;
2156             }
2157             else {
2158 192         418 push @singleoctet, $uc;
2159 0         0 push @multipleoctet, $fc;
2160             }
2161             }
2162             else {
2163 0         0 push @singleoctet, $char[$i];
2164             }
2165             }
2166             else {
2167 0         0 push @singleoctet, $char[$i];
2168             }
2169 572         964 $i += 1;
2170             }
2171              
2172             # single character of single octet code
2173             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2174 764         1373 push @singleoctet, "\t", "\x20";
2175 0         0 $i += 1;
2176             }
2177             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2178 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2179 0         0 $i += 1;
2180             }
2181             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2182 0         0 push @singleoctet, $char[$i];
2183 2         8 $i += 1;
2184             }
2185              
2186             # single character of multiple-octet code
2187             else {
2188 2         7 push @multipleoctet, $char[$i];
2189 391         794 $i += 1;
2190             }
2191             }
2192              
2193             # quote metachar
2194 391         761 for (@singleoctet) {
2195 758 50       1648 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2196 1384         6343 $_ = '-';
2197             }
2198             elsif (/\A \n \z/oxms) {
2199 0         0 $_ = '\n';
2200             }
2201             elsif (/\A \r \z/oxms) {
2202 8         22 $_ = '\r';
2203             }
2204             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2205 8         46 $_ = sprintf('\x%02X', CORE::ord $1);
2206             }
2207             elsif (/\A [\x00-\xFF] \z/oxms) {
2208 1         7 $_ = quotemeta $_;
2209             }
2210             }
2211 939         1656 for (@multipleoctet) {
2212 758 100       1459 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2213 693         2002 $_ = $1 . quotemeta $2;
2214             }
2215             }
2216              
2217             # return character list
2218 307         825 return \@singleoctet, \@multipleoctet;
2219             }
2220              
2221             #
2222             # INFORMIX V6 ALS octal escape sequence
2223             #
2224             sub octchr {
2225 758     5 0 2839 my($octdigit) = @_;
2226              
2227 5         16 my @binary = ();
2228 5         11 for my $octal (split(//,$octdigit)) {
2229             push @binary, {
2230             '0' => '000',
2231             '1' => '001',
2232             '2' => '010',
2233             '3' => '011',
2234             '4' => '100',
2235             '5' => '101',
2236             '6' => '110',
2237             '7' => '111',
2238 5         38 }->{$octal};
2239             }
2240 50         241 my $binary = join '', @binary;
2241              
2242             my $octchr = {
2243             # 1234567
2244             1 => pack('B*', "0000000$binary"),
2245             2 => pack('B*', "000000$binary"),
2246             3 => pack('B*', "00000$binary"),
2247             4 => pack('B*', "0000$binary"),
2248             5 => pack('B*', "000$binary"),
2249             6 => pack('B*', "00$binary"),
2250             7 => pack('B*', "0$binary"),
2251             0 => pack('B*', "$binary"),
2252              
2253 5         19 }->{CORE::length($binary) % 8};
2254              
2255 5         69 return $octchr;
2256             }
2257              
2258             #
2259             # INFORMIX V6 ALS hexadecimal escape sequence
2260             #
2261             sub hexchr {
2262 5     5 0 25 my($hexdigit) = @_;
2263              
2264             my $hexchr = {
2265             1 => pack('H*', "0$hexdigit"),
2266             0 => pack('H*', "$hexdigit"),
2267              
2268 5         20 }->{CORE::length($_[0]) % 2};
2269              
2270 5         82 return $hexchr;
2271             }
2272              
2273             #
2274             # INFORMIX V6 ALS open character list for qr
2275             #
2276             sub charlist_qr {
2277              
2278 5     519 0 26 my $modifier = pop @_;
2279 519         1125 my @char = @_;
2280              
2281 519         1446 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2282 519         1669 my @singleoctet = @$singleoctet;
2283 519         1232 my @multipleoctet = @$multipleoctet;
2284              
2285             # return character list
2286 519 100       1032 if (scalar(@singleoctet) >= 1) {
2287              
2288             # with /i modifier
2289 519 100       1383 if ($modifier =~ m/i/oxms) {
2290 384         958 my %singleoctet_ignorecase = ();
2291 107         169 for (@singleoctet) {
2292 107   100     180 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2293 277         1042 for my $ord (hex($1) .. hex($2)) {
2294 90         334 my $char = CORE::chr($ord);
2295 1371         2441 my $uc = Einformixv6als::uc($char);
2296 1371         1967 my $fc = Einformixv6als::fc($char);
2297 1371 100       2229 if ($uc eq $fc) {
2298 1371         2266 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2299             }
2300             else {
2301 782 50       1954 if (CORE::length($fc) == 1) {
2302 589         984 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2303 589         1299 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2304             }
2305             else {
2306 589         1561 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2307 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2308             }
2309             }
2310             }
2311             }
2312 0 100       0 if ($_ ne '') {
2313 277         544 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2314             }
2315             }
2316 192         508 my $i = 0;
2317 107         158 my @singleoctet_ignorecase = ();
2318 107         188 for my $ord (0 .. 255) {
2319 107 100       193 if (exists $singleoctet_ignorecase{$ord}) {
2320 27392         39528 push @{$singleoctet_ignorecase[$i]}, $ord;
  1902         2009  
2321             }
2322             else {
2323 1902         3541 $i++;
2324             }
2325             }
2326 25490         32632 @singleoctet = ();
2327 107         192 for my $range (@singleoctet_ignorecase) {
2328 107 100       268 if (ref $range) {
2329 11087 50       20954 if (scalar(@{$range}) == 1) {
  219 100       275  
2330 219         473 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2331             }
2332 0         0 elsif (scalar(@{$range}) == 2) {
2333 219         387 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  5         8  
  5         7  
2334             }
2335             else {
2336 5         94 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  214         287  
  214         344  
2337             }
2338             }
2339             }
2340             }
2341              
2342 214         1082 my $not_anchor = '';
2343 384         828 $not_anchor = '(?![\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE])';
2344              
2345 384         740 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2346             }
2347 384 100       1503 if (scalar(@multipleoctet) >= 2) {
2348 519         1439 return '(?:' . join('|', @multipleoctet) . ')';
2349             }
2350             else {
2351 131         939 return $multipleoctet[0];
2352             }
2353             }
2354              
2355             #
2356             # INFORMIX V6 ALS open character list for not qr
2357             #
2358             sub charlist_not_qr {
2359              
2360 388     239 0 1877 my $modifier = pop @_;
2361 239         476 my @char = @_;
2362              
2363 239         672 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2364 239         627 my @singleoctet = @$singleoctet;
2365 239         623 my @multipleoctet = @$multipleoctet;
2366              
2367             # with /i modifier
2368 239 100       437 if ($modifier =~ m/i/oxms) {
2369 239         625 my %singleoctet_ignorecase = ();
2370 128         229 for (@singleoctet) {
2371 128   100     216 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2372 277         993 for my $ord (hex($1) .. hex($2)) {
2373 90         325 my $char = CORE::chr($ord);
2374 1371         2040 my $uc = Einformixv6als::uc($char);
2375 1371         1959 my $fc = Einformixv6als::fc($char);
2376 1371 100       2184 if ($uc eq $fc) {
2377 1371         2253 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2378             }
2379             else {
2380 782 50       1922 if (CORE::length($fc) == 1) {
2381 589         896 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2382 589         1270 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2383             }
2384             else {
2385 589         1562 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2386 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2387             }
2388             }
2389             }
2390             }
2391 0 100       0 if ($_ ne '') {
2392 277         555 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2393             }
2394             }
2395 192         501 my $i = 0;
2396 128         175 my @singleoctet_ignorecase = ();
2397 128         221 for my $ord (0 .. 255) {
2398 128 100       237 if (exists $singleoctet_ignorecase{$ord}) {
2399 32768         47549 push @{$singleoctet_ignorecase[$i]}, $ord;
  1902         2116  
2400             }
2401             else {
2402 1902         3325 $i++;
2403             }
2404             }
2405 30866         38505 @singleoctet = ();
2406 128         223 for my $range (@singleoctet_ignorecase) {
2407 128 100       312 if (ref $range) {
2408 11087 50       20973 if (scalar(@{$range}) == 1) {
  219 100       273  
2409 219         411 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2410             }
2411 0         0 elsif (scalar(@{$range}) == 2) {
2412 219         421 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  5         8  
  5         8  
2413             }
2414             else {
2415 5         89 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  214         310  
  214         336  
2416             }
2417             }
2418             }
2419             }
2420              
2421             # return character list
2422 214 100       1074 if (scalar(@multipleoctet) >= 1) {
2423 239 100       649 if (scalar(@singleoctet) >= 1) {
2424              
2425             # any character other than multiple-octet and single octet character class
2426 114         214 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\x9F\xE0-\xFD' . join('', @singleoctet) . ']|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])';
2427             }
2428             else {
2429              
2430             # any character other than multiple-octet character class
2431 70         581 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2432             }
2433             }
2434             else {
2435 44 50       335 if (scalar(@singleoctet) >= 1) {
2436              
2437             # any character other than single octet character class
2438 125         250 return '(?:[^\x81-\x9F\xE0-\xFD' . join('', @singleoctet) . ']|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])';
2439             }
2440             else {
2441              
2442             # any character
2443 125         821 return "(?:$your_char)";
2444             }
2445             }
2446             }
2447              
2448             #
2449             # open file in read mode
2450             #
2451             sub _open_r {
2452 0     768   0 my(undef,$file) = @_;
2453 389     389   6358 use Fcntl qw(O_RDONLY);
  389         4415  
  389         58892  
2454 768         2424 return CORE::sysopen($_[0], $file, &O_RDONLY);
2455             }
2456              
2457             #
2458             # open file in append mode
2459             #
2460             sub _open_a {
2461 768     384   34582 my(undef,$file) = @_;
2462 389     389   4615 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         910  
  389         5712437  
2463 384         1272 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2464             }
2465              
2466             #
2467             # safe system
2468             #
2469             sub _systemx {
2470              
2471             # P.707 29.2.33. exec
2472             # in Chapter 29: Functions
2473             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2474             #
2475             # Be aware that in older releases of Perl, exec (and system) did not flush
2476             # your output buffer, so you needed to enable command buffering by setting $|
2477             # on one or more filehandles to avoid lost output in the case of exec, or
2478             # misordererd output in the case of system. This situation was largely remedied
2479             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2480              
2481             # P.855 exec
2482             # in Chapter 27: Functions
2483             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2484             #
2485             # In very old release of Perl (before v5.6), exec (and system) did not flush
2486             # your output buffer, so you needed to enable command buffering by setting $|
2487             # on one or more filehandles to avoid lost output with exec or misordered
2488             # output with system.
2489              
2490 384     384   72777 $| = 1;
2491              
2492             # P.565 23.1.2. Cleaning Up Your Environment
2493             # in Chapter 23: Security
2494             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2495              
2496             # P.656 Cleaning Up Your Environment
2497             # in Chapter 20: Security
2498             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2499              
2500             # local $ENV{'PATH'} = '.';
2501 384         1609 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2502              
2503             # P.707 29.2.33. exec
2504             # in Chapter 29: Functions
2505             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2506             #
2507             # As we mentioned earlier, exec treats a discrete list of arguments as an
2508             # indication that it should bypass shell processing. However, there is one
2509             # place where you might still get tripped up. The exec call (and system, too)
2510             # will not distinguish between a single scalar argument and an array containing
2511             # only one element.
2512             #
2513             # @args = ("echo surprise"); # just one element in list
2514             # exec @args # still subject to shell escapes
2515             # or die "exec: $!"; # because @args == 1
2516             #
2517             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2518             # first argument as the pathname, which forces the rest of the arguments to be
2519             # interpreted as a list, even if there is only one of them:
2520             #
2521             # exec { $args[0] } @args # safe even with one-argument list
2522             # or die "can't exec @args: $!";
2523              
2524             # P.855 exec
2525             # in Chapter 27: Functions
2526             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2527             #
2528             # As we mentioned earlier, exec treats a discrete list of arguments as a
2529             # directive to bypass shell processing. However, there is one place where
2530             # you might still get tripped up. The exec call (and system, too) cannot
2531             # distinguish between a single scalar argument and an array containing
2532             # only one element.
2533             #
2534             # @args = ("echo surprise"); # just one element in list
2535             # exec @args # still subject to shell escapes
2536             # || die "exec: $!"; # because @args == 1
2537             #
2538             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2539             # argument as the pathname, which forces the rest of the arguments to be
2540             # interpreted as a list, even if there is only one of them:
2541             #
2542             # exec { $args[0] } @args # safe even with one-argument list
2543             # || die "can't exec @args: $!";
2544              
2545 384         3778 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         992  
2546             }
2547              
2548             #
2549             # INFORMIX V6 ALS order to character (with parameter)
2550             #
2551             sub Einformixv6als::chr(;$) {
2552              
2553 384 0   0 0 46434971 my $c = @_ ? $_[0] : $_;
2554              
2555 0 0       0 if ($c == 0x00) {
2556 0         0 return "\x00";
2557             }
2558             else {
2559 0         0 my @chr = ();
2560 0         0 while ($c > 0) {
2561 0         0 unshift @chr, ($c % 0x100);
2562 0         0 $c = int($c / 0x100);
2563             }
2564 0         0 return pack 'C*', @chr;
2565             }
2566             }
2567              
2568             #
2569             # INFORMIX V6 ALS order to character (without parameter)
2570             #
2571             sub Einformixv6als::chr_() {
2572              
2573 0     0 0 0 my $c = $_;
2574              
2575 0 0       0 if ($c == 0x00) {
2576 0         0 return "\x00";
2577             }
2578             else {
2579 0         0 my @chr = ();
2580 0         0 while ($c > 0) {
2581 0         0 unshift @chr, ($c % 0x100);
2582 0         0 $c = int($c / 0x100);
2583             }
2584 0         0 return pack 'C*', @chr;
2585             }
2586             }
2587              
2588             #
2589             # INFORMIX V6 ALS stacked file test expr
2590             #
2591             sub Einformixv6als::filetest {
2592              
2593 0     0 0 0 my $file = pop @_;
2594 0         0 my $filetest = substr(pop @_, 1);
2595              
2596 0 0       0 unless (CORE::eval qq{Einformixv6als::$filetest(\$file)}) {
2597 0         0 return '';
2598             }
2599 0         0 for my $filetest (CORE::reverse @_) {
2600 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2601 0         0 return '';
2602             }
2603             }
2604 0         0 return 1;
2605             }
2606              
2607             #
2608             # INFORMIX V6 ALS file test -r expr
2609             #
2610             sub Einformixv6als::r(;*@) {
2611              
2612 0 0   0 0 0 local $_ = shift if @_;
2613 0 0 0     0 croak 'Too many arguments for -r (Einformixv6als::r)' if @_ and not wantarray;
2614              
2615 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2616 0 0       0 return wantarray ? (-r _,@_) : -r _;
2617             }
2618              
2619             # P.908 32.39. Symbol
2620             # in Chapter 32: Standard Modules
2621             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2622              
2623             # P.326 Prototypes
2624             # in Chapter 7: Subroutines
2625             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2626              
2627             # (and so on)
2628              
2629             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2630 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2631             }
2632             elsif (-e $_) {
2633 0 0       0 return wantarray ? (-r _,@_) : -r _;
2634             }
2635             elsif (_MSWin32_5Cended_path($_)) {
2636 0 0       0 if (-d "$_/.") {
2637 0 0       0 return wantarray ? (-r _,@_) : -r _;
2638             }
2639             else {
2640              
2641             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Einformixv6als::*()
2642             # on Windows opens the file for the path which has 5c at end.
2643             # (and so on)
2644              
2645 0         0 my $fh = gensym();
2646 0 0       0 if (_open_r($fh, $_)) {
2647 0         0 my $r = -r $fh;
2648 0 0       0 close($fh) or die "Can't close file: $_: $!";
2649 0 0       0 return wantarray ? ($r,@_) : $r;
2650             }
2651             }
2652             }
2653 0 0       0 return wantarray ? (undef,@_) : undef;
2654             }
2655              
2656             #
2657             # INFORMIX V6 ALS file test -w expr
2658             #
2659             sub Einformixv6als::w(;*@) {
2660              
2661 0 0   0 0 0 local $_ = shift if @_;
2662 0 0 0     0 croak 'Too many arguments for -w (Einformixv6als::w)' if @_ and not wantarray;
2663              
2664 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2665 0 0       0 return wantarray ? (-w _,@_) : -w _;
2666             }
2667             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2668 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2669             }
2670             elsif (-e $_) {
2671 0 0       0 return wantarray ? (-w _,@_) : -w _;
2672             }
2673             elsif (_MSWin32_5Cended_path($_)) {
2674 0 0       0 if (-d "$_/.") {
2675 0 0       0 return wantarray ? (-w _,@_) : -w _;
2676             }
2677             else {
2678 0         0 my $fh = gensym();
2679 0 0       0 if (_open_a($fh, $_)) {
2680 0         0 my $w = -w $fh;
2681 0 0       0 close($fh) or die "Can't close file: $_: $!";
2682 0 0       0 return wantarray ? ($w,@_) : $w;
2683             }
2684             }
2685             }
2686 0 0       0 return wantarray ? (undef,@_) : undef;
2687             }
2688              
2689             #
2690             # INFORMIX V6 ALS file test -x expr
2691             #
2692             sub Einformixv6als::x(;*@) {
2693              
2694 0 0   0 0 0 local $_ = shift if @_;
2695 0 0 0     0 croak 'Too many arguments for -x (Einformixv6als::x)' if @_ and not wantarray;
2696              
2697 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2698 0 0       0 return wantarray ? (-x _,@_) : -x _;
2699             }
2700             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2701 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2702             }
2703             elsif (-e $_) {
2704 0 0       0 return wantarray ? (-x _,@_) : -x _;
2705             }
2706             elsif (_MSWin32_5Cended_path($_)) {
2707 0 0       0 if (-d "$_/.") {
2708 0 0       0 return wantarray ? (-x _,@_) : -x _;
2709             }
2710             else {
2711 0         0 my $fh = gensym();
2712 0 0       0 if (_open_r($fh, $_)) {
2713 0         0 my $dummy_for_underline_cache = -x $fh;
2714 0 0       0 close($fh) or die "Can't close file: $_: $!";
2715             }
2716              
2717             # filename is not .COM .EXE .BAT .CMD
2718 0 0       0 return wantarray ? ('',@_) : '';
2719             }
2720             }
2721 0 0       0 return wantarray ? (undef,@_) : undef;
2722             }
2723              
2724             #
2725             # INFORMIX V6 ALS file test -o expr
2726             #
2727             sub Einformixv6als::o(;*@) {
2728              
2729 0 0   0 0 0 local $_ = shift if @_;
2730 0 0 0     0 croak 'Too many arguments for -o (Einformixv6als::o)' if @_ and not wantarray;
2731              
2732 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2733 0 0       0 return wantarray ? (-o _,@_) : -o _;
2734             }
2735             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2736 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2737             }
2738             elsif (-e $_) {
2739 0 0       0 return wantarray ? (-o _,@_) : -o _;
2740             }
2741             elsif (_MSWin32_5Cended_path($_)) {
2742 0 0       0 if (-d "$_/.") {
2743 0 0       0 return wantarray ? (-o _,@_) : -o _;
2744             }
2745             else {
2746 0         0 my $fh = gensym();
2747 0 0       0 if (_open_r($fh, $_)) {
2748 0         0 my $o = -o $fh;
2749 0 0       0 close($fh) or die "Can't close file: $_: $!";
2750 0 0       0 return wantarray ? ($o,@_) : $o;
2751             }
2752             }
2753             }
2754 0 0       0 return wantarray ? (undef,@_) : undef;
2755             }
2756              
2757             #
2758             # INFORMIX V6 ALS file test -R expr
2759             #
2760             sub Einformixv6als::R(;*@) {
2761              
2762 0 0   0 0 0 local $_ = shift if @_;
2763 0 0 0     0 croak 'Too many arguments for -R (Einformixv6als::R)' if @_ and not wantarray;
2764              
2765 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2766 0 0       0 return wantarray ? (-R _,@_) : -R _;
2767             }
2768             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2769 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2770             }
2771             elsif (-e $_) {
2772 0 0       0 return wantarray ? (-R _,@_) : -R _;
2773             }
2774             elsif (_MSWin32_5Cended_path($_)) {
2775 0 0       0 if (-d "$_/.") {
2776 0 0       0 return wantarray ? (-R _,@_) : -R _;
2777             }
2778             else {
2779 0         0 my $fh = gensym();
2780 0 0       0 if (_open_r($fh, $_)) {
2781 0         0 my $R = -R $fh;
2782 0 0       0 close($fh) or die "Can't close file: $_: $!";
2783 0 0       0 return wantarray ? ($R,@_) : $R;
2784             }
2785             }
2786             }
2787 0 0       0 return wantarray ? (undef,@_) : undef;
2788             }
2789              
2790             #
2791             # INFORMIX V6 ALS file test -W expr
2792             #
2793             sub Einformixv6als::W(;*@) {
2794              
2795 0 0   0 0 0 local $_ = shift if @_;
2796 0 0 0     0 croak 'Too many arguments for -W (Einformixv6als::W)' if @_ and not wantarray;
2797              
2798 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2799 0 0       0 return wantarray ? (-W _,@_) : -W _;
2800             }
2801             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2802 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2803             }
2804             elsif (-e $_) {
2805 0 0       0 return wantarray ? (-W _,@_) : -W _;
2806             }
2807             elsif (_MSWin32_5Cended_path($_)) {
2808 0 0       0 if (-d "$_/.") {
2809 0 0       0 return wantarray ? (-W _,@_) : -W _;
2810             }
2811             else {
2812 0         0 my $fh = gensym();
2813 0 0       0 if (_open_a($fh, $_)) {
2814 0         0 my $W = -W $fh;
2815 0 0       0 close($fh) or die "Can't close file: $_: $!";
2816 0 0       0 return wantarray ? ($W,@_) : $W;
2817             }
2818             }
2819             }
2820 0 0       0 return wantarray ? (undef,@_) : undef;
2821             }
2822              
2823             #
2824             # INFORMIX V6 ALS file test -X expr
2825             #
2826             sub Einformixv6als::X(;*@) {
2827              
2828 0 0   0 1 0 local $_ = shift if @_;
2829 0 0 0     0 croak 'Too many arguments for -X (Einformixv6als::X)' if @_ and not wantarray;
2830              
2831 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2832 0 0       0 return wantarray ? (-X _,@_) : -X _;
2833             }
2834             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2835 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2836             }
2837             elsif (-e $_) {
2838 0 0       0 return wantarray ? (-X _,@_) : -X _;
2839             }
2840             elsif (_MSWin32_5Cended_path($_)) {
2841 0 0       0 if (-d "$_/.") {
2842 0 0       0 return wantarray ? (-X _,@_) : -X _;
2843             }
2844             else {
2845 0         0 my $fh = gensym();
2846 0 0       0 if (_open_r($fh, $_)) {
2847 0         0 my $dummy_for_underline_cache = -X $fh;
2848 0 0       0 close($fh) or die "Can't close file: $_: $!";
2849             }
2850              
2851             # filename is not .COM .EXE .BAT .CMD
2852 0 0       0 return wantarray ? ('',@_) : '';
2853             }
2854             }
2855 0 0       0 return wantarray ? (undef,@_) : undef;
2856             }
2857              
2858             #
2859             # INFORMIX V6 ALS file test -O expr
2860             #
2861             sub Einformixv6als::O(;*@) {
2862              
2863 0 0   0 0 0 local $_ = shift if @_;
2864 0 0 0     0 croak 'Too many arguments for -O (Einformixv6als::O)' if @_ and not wantarray;
2865              
2866 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2867 0 0       0 return wantarray ? (-O _,@_) : -O _;
2868             }
2869             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2870 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2871             }
2872             elsif (-e $_) {
2873 0 0       0 return wantarray ? (-O _,@_) : -O _;
2874             }
2875             elsif (_MSWin32_5Cended_path($_)) {
2876 0 0       0 if (-d "$_/.") {
2877 0 0       0 return wantarray ? (-O _,@_) : -O _;
2878             }
2879             else {
2880 0         0 my $fh = gensym();
2881 0 0       0 if (_open_r($fh, $_)) {
2882 0         0 my $O = -O $fh;
2883 0 0       0 close($fh) or die "Can't close file: $_: $!";
2884 0 0       0 return wantarray ? ($O,@_) : $O;
2885             }
2886             }
2887             }
2888 0 0       0 return wantarray ? (undef,@_) : undef;
2889             }
2890              
2891             #
2892             # INFORMIX V6 ALS file test -e expr
2893             #
2894             sub Einformixv6als::e(;*@) {
2895              
2896 0 50   768 0 0 local $_ = shift if @_;
2897 768 50 33     3267 croak 'Too many arguments for -e (Einformixv6als::e)' if @_ and not wantarray;
2898              
2899 768         3382 local $^W = 0;
2900              
2901 768         3001 my $fh = qualify_to_ref $_;
2902 768 50       2284 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2903 768 0       3551 return wantarray ? (-e _,@_) : -e _;
2904             }
2905              
2906             # return false if directory handle
2907             elsif (defined Einformixv6als::telldir($fh)) {
2908 0 0       0 return wantarray ? ('',@_) : '';
2909             }
2910              
2911             # return true if file handle
2912             elsif (defined fileno $fh) {
2913 0 0       0 return wantarray ? (1,@_) : 1;
2914             }
2915              
2916             elsif (-e $_) {
2917 0 0       0 return wantarray ? (1,@_) : 1;
2918             }
2919             elsif (_MSWin32_5Cended_path($_)) {
2920 0 0       0 if (-d "$_/.") {
2921 0 0       0 return wantarray ? (1,@_) : 1;
2922             }
2923             else {
2924 0         0 my $fh = gensym();
2925 0 0       0 if (_open_r($fh, $_)) {
2926 0         0 my $e = -e $fh;
2927 0 0       0 close($fh) or die "Can't close file: $_: $!";
2928 0 0       0 return wantarray ? ($e,@_) : $e;
2929             }
2930             }
2931             }
2932 0 50       0 return wantarray ? (undef,@_) : undef;
2933             }
2934              
2935             #
2936             # INFORMIX V6 ALS file test -z expr
2937             #
2938             sub Einformixv6als::z(;*@) {
2939              
2940 768 0   0 0 4738 local $_ = shift if @_;
2941 0 0 0     0 croak 'Too many arguments for -z (Einformixv6als::z)' if @_ and not wantarray;
2942              
2943 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2944 0 0       0 return wantarray ? (-z _,@_) : -z _;
2945             }
2946             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2947 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2948             }
2949             elsif (-e $_) {
2950 0 0       0 return wantarray ? (-z _,@_) : -z _;
2951             }
2952             elsif (_MSWin32_5Cended_path($_)) {
2953 0 0       0 if (-d "$_/.") {
2954 0 0       0 return wantarray ? (-z _,@_) : -z _;
2955             }
2956             else {
2957 0         0 my $fh = gensym();
2958 0 0       0 if (_open_r($fh, $_)) {
2959 0         0 my $z = -z $fh;
2960 0 0       0 close($fh) or die "Can't close file: $_: $!";
2961 0 0       0 return wantarray ? ($z,@_) : $z;
2962             }
2963             }
2964             }
2965 0 0       0 return wantarray ? (undef,@_) : undef;
2966             }
2967              
2968             #
2969             # INFORMIX V6 ALS file test -s expr
2970             #
2971             sub Einformixv6als::s(;*@) {
2972              
2973 0 0   0 0 0 local $_ = shift if @_;
2974 0 0 0     0 croak 'Too many arguments for -s (Einformixv6als::s)' if @_ and not wantarray;
2975              
2976 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2977 0 0       0 return wantarray ? (-s _,@_) : -s _;
2978             }
2979             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2980 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2981             }
2982             elsif (-e $_) {
2983 0 0       0 return wantarray ? (-s _,@_) : -s _;
2984             }
2985             elsif (_MSWin32_5Cended_path($_)) {
2986 0 0       0 if (-d "$_/.") {
2987 0 0       0 return wantarray ? (-s _,@_) : -s _;
2988             }
2989             else {
2990 0         0 my $fh = gensym();
2991 0 0       0 if (_open_r($fh, $_)) {
2992 0         0 my $s = -s $fh;
2993 0 0       0 close($fh) or die "Can't close file: $_: $!";
2994 0 0       0 return wantarray ? ($s,@_) : $s;
2995             }
2996             }
2997             }
2998 0 0       0 return wantarray ? (undef,@_) : undef;
2999             }
3000              
3001             #
3002             # INFORMIX V6 ALS file test -f expr
3003             #
3004             sub Einformixv6als::f(;*@) {
3005              
3006 0 0   0 0 0 local $_ = shift if @_;
3007 0 0 0     0 croak 'Too many arguments for -f (Einformixv6als::f)' if @_ and not wantarray;
3008              
3009 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3010 0 0       0 return wantarray ? (-f _,@_) : -f _;
3011             }
3012             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3013 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
3014             }
3015             elsif (-e $_) {
3016 0 0       0 return wantarray ? (-f _,@_) : -f _;
3017             }
3018             elsif (_MSWin32_5Cended_path($_)) {
3019 0 0       0 if (-d "$_/.") {
3020 0 0       0 return wantarray ? ('',@_) : '';
3021             }
3022             else {
3023 0         0 my $fh = gensym();
3024 0 0       0 if (_open_r($fh, $_)) {
3025 0         0 my $f = -f $fh;
3026 0 0       0 close($fh) or die "Can't close file: $_: $!";
3027 0 0       0 return wantarray ? ($f,@_) : $f;
3028             }
3029             }
3030             }
3031 0 0       0 return wantarray ? (undef,@_) : undef;
3032             }
3033              
3034             #
3035             # INFORMIX V6 ALS file test -d expr
3036             #
3037             sub Einformixv6als::d(;*@) {
3038              
3039 0 0   0 0 0 local $_ = shift if @_;
3040 0 0 0     0 croak 'Too many arguments for -d (Einformixv6als::d)' if @_ and not wantarray;
3041              
3042 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3043 0 0       0 return wantarray ? (-d _,@_) : -d _;
3044             }
3045              
3046             # return false if file handle or directory handle
3047             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3048 0 0       0 return wantarray ? ('',@_) : '';
3049             }
3050             elsif (-e $_) {
3051 0 0       0 return wantarray ? (-d _,@_) : -d _;
3052             }
3053             elsif (_MSWin32_5Cended_path($_)) {
3054 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3055             }
3056 0 0       0 return wantarray ? (undef,@_) : undef;
3057             }
3058              
3059             #
3060             # INFORMIX V6 ALS file test -l expr
3061             #
3062             sub Einformixv6als::l(;*@) {
3063              
3064 0 0   0 0 0 local $_ = shift if @_;
3065 0 0 0     0 croak 'Too many arguments for -l (Einformixv6als::l)' if @_ and not wantarray;
3066              
3067 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3068 0 0       0 return wantarray ? (-l _,@_) : -l _;
3069             }
3070             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3071 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3072             }
3073             elsif (-e $_) {
3074 0 0       0 return wantarray ? (-l _,@_) : -l _;
3075             }
3076             elsif (_MSWin32_5Cended_path($_)) {
3077 0 0       0 if (-d "$_/.") {
3078 0 0       0 return wantarray ? (-l _,@_) : -l _;
3079             }
3080             else {
3081 0         0 my $fh = gensym();
3082 0 0       0 if (_open_r($fh, $_)) {
3083 0         0 my $l = -l $fh;
3084 0 0       0 close($fh) or die "Can't close file: $_: $!";
3085 0 0       0 return wantarray ? ($l,@_) : $l;
3086             }
3087             }
3088             }
3089 0 0       0 return wantarray ? (undef,@_) : undef;
3090             }
3091              
3092             #
3093             # INFORMIX V6 ALS file test -p expr
3094             #
3095             sub Einformixv6als::p(;*@) {
3096              
3097 0 0   0 0 0 local $_ = shift if @_;
3098 0 0 0     0 croak 'Too many arguments for -p (Einformixv6als::p)' if @_ and not wantarray;
3099              
3100 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3101 0 0       0 return wantarray ? (-p _,@_) : -p _;
3102             }
3103             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3104 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3105             }
3106             elsif (-e $_) {
3107 0 0       0 return wantarray ? (-p _,@_) : -p _;
3108             }
3109             elsif (_MSWin32_5Cended_path($_)) {
3110 0 0       0 if (-d "$_/.") {
3111 0 0       0 return wantarray ? (-p _,@_) : -p _;
3112             }
3113             else {
3114 0         0 my $fh = gensym();
3115 0 0       0 if (_open_r($fh, $_)) {
3116 0         0 my $p = -p $fh;
3117 0 0       0 close($fh) or die "Can't close file: $_: $!";
3118 0 0       0 return wantarray ? ($p,@_) : $p;
3119             }
3120             }
3121             }
3122 0 0       0 return wantarray ? (undef,@_) : undef;
3123             }
3124              
3125             #
3126             # INFORMIX V6 ALS file test -S expr
3127             #
3128             sub Einformixv6als::S(;*@) {
3129              
3130 0 0   0 0 0 local $_ = shift if @_;
3131 0 0 0     0 croak 'Too many arguments for -S (Einformixv6als::S)' if @_ and not wantarray;
3132              
3133 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3134 0 0       0 return wantarray ? (-S _,@_) : -S _;
3135             }
3136             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3137 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3138             }
3139             elsif (-e $_) {
3140 0 0       0 return wantarray ? (-S _,@_) : -S _;
3141             }
3142             elsif (_MSWin32_5Cended_path($_)) {
3143 0 0       0 if (-d "$_/.") {
3144 0 0       0 return wantarray ? (-S _,@_) : -S _;
3145             }
3146             else {
3147 0         0 my $fh = gensym();
3148 0 0       0 if (_open_r($fh, $_)) {
3149 0         0 my $S = -S $fh;
3150 0 0       0 close($fh) or die "Can't close file: $_: $!";
3151 0 0       0 return wantarray ? ($S,@_) : $S;
3152             }
3153             }
3154             }
3155 0 0       0 return wantarray ? (undef,@_) : undef;
3156             }
3157              
3158             #
3159             # INFORMIX V6 ALS file test -b expr
3160             #
3161             sub Einformixv6als::b(;*@) {
3162              
3163 0 0   0 0 0 local $_ = shift if @_;
3164 0 0 0     0 croak 'Too many arguments for -b (Einformixv6als::b)' if @_ and not wantarray;
3165              
3166 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3167 0 0       0 return wantarray ? (-b _,@_) : -b _;
3168             }
3169             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3170 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3171             }
3172             elsif (-e $_) {
3173 0 0       0 return wantarray ? (-b _,@_) : -b _;
3174             }
3175             elsif (_MSWin32_5Cended_path($_)) {
3176 0 0       0 if (-d "$_/.") {
3177 0 0       0 return wantarray ? (-b _,@_) : -b _;
3178             }
3179             else {
3180 0         0 my $fh = gensym();
3181 0 0       0 if (_open_r($fh, $_)) {
3182 0         0 my $b = -b $fh;
3183 0 0       0 close($fh) or die "Can't close file: $_: $!";
3184 0 0       0 return wantarray ? ($b,@_) : $b;
3185             }
3186             }
3187             }
3188 0 0       0 return wantarray ? (undef,@_) : undef;
3189             }
3190              
3191             #
3192             # INFORMIX V6 ALS file test -c expr
3193             #
3194             sub Einformixv6als::c(;*@) {
3195              
3196 0 0   0 0 0 local $_ = shift if @_;
3197 0 0 0     0 croak 'Too many arguments for -c (Einformixv6als::c)' if @_ and not wantarray;
3198              
3199 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3200 0 0       0 return wantarray ? (-c _,@_) : -c _;
3201             }
3202             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3203 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3204             }
3205             elsif (-e $_) {
3206 0 0       0 return wantarray ? (-c _,@_) : -c _;
3207             }
3208             elsif (_MSWin32_5Cended_path($_)) {
3209 0 0       0 if (-d "$_/.") {
3210 0 0       0 return wantarray ? (-c _,@_) : -c _;
3211             }
3212             else {
3213 0         0 my $fh = gensym();
3214 0 0       0 if (_open_r($fh, $_)) {
3215 0         0 my $c = -c $fh;
3216 0 0       0 close($fh) or die "Can't close file: $_: $!";
3217 0 0       0 return wantarray ? ($c,@_) : $c;
3218             }
3219             }
3220             }
3221 0 0       0 return wantarray ? (undef,@_) : undef;
3222             }
3223              
3224             #
3225             # INFORMIX V6 ALS file test -u expr
3226             #
3227             sub Einformixv6als::u(;*@) {
3228              
3229 0 0   0 0 0 local $_ = shift if @_;
3230 0 0 0     0 croak 'Too many arguments for -u (Einformixv6als::u)' if @_ and not wantarray;
3231              
3232 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3233 0 0       0 return wantarray ? (-u _,@_) : -u _;
3234             }
3235             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3236 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3237             }
3238             elsif (-e $_) {
3239 0 0       0 return wantarray ? (-u _,@_) : -u _;
3240             }
3241             elsif (_MSWin32_5Cended_path($_)) {
3242 0 0       0 if (-d "$_/.") {
3243 0 0       0 return wantarray ? (-u _,@_) : -u _;
3244             }
3245             else {
3246 0         0 my $fh = gensym();
3247 0 0       0 if (_open_r($fh, $_)) {
3248 0         0 my $u = -u $fh;
3249 0 0       0 close($fh) or die "Can't close file: $_: $!";
3250 0 0       0 return wantarray ? ($u,@_) : $u;
3251             }
3252             }
3253             }
3254 0 0       0 return wantarray ? (undef,@_) : undef;
3255             }
3256              
3257             #
3258             # INFORMIX V6 ALS file test -g expr
3259             #
3260             sub Einformixv6als::g(;*@) {
3261              
3262 0 0   0 0 0 local $_ = shift if @_;
3263 0 0 0     0 croak 'Too many arguments for -g (Einformixv6als::g)' if @_ and not wantarray;
3264              
3265 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3266 0 0       0 return wantarray ? (-g _,@_) : -g _;
3267             }
3268             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3269 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3270             }
3271             elsif (-e $_) {
3272 0 0       0 return wantarray ? (-g _,@_) : -g _;
3273             }
3274             elsif (_MSWin32_5Cended_path($_)) {
3275 0 0       0 if (-d "$_/.") {
3276 0 0       0 return wantarray ? (-g _,@_) : -g _;
3277             }
3278             else {
3279 0         0 my $fh = gensym();
3280 0 0       0 if (_open_r($fh, $_)) {
3281 0         0 my $g = -g $fh;
3282 0 0       0 close($fh) or die "Can't close file: $_: $!";
3283 0 0       0 return wantarray ? ($g,@_) : $g;
3284             }
3285             }
3286             }
3287 0 0       0 return wantarray ? (undef,@_) : undef;
3288             }
3289              
3290             #
3291             # INFORMIX V6 ALS file test -k expr
3292             #
3293             sub Einformixv6als::k(;*@) {
3294              
3295 0 0   0 0 0 local $_ = shift if @_;
3296 0 0 0     0 croak 'Too many arguments for -k (Einformixv6als::k)' if @_ and not wantarray;
3297              
3298 0 0       0 if ($_ eq '_') {
    0          
    0          
3299 0 0       0 return wantarray ? ('',@_) : '';
3300             }
3301             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3302 0 0       0 return wantarray ? ('',@_) : '';
3303             }
3304             elsif ($] =~ /^5\.008/oxms) {
3305 0 0       0 return wantarray ? ('',@_) : '';
3306             }
3307 0 0       0 return wantarray ? ($_,@_) : $_;
3308             }
3309              
3310             #
3311             # INFORMIX V6 ALS file test -T expr
3312             #
3313             sub Einformixv6als::T(;*@) {
3314              
3315 0 0   0 0 0 local $_ = shift if @_;
3316              
3317             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3318             # croak 'Too many arguments for -T (Einformixv6als::T)';
3319             # Must be used by parentheses like:
3320             # croak('Too many arguments for -T (Einformixv6als::T)');
3321              
3322 0 0 0     0 if (@_ and not wantarray) {
3323 0         0 croak('Too many arguments for -T (Einformixv6als::T)');
3324             }
3325              
3326 0         0 my $T = 1;
3327              
3328 0         0 my $fh = qualify_to_ref $_;
3329 0 0       0 if (defined fileno $fh) {
3330              
3331 0 0       0 if (defined Einformixv6als::telldir($fh)) {
3332 0 0       0 return wantarray ? (undef,@_) : undef;
3333             }
3334              
3335             # P.813 29.2.176. tell
3336             # in Chapter 29: Functions
3337             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3338              
3339             # P.970 tell
3340             # in Chapter 27: Functions
3341             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3342              
3343             # (and so on)
3344              
3345 0         0 my $systell = sysseek $fh, 0, 1;
3346              
3347 0 0       0 if (sysread $fh, my $block, 512) {
3348              
3349             # P.163 Binary file check in Little Perl Parlor 16
3350             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3351             # (and so on)
3352              
3353 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3354 0         0 $T = '';
3355             }
3356             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3357 0         0 $T = '';
3358             }
3359             }
3360              
3361             # 0 byte or eof
3362             else {
3363 0         0 $T = 1;
3364             }
3365              
3366 0         0 my $dummy_for_underline_cache = -T $fh;
3367 0         0 sysseek $fh, $systell, 0;
3368             }
3369             else {
3370 0 0 0     0 if (-d $_ or -d "$_/.") {
3371 0 0       0 return wantarray ? (undef,@_) : undef;
3372             }
3373              
3374 0         0 $fh = gensym();
3375 0 0       0 if (_open_r($fh, $_)) {
3376             }
3377             else {
3378 0 0       0 return wantarray ? (undef,@_) : undef;
3379             }
3380 0 0       0 if (sysread $fh, my $block, 512) {
3381 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3382 0         0 $T = '';
3383             }
3384             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3385 0         0 $T = '';
3386             }
3387             }
3388              
3389             # 0 byte or eof
3390             else {
3391 0         0 $T = 1;
3392             }
3393 0         0 my $dummy_for_underline_cache = -T $fh;
3394 0 0       0 close($fh) or die "Can't close file: $_: $!";
3395             }
3396              
3397 0 0       0 return wantarray ? ($T,@_) : $T;
3398             }
3399              
3400             #
3401             # INFORMIX V6 ALS file test -B expr
3402             #
3403             sub Einformixv6als::B(;*@) {
3404              
3405 0 0   0 0 0 local $_ = shift if @_;
3406 0 0 0     0 croak 'Too many arguments for -B (Einformixv6als::B)' if @_ and not wantarray;
3407 0         0 my $B = '';
3408              
3409 0         0 my $fh = qualify_to_ref $_;
3410 0 0       0 if (defined fileno $fh) {
3411              
3412 0 0       0 if (defined Einformixv6als::telldir($fh)) {
3413 0 0       0 return wantarray ? (undef,@_) : undef;
3414             }
3415              
3416 0         0 my $systell = sysseek $fh, 0, 1;
3417              
3418 0 0       0 if (sysread $fh, my $block, 512) {
3419 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3420 0         0 $B = 1;
3421             }
3422             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3423 0         0 $B = 1;
3424             }
3425             }
3426              
3427             # 0 byte or eof
3428             else {
3429 0         0 $B = 1;
3430             }
3431              
3432 0         0 my $dummy_for_underline_cache = -B $fh;
3433 0         0 sysseek $fh, $systell, 0;
3434             }
3435             else {
3436 0 0 0     0 if (-d $_ or -d "$_/.") {
3437 0 0       0 return wantarray ? (undef,@_) : undef;
3438             }
3439              
3440 0         0 $fh = gensym();
3441 0 0       0 if (_open_r($fh, $_)) {
3442             }
3443             else {
3444 0 0       0 return wantarray ? (undef,@_) : undef;
3445             }
3446 0 0       0 if (sysread $fh, my $block, 512) {
3447 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3448 0         0 $B = 1;
3449             }
3450             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3451 0         0 $B = 1;
3452             }
3453             }
3454              
3455             # 0 byte or eof
3456             else {
3457 0         0 $B = 1;
3458             }
3459 0         0 my $dummy_for_underline_cache = -B $fh;
3460 0 0       0 close($fh) or die "Can't close file: $_: $!";
3461             }
3462              
3463 0 0       0 return wantarray ? ($B,@_) : $B;
3464             }
3465              
3466             #
3467             # INFORMIX V6 ALS file test -M expr
3468             #
3469             sub Einformixv6als::M(;*@) {
3470              
3471 0 0   0 0 0 local $_ = shift if @_;
3472 0 0 0     0 croak 'Too many arguments for -M (Einformixv6als::M)' if @_ and not wantarray;
3473              
3474 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3475 0 0       0 return wantarray ? (-M _,@_) : -M _;
3476             }
3477             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3478 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3479             }
3480             elsif (-e $_) {
3481 0 0       0 return wantarray ? (-M _,@_) : -M _;
3482             }
3483             elsif (_MSWin32_5Cended_path($_)) {
3484 0 0       0 if (-d "$_/.") {
3485 0 0       0 return wantarray ? (-M _,@_) : -M _;
3486             }
3487             else {
3488 0         0 my $fh = gensym();
3489 0 0       0 if (_open_r($fh, $_)) {
3490 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3491 0 0       0 close($fh) or die "Can't close file: $_: $!";
3492 0         0 my $M = ($^T - $mtime) / (24*60*60);
3493 0 0       0 return wantarray ? ($M,@_) : $M;
3494             }
3495             }
3496             }
3497 0 0       0 return wantarray ? (undef,@_) : undef;
3498             }
3499              
3500             #
3501             # INFORMIX V6 ALS file test -A expr
3502             #
3503             sub Einformixv6als::A(;*@) {
3504              
3505 0 0   0 0 0 local $_ = shift if @_;
3506 0 0 0     0 croak 'Too many arguments for -A (Einformixv6als::A)' if @_ and not wantarray;
3507              
3508 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3509 0 0       0 return wantarray ? (-A _,@_) : -A _;
3510             }
3511             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3512 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3513             }
3514             elsif (-e $_) {
3515 0 0       0 return wantarray ? (-A _,@_) : -A _;
3516             }
3517             elsif (_MSWin32_5Cended_path($_)) {
3518 0 0       0 if (-d "$_/.") {
3519 0 0       0 return wantarray ? (-A _,@_) : -A _;
3520             }
3521             else {
3522 0         0 my $fh = gensym();
3523 0 0       0 if (_open_r($fh, $_)) {
3524 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3525 0 0       0 close($fh) or die "Can't close file: $_: $!";
3526 0         0 my $A = ($^T - $atime) / (24*60*60);
3527 0 0       0 return wantarray ? ($A,@_) : $A;
3528             }
3529             }
3530             }
3531 0 0       0 return wantarray ? (undef,@_) : undef;
3532             }
3533              
3534             #
3535             # INFORMIX V6 ALS file test -C expr
3536             #
3537             sub Einformixv6als::C(;*@) {
3538              
3539 0 0   0 0 0 local $_ = shift if @_;
3540 0 0 0     0 croak 'Too many arguments for -C (Einformixv6als::C)' if @_ and not wantarray;
3541              
3542 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3543 0 0       0 return wantarray ? (-C _,@_) : -C _;
3544             }
3545             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3546 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3547             }
3548             elsif (-e $_) {
3549 0 0       0 return wantarray ? (-C _,@_) : -C _;
3550             }
3551             elsif (_MSWin32_5Cended_path($_)) {
3552 0 0       0 if (-d "$_/.") {
3553 0 0       0 return wantarray ? (-C _,@_) : -C _;
3554             }
3555             else {
3556 0         0 my $fh = gensym();
3557 0 0       0 if (_open_r($fh, $_)) {
3558 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3559 0 0       0 close($fh) or die "Can't close file: $_: $!";
3560 0         0 my $C = ($^T - $ctime) / (24*60*60);
3561 0 0       0 return wantarray ? ($C,@_) : $C;
3562             }
3563             }
3564             }
3565 0 0       0 return wantarray ? (undef,@_) : undef;
3566             }
3567              
3568             #
3569             # INFORMIX V6 ALS stacked file test $_
3570             #
3571             sub Einformixv6als::filetest_ {
3572              
3573 0     0 0 0 my $filetest = substr(pop @_, 1);
3574              
3575 0 0       0 unless (CORE::eval qq{Einformixv6als::${filetest}_}) {
3576 0         0 return '';
3577             }
3578 0         0 for my $filetest (CORE::reverse @_) {
3579 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3580 0         0 return '';
3581             }
3582             }
3583 0         0 return 1;
3584             }
3585              
3586             #
3587             # INFORMIX V6 ALS file test -r $_
3588             #
3589             sub Einformixv6als::r_() {
3590              
3591 0 0   0 0 0 if (-e $_) {
    0          
3592 0 0       0 return -r _ ? 1 : '';
3593             }
3594             elsif (_MSWin32_5Cended_path($_)) {
3595 0 0       0 if (-d "$_/.") {
3596 0 0       0 return -r _ ? 1 : '';
3597             }
3598             else {
3599 0         0 my $fh = gensym();
3600 0 0       0 if (_open_r($fh, $_)) {
3601 0         0 my $r = -r $fh;
3602 0 0       0 close($fh) or die "Can't close file: $_: $!";
3603 0 0       0 return $r ? 1 : '';
3604             }
3605             }
3606             }
3607              
3608             # 10.10. Returning Failure
3609             # in Chapter 10. Subroutines
3610             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3611             # (and so on)
3612              
3613             # 2010-01-26 The difference of "return;" and "return undef;"
3614             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3615             #
3616             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3617             # it might be wrong in some cases. If you use this idiom for those functions
3618             # which are expected to return a scalar value, e.g. searching functions, the
3619             # user of those functions will be surprised at what they return in list
3620             # context, an empty list - note that many functions and all the methods
3621             # evaluate their arguments in list context. You'd better to use "return undef;"
3622             # for such scalar functions.
3623             #
3624             # sub search_something {
3625             # my($arg) = @_;
3626             # # search_something...
3627             # if(defined $found){
3628             # return $found;
3629             # }
3630             # return; # XXX: you'd better to "return undef;"
3631             # }
3632             #
3633             # # ...
3634             #
3635             # # you'll get what you want, but ...
3636             # my $something = search_something($source);
3637             #
3638             # # you won't get what you want here.
3639             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3640             # $obj->doit(search_something($source), -option=> $optval);
3641             #
3642             # # you have to use the "scalar" operator in such a case.
3643             # $obj->doit(scalar search_something($source), ...);
3644             #
3645             # *1: it returns an empty list in list context, or returns undef in scalar
3646             # context
3647             #
3648             # (and so on)
3649              
3650 0         0 return undef;
3651             }
3652              
3653             #
3654             # INFORMIX V6 ALS file test -w $_
3655             #
3656             sub Einformixv6als::w_() {
3657              
3658 0 0   0 0 0 if (-e $_) {
    0          
3659 0 0       0 return -w _ ? 1 : '';
3660             }
3661             elsif (_MSWin32_5Cended_path($_)) {
3662 0 0       0 if (-d "$_/.") {
3663 0 0       0 return -w _ ? 1 : '';
3664             }
3665             else {
3666 0         0 my $fh = gensym();
3667 0 0       0 if (_open_a($fh, $_)) {
3668 0         0 my $w = -w $fh;
3669 0 0       0 close($fh) or die "Can't close file: $_: $!";
3670 0 0       0 return $w ? 1 : '';
3671             }
3672             }
3673             }
3674 0         0 return undef;
3675             }
3676              
3677             #
3678             # INFORMIX V6 ALS file test -x $_
3679             #
3680             sub Einformixv6als::x_() {
3681              
3682 0 0   0 0 0 if (-e $_) {
    0          
3683 0 0       0 return -x _ ? 1 : '';
3684             }
3685             elsif (_MSWin32_5Cended_path($_)) {
3686 0 0       0 if (-d "$_/.") {
3687 0 0       0 return -x _ ? 1 : '';
3688             }
3689             else {
3690 0         0 my $fh = gensym();
3691 0 0       0 if (_open_r($fh, $_)) {
3692 0         0 my $dummy_for_underline_cache = -x $fh;
3693 0 0       0 close($fh) or die "Can't close file: $_: $!";
3694             }
3695              
3696             # filename is not .COM .EXE .BAT .CMD
3697 0         0 return '';
3698             }
3699             }
3700 0         0 return undef;
3701             }
3702              
3703             #
3704             # INFORMIX V6 ALS file test -o $_
3705             #
3706             sub Einformixv6als::o_() {
3707              
3708 0 0   0 0 0 if (-e $_) {
    0          
3709 0 0       0 return -o _ ? 1 : '';
3710             }
3711             elsif (_MSWin32_5Cended_path($_)) {
3712 0 0       0 if (-d "$_/.") {
3713 0 0       0 return -o _ ? 1 : '';
3714             }
3715             else {
3716 0         0 my $fh = gensym();
3717 0 0       0 if (_open_r($fh, $_)) {
3718 0         0 my $o = -o $fh;
3719 0 0       0 close($fh) or die "Can't close file: $_: $!";
3720 0 0       0 return $o ? 1 : '';
3721             }
3722             }
3723             }
3724 0         0 return undef;
3725             }
3726              
3727             #
3728             # INFORMIX V6 ALS file test -R $_
3729             #
3730             sub Einformixv6als::R_() {
3731              
3732 0 0   0 0 0 if (-e $_) {
    0          
3733 0 0       0 return -R _ ? 1 : '';
3734             }
3735             elsif (_MSWin32_5Cended_path($_)) {
3736 0 0       0 if (-d "$_/.") {
3737 0 0       0 return -R _ ? 1 : '';
3738             }
3739             else {
3740 0         0 my $fh = gensym();
3741 0 0       0 if (_open_r($fh, $_)) {
3742 0         0 my $R = -R $fh;
3743 0 0       0 close($fh) or die "Can't close file: $_: $!";
3744 0 0       0 return $R ? 1 : '';
3745             }
3746             }
3747             }
3748 0         0 return undef;
3749             }
3750              
3751             #
3752             # INFORMIX V6 ALS file test -W $_
3753             #
3754             sub Einformixv6als::W_() {
3755              
3756 0 0   0 0 0 if (-e $_) {
    0          
3757 0 0       0 return -W _ ? 1 : '';
3758             }
3759             elsif (_MSWin32_5Cended_path($_)) {
3760 0 0       0 if (-d "$_/.") {
3761 0 0       0 return -W _ ? 1 : '';
3762             }
3763             else {
3764 0         0 my $fh = gensym();
3765 0 0       0 if (_open_a($fh, $_)) {
3766 0         0 my $W = -W $fh;
3767 0 0       0 close($fh) or die "Can't close file: $_: $!";
3768 0 0       0 return $W ? 1 : '';
3769             }
3770             }
3771             }
3772 0         0 return undef;
3773             }
3774              
3775             #
3776             # INFORMIX V6 ALS file test -X $_
3777             #
3778             sub Einformixv6als::X_() {
3779              
3780 0 0   0 0 0 if (-e $_) {
    0          
3781 0 0       0 return -X _ ? 1 : '';
3782             }
3783             elsif (_MSWin32_5Cended_path($_)) {
3784 0 0       0 if (-d "$_/.") {
3785 0 0       0 return -X _ ? 1 : '';
3786             }
3787             else {
3788 0         0 my $fh = gensym();
3789 0 0       0 if (_open_r($fh, $_)) {
3790 0         0 my $dummy_for_underline_cache = -X $fh;
3791 0 0       0 close($fh) or die "Can't close file: $_: $!";
3792             }
3793              
3794             # filename is not .COM .EXE .BAT .CMD
3795 0         0 return '';
3796             }
3797             }
3798 0         0 return undef;
3799             }
3800              
3801             #
3802             # INFORMIX V6 ALS file test -O $_
3803             #
3804             sub Einformixv6als::O_() {
3805              
3806 0 0   0 0 0 if (-e $_) {
    0          
3807 0 0       0 return -O _ ? 1 : '';
3808             }
3809             elsif (_MSWin32_5Cended_path($_)) {
3810 0 0       0 if (-d "$_/.") {
3811 0 0       0 return -O _ ? 1 : '';
3812             }
3813             else {
3814 0         0 my $fh = gensym();
3815 0 0       0 if (_open_r($fh, $_)) {
3816 0         0 my $O = -O $fh;
3817 0 0       0 close($fh) or die "Can't close file: $_: $!";
3818 0 0       0 return $O ? 1 : '';
3819             }
3820             }
3821             }
3822 0         0 return undef;
3823             }
3824              
3825             #
3826             # INFORMIX V6 ALS file test -e $_
3827             #
3828             sub Einformixv6als::e_() {
3829              
3830 0 0   0 0 0 if (-e $_) {
    0          
3831 0         0 return 1;
3832             }
3833             elsif (_MSWin32_5Cended_path($_)) {
3834 0 0       0 if (-d "$_/.") {
3835 0         0 return 1;
3836             }
3837             else {
3838 0         0 my $fh = gensym();
3839 0 0       0 if (_open_r($fh, $_)) {
3840 0         0 my $e = -e $fh;
3841 0 0       0 close($fh) or die "Can't close file: $_: $!";
3842 0 0       0 return $e ? 1 : '';
3843             }
3844             }
3845             }
3846 0         0 return undef;
3847             }
3848              
3849             #
3850             # INFORMIX V6 ALS file test -z $_
3851             #
3852             sub Einformixv6als::z_() {
3853              
3854 0 0   0 0 0 if (-e $_) {
    0          
3855 0 0       0 return -z _ ? 1 : '';
3856             }
3857             elsif (_MSWin32_5Cended_path($_)) {
3858 0 0       0 if (-d "$_/.") {
3859 0 0       0 return -z _ ? 1 : '';
3860             }
3861             else {
3862 0         0 my $fh = gensym();
3863 0 0       0 if (_open_r($fh, $_)) {
3864 0         0 my $z = -z $fh;
3865 0 0       0 close($fh) or die "Can't close file: $_: $!";
3866 0 0       0 return $z ? 1 : '';
3867             }
3868             }
3869             }
3870 0         0 return undef;
3871             }
3872              
3873             #
3874             # INFORMIX V6 ALS file test -s $_
3875             #
3876             sub Einformixv6als::s_() {
3877              
3878 0 0   0 0 0 if (-e $_) {
    0          
3879 0         0 return -s _;
3880             }
3881             elsif (_MSWin32_5Cended_path($_)) {
3882 0 0       0 if (-d "$_/.") {
3883 0         0 return -s _;
3884             }
3885             else {
3886 0         0 my $fh = gensym();
3887 0 0       0 if (_open_r($fh, $_)) {
3888 0         0 my $s = -s $fh;
3889 0 0       0 close($fh) or die "Can't close file: $_: $!";
3890 0         0 return $s;
3891             }
3892             }
3893             }
3894 0         0 return undef;
3895             }
3896              
3897             #
3898             # INFORMIX V6 ALS file test -f $_
3899             #
3900             sub Einformixv6als::f_() {
3901              
3902 0 0   0 0 0 if (-e $_) {
    0          
3903 0 0       0 return -f _ ? 1 : '';
3904             }
3905             elsif (_MSWin32_5Cended_path($_)) {
3906 0 0       0 if (-d "$_/.") {
3907 0         0 return '';
3908             }
3909             else {
3910 0         0 my $fh = gensym();
3911 0 0       0 if (_open_r($fh, $_)) {
3912 0         0 my $f = -f $fh;
3913 0 0       0 close($fh) or die "Can't close file: $_: $!";
3914 0 0       0 return $f ? 1 : '';
3915             }
3916             }
3917             }
3918 0         0 return undef;
3919             }
3920              
3921             #
3922             # INFORMIX V6 ALS file test -d $_
3923             #
3924             sub Einformixv6als::d_() {
3925              
3926 0 0   0 0 0 if (-e $_) {
    0          
3927 0 0       0 return -d _ ? 1 : '';
3928             }
3929             elsif (_MSWin32_5Cended_path($_)) {
3930 0 0       0 return -d "$_/." ? 1 : '';
3931             }
3932 0         0 return undef;
3933             }
3934              
3935             #
3936             # INFORMIX V6 ALS file test -l $_
3937             #
3938             sub Einformixv6als::l_() {
3939              
3940 0 0   0 0 0 if (-e $_) {
    0          
3941 0 0       0 return -l _ ? 1 : '';
3942             }
3943             elsif (_MSWin32_5Cended_path($_)) {
3944 0 0       0 if (-d "$_/.") {
3945 0 0       0 return -l _ ? 1 : '';
3946             }
3947             else {
3948 0         0 my $fh = gensym();
3949 0 0       0 if (_open_r($fh, $_)) {
3950 0         0 my $l = -l $fh;
3951 0 0       0 close($fh) or die "Can't close file: $_: $!";
3952 0 0       0 return $l ? 1 : '';
3953             }
3954             }
3955             }
3956 0         0 return undef;
3957             }
3958              
3959             #
3960             # INFORMIX V6 ALS file test -p $_
3961             #
3962             sub Einformixv6als::p_() {
3963              
3964 0 0   0 0 0 if (-e $_) {
    0          
3965 0 0       0 return -p _ ? 1 : '';
3966             }
3967             elsif (_MSWin32_5Cended_path($_)) {
3968 0 0       0 if (-d "$_/.") {
3969 0 0       0 return -p _ ? 1 : '';
3970             }
3971             else {
3972 0         0 my $fh = gensym();
3973 0 0       0 if (_open_r($fh, $_)) {
3974 0         0 my $p = -p $fh;
3975 0 0       0 close($fh) or die "Can't close file: $_: $!";
3976 0 0       0 return $p ? 1 : '';
3977             }
3978             }
3979             }
3980 0         0 return undef;
3981             }
3982              
3983             #
3984             # INFORMIX V6 ALS file test -S $_
3985             #
3986             sub Einformixv6als::S_() {
3987              
3988 0 0   0 0 0 if (-e $_) {
    0          
3989 0 0       0 return -S _ ? 1 : '';
3990             }
3991             elsif (_MSWin32_5Cended_path($_)) {
3992 0 0       0 if (-d "$_/.") {
3993 0 0       0 return -S _ ? 1 : '';
3994             }
3995             else {
3996 0         0 my $fh = gensym();
3997 0 0       0 if (_open_r($fh, $_)) {
3998 0         0 my $S = -S $fh;
3999 0 0       0 close($fh) or die "Can't close file: $_: $!";
4000 0 0       0 return $S ? 1 : '';
4001             }
4002             }
4003             }
4004 0         0 return undef;
4005             }
4006              
4007             #
4008             # INFORMIX V6 ALS file test -b $_
4009             #
4010             sub Einformixv6als::b_() {
4011              
4012 0 0   0 0 0 if (-e $_) {
    0          
4013 0 0       0 return -b _ ? 1 : '';
4014             }
4015             elsif (_MSWin32_5Cended_path($_)) {
4016 0 0       0 if (-d "$_/.") {
4017 0 0       0 return -b _ ? 1 : '';
4018             }
4019             else {
4020 0         0 my $fh = gensym();
4021 0 0       0 if (_open_r($fh, $_)) {
4022 0         0 my $b = -b $fh;
4023 0 0       0 close($fh) or die "Can't close file: $_: $!";
4024 0 0       0 return $b ? 1 : '';
4025             }
4026             }
4027             }
4028 0         0 return undef;
4029             }
4030              
4031             #
4032             # INFORMIX V6 ALS file test -c $_
4033             #
4034             sub Einformixv6als::c_() {
4035              
4036 0 0   0 0 0 if (-e $_) {
    0          
4037 0 0       0 return -c _ ? 1 : '';
4038             }
4039             elsif (_MSWin32_5Cended_path($_)) {
4040 0 0       0 if (-d "$_/.") {
4041 0 0       0 return -c _ ? 1 : '';
4042             }
4043             else {
4044 0         0 my $fh = gensym();
4045 0 0       0 if (_open_r($fh, $_)) {
4046 0         0 my $c = -c $fh;
4047 0 0       0 close($fh) or die "Can't close file: $_: $!";
4048 0 0       0 return $c ? 1 : '';
4049             }
4050             }
4051             }
4052 0         0 return undef;
4053             }
4054              
4055             #
4056             # INFORMIX V6 ALS file test -u $_
4057             #
4058             sub Einformixv6als::u_() {
4059              
4060 0 0   0 0 0 if (-e $_) {
    0          
4061 0 0       0 return -u _ ? 1 : '';
4062             }
4063             elsif (_MSWin32_5Cended_path($_)) {
4064 0 0       0 if (-d "$_/.") {
4065 0 0       0 return -u _ ? 1 : '';
4066             }
4067             else {
4068 0         0 my $fh = gensym();
4069 0 0       0 if (_open_r($fh, $_)) {
4070 0         0 my $u = -u $fh;
4071 0 0       0 close($fh) or die "Can't close file: $_: $!";
4072 0 0       0 return $u ? 1 : '';
4073             }
4074             }
4075             }
4076 0         0 return undef;
4077             }
4078              
4079             #
4080             # INFORMIX V6 ALS file test -g $_
4081             #
4082             sub Einformixv6als::g_() {
4083              
4084 0 0   0 0 0 if (-e $_) {
    0          
4085 0 0       0 return -g _ ? 1 : '';
4086             }
4087             elsif (_MSWin32_5Cended_path($_)) {
4088 0 0       0 if (-d "$_/.") {
4089 0 0       0 return -g _ ? 1 : '';
4090             }
4091             else {
4092 0         0 my $fh = gensym();
4093 0 0       0 if (_open_r($fh, $_)) {
4094 0         0 my $g = -g $fh;
4095 0 0       0 close($fh) or die "Can't close file: $_: $!";
4096 0 0       0 return $g ? 1 : '';
4097             }
4098             }
4099             }
4100 0         0 return undef;
4101             }
4102              
4103             #
4104             # INFORMIX V6 ALS file test -k $_
4105             #
4106             sub Einformixv6als::k_() {
4107              
4108 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4109 0 0       0 return wantarray ? ('',@_) : '';
4110             }
4111 0 0       0 return wantarray ? ($_,@_) : $_;
4112             }
4113              
4114             #
4115             # INFORMIX V6 ALS file test -T $_
4116             #
4117             sub Einformixv6als::T_() {
4118              
4119 0     0 0 0 my $T = 1;
4120              
4121 0 0 0     0 if (-d $_ or -d "$_/.") {
4122 0         0 return undef;
4123             }
4124 0         0 my $fh = gensym();
4125 0 0       0 if (_open_r($fh, $_)) {
4126             }
4127             else {
4128 0         0 return undef;
4129             }
4130              
4131 0 0       0 if (sysread $fh, my $block, 512) {
4132 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4133 0         0 $T = '';
4134             }
4135             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4136 0         0 $T = '';
4137             }
4138             }
4139              
4140             # 0 byte or eof
4141             else {
4142 0         0 $T = 1;
4143             }
4144 0         0 my $dummy_for_underline_cache = -T $fh;
4145 0 0       0 close($fh) or die "Can't close file: $_: $!";
4146              
4147 0         0 return $T;
4148             }
4149              
4150             #
4151             # INFORMIX V6 ALS file test -B $_
4152             #
4153             sub Einformixv6als::B_() {
4154              
4155 0     0 0 0 my $B = '';
4156              
4157 0 0 0     0 if (-d $_ or -d "$_/.") {
4158 0         0 return undef;
4159             }
4160 0         0 my $fh = gensym();
4161 0 0       0 if (_open_r($fh, $_)) {
4162             }
4163             else {
4164 0         0 return undef;
4165             }
4166              
4167 0 0       0 if (sysread $fh, my $block, 512) {
4168 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4169 0         0 $B = 1;
4170             }
4171             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4172 0         0 $B = 1;
4173             }
4174             }
4175              
4176             # 0 byte or eof
4177             else {
4178 0         0 $B = 1;
4179             }
4180 0         0 my $dummy_for_underline_cache = -B $fh;
4181 0 0       0 close($fh) or die "Can't close file: $_: $!";
4182              
4183 0         0 return $B;
4184             }
4185              
4186             #
4187             # INFORMIX V6 ALS file test -M $_
4188             #
4189             sub Einformixv6als::M_() {
4190              
4191 0 0   0 0 0 if (-e $_) {
    0          
4192 0         0 return -M _;
4193             }
4194             elsif (_MSWin32_5Cended_path($_)) {
4195 0 0       0 if (-d "$_/.") {
4196 0         0 return -M _;
4197             }
4198             else {
4199 0         0 my $fh = gensym();
4200 0 0       0 if (_open_r($fh, $_)) {
4201 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4202 0 0       0 close($fh) or die "Can't close file: $_: $!";
4203 0         0 my $M = ($^T - $mtime) / (24*60*60);
4204 0         0 return $M;
4205             }
4206             }
4207             }
4208 0         0 return undef;
4209             }
4210              
4211             #
4212             # INFORMIX V6 ALS file test -A $_
4213             #
4214             sub Einformixv6als::A_() {
4215              
4216 0 0   0 0 0 if (-e $_) {
    0          
4217 0         0 return -A _;
4218             }
4219             elsif (_MSWin32_5Cended_path($_)) {
4220 0 0       0 if (-d "$_/.") {
4221 0         0 return -A _;
4222             }
4223             else {
4224 0         0 my $fh = gensym();
4225 0 0       0 if (_open_r($fh, $_)) {
4226 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4227 0 0       0 close($fh) or die "Can't close file: $_: $!";
4228 0         0 my $A = ($^T - $atime) / (24*60*60);
4229 0         0 return $A;
4230             }
4231             }
4232             }
4233 0         0 return undef;
4234             }
4235              
4236             #
4237             # INFORMIX V6 ALS file test -C $_
4238             #
4239             sub Einformixv6als::C_() {
4240              
4241 0 0   0 0 0 if (-e $_) {
    0          
4242 0         0 return -C _;
4243             }
4244             elsif (_MSWin32_5Cended_path($_)) {
4245 0 0       0 if (-d "$_/.") {
4246 0         0 return -C _;
4247             }
4248             else {
4249 0         0 my $fh = gensym();
4250 0 0       0 if (_open_r($fh, $_)) {
4251 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4252 0 0       0 close($fh) or die "Can't close file: $_: $!";
4253 0         0 my $C = ($^T - $ctime) / (24*60*60);
4254 0         0 return $C;
4255             }
4256             }
4257             }
4258 0         0 return undef;
4259             }
4260              
4261             #
4262             # INFORMIX V6 ALS path globbing (with parameter)
4263             #
4264             sub Einformixv6als::glob($) {
4265              
4266 0 0   0 0 0 if (wantarray) {
4267 0         0 my @glob = _DOS_like_glob(@_);
4268 0         0 for my $glob (@glob) {
4269 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4270             }
4271 0         0 return @glob;
4272             }
4273             else {
4274 0         0 my $glob = _DOS_like_glob(@_);
4275 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4276 0         0 return $glob;
4277             }
4278             }
4279              
4280             #
4281             # INFORMIX V6 ALS path globbing (without parameter)
4282             #
4283             sub Einformixv6als::glob_() {
4284              
4285 0 0   0 0 0 if (wantarray) {
4286 0         0 my @glob = _DOS_like_glob();
4287 0         0 for my $glob (@glob) {
4288 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4289             }
4290 0         0 return @glob;
4291             }
4292             else {
4293 0         0 my $glob = _DOS_like_glob();
4294 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4295 0         0 return $glob;
4296             }
4297             }
4298              
4299             #
4300             # INFORMIX V6 ALS path globbing via File::DosGlob 1.10
4301             #
4302             # Often I confuse "_dosglob" and "_doglob".
4303             # So, I renamed "_dosglob" to "_DOS_like_glob".
4304             #
4305             my %iter;
4306             my %entries;
4307             sub _DOS_like_glob {
4308              
4309             # context (keyed by second cxix argument provided by core)
4310 0     0   0 my($expr,$cxix) = @_;
4311              
4312             # glob without args defaults to $_
4313 0 0       0 $expr = $_ if not defined $expr;
4314              
4315             # represents the current user's home directory
4316             #
4317             # 7.3. Expanding Tildes in Filenames
4318             # in Chapter 7. File Access
4319             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4320             #
4321             # and File::HomeDir, File::HomeDir::Windows module
4322              
4323             # DOS-like system
4324 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4325 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4326             { my_home_MSWin32() }oxmse;
4327             }
4328              
4329             # UNIX-like system
4330 0 0 0     0 else {
  0         0  
4331             $expr =~ s{ \A ~ ( (?:[^\x81-\x9F\xE0-\xFD/]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])* ) }
4332             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4333             }
4334 0 0       0  
4335 0 0       0 # assume global context if not provided one
4336             $cxix = '_G_' if not defined $cxix;
4337             $iter{$cxix} = 0 if not exists $iter{$cxix};
4338 0 0       0  
4339 0         0 # if we're just beginning, do it all first
4340             if ($iter{$cxix} == 0) {
4341             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4342             }
4343 0 0       0  
4344 0         0 # chuck it all out, quick or slow
4345 0         0 if (wantarray) {
  0         0  
4346             delete $iter{$cxix};
4347             return @{delete $entries{$cxix}};
4348 0 0       0 }
  0         0  
4349 0         0 else {
  0         0  
4350             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4351             return shift @{$entries{$cxix}};
4352             }
4353 0         0 else {
4354 0         0 # return undef for EOL
4355 0         0 delete $iter{$cxix};
4356             delete $entries{$cxix};
4357             return undef;
4358             }
4359             }
4360             }
4361              
4362             #
4363             # INFORMIX V6 ALS path globbing subroutine
4364             #
4365 0     0   0 sub _do_glob {
4366 0         0  
4367 0         0 my($cond,@expr) = @_;
4368             my @glob = ();
4369             my $fix_drive_relative_paths = 0;
4370 0         0  
4371 0 0       0 OUTER:
4372 0 0       0 for my $expr (@expr) {
4373             next OUTER if not defined $expr;
4374 0         0 next OUTER if $expr eq '';
4375 0         0  
4376 0         0 my @matched = ();
4377 0         0 my @globdir = ();
4378 0         0 my $head = '.';
4379             my $pathsep = '/';
4380             my $tail;
4381 0 0       0  
4382 0         0 # if argument is within quotes strip em and do no globbing
4383 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4384 0 0       0 $expr = $1;
4385 0         0 if ($cond eq 'd') {
4386             if (Einformixv6als::d $expr) {
4387             push @glob, $expr;
4388             }
4389 0 0       0 }
4390 0         0 else {
4391             if (Einformixv6als::e $expr) {
4392             push @glob, $expr;
4393 0         0 }
4394             }
4395             next OUTER;
4396             }
4397              
4398 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4399 0 0       0 # to h:./*.pm to expand correctly
4400 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4401             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\x9F\xE0-\xFD/\\]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4402             $fix_drive_relative_paths = 1;
4403             }
4404 0 0       0 }
4405 0 0       0  
4406 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4407 0         0 if ($tail eq '') {
4408             push @glob, $expr;
4409 0 0       0 next OUTER;
4410 0 0       0 }
4411 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4412 0         0 if (@globdir = _do_glob('d', $head)) {
4413             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4414             next OUTER;
4415 0 0 0     0 }
4416 0         0 }
4417             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4418 0         0 $head .= $pathsep;
4419             }
4420             $expr = $tail;
4421             }
4422 0 0       0  
4423 0 0       0 # If file component has no wildcards, we can avoid opendir
4424 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4425             if ($head eq '.') {
4426 0 0 0     0 $head = '';
4427 0         0 }
4428             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4429 0         0 $head .= $pathsep;
4430 0 0       0 }
4431 0 0       0 $head .= $expr;
4432 0         0 if ($cond eq 'd') {
4433             if (Einformixv6als::d $head) {
4434             push @glob, $head;
4435             }
4436 0 0       0 }
4437 0         0 else {
4438             if (Einformixv6als::e $head) {
4439             push @glob, $head;
4440 0         0 }
4441             }
4442 0 0       0 next OUTER;
4443 0         0 }
4444 0         0 Einformixv6als::opendir(*DIR, $head) or next OUTER;
4445             my @leaf = readdir DIR;
4446 0 0       0 closedir DIR;
4447 0         0  
4448             if ($head eq '.') {
4449 0 0 0     0 $head = '';
4450 0         0 }
4451             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4452             $head .= $pathsep;
4453 0         0 }
4454 0         0  
4455 0         0 my $pattern = '';
4456             while ($expr =~ / \G ($q_char) /oxgc) {
4457             my $char = $1;
4458              
4459             # 6.9. Matching Shell Globs as Regular Expressions
4460             # in Chapter 6. Pattern Matching
4461             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4462 0 0       0 # (and so on)
    0          
    0          
4463 0         0  
4464             if ($char eq '*') {
4465             $pattern .= "(?:$your_char)*",
4466 0         0 }
4467             elsif ($char eq '?') {
4468             $pattern .= "(?:$your_char)?", # DOS style
4469             # $pattern .= "(?:$your_char)", # UNIX style
4470 0         0 }
4471             elsif ((my $fc = Einformixv6als::fc($char)) ne $char) {
4472             $pattern .= $fc;
4473 0         0 }
4474             else {
4475             $pattern .= quotemeta $char;
4476 0     0   0 }
  0         0  
4477             }
4478             my $matchsub = sub { Einformixv6als::fc($_[0]) =~ /\A $pattern \z/xms };
4479              
4480             # if ($@) {
4481             # print STDERR "$0: $@\n";
4482             # next OUTER;
4483             # }
4484 0         0  
4485 0 0 0     0 INNER:
4486 0         0 for my $leaf (@leaf) {
4487             if ($leaf eq '.' or $leaf eq '..') {
4488 0 0 0     0 next INNER;
4489 0         0 }
4490             if ($cond eq 'd' and not Einformixv6als::d "$head$leaf") {
4491             next INNER;
4492 0 0       0 }
4493 0         0  
4494 0         0 if (&$matchsub($leaf)) {
4495             push @matched, "$head$leaf";
4496             next INNER;
4497             }
4498              
4499             # [DOS compatibility special case]
4500 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4501              
4502             if (Einformixv6als::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4503             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4504 0 0       0 Einformixv6als::index($pattern,'\\.') != -1 # pattern has a dot.
4505 0         0 ) {
4506 0         0 if (&$matchsub("$leaf.")) {
4507             push @matched, "$head$leaf";
4508             next INNER;
4509             }
4510 0 0       0 }
4511 0         0 }
4512             if (@matched) {
4513             push @glob, @matched;
4514 0 0       0 }
4515 0         0 }
4516 0         0 if ($fix_drive_relative_paths) {
4517             for my $glob (@glob) {
4518             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4519 0         0 }
4520             }
4521             return @glob;
4522             }
4523              
4524             #
4525             # INFORMIX V6 ALS parse line
4526             #
4527 0     0   0 sub _parse_line {
4528              
4529 0         0 my($line) = @_;
4530 0         0  
4531 0         0 $line .= ' ';
4532             my @piece = ();
4533             while ($line =~ /
4534             " ( (?>(?: [^\x81-\x9F\xE0-\xFD"] |[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4535             ( (?>(?: [^\x81-\x9F\xE0-\xFD"\s]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4536 0 0       0 /oxmsg
4537             ) {
4538 0         0 push @piece, defined($1) ? $1 : $2;
4539             }
4540             return @piece;
4541             }
4542              
4543             #
4544             # INFORMIX V6 ALS parse path
4545             #
4546 0     0   0 sub _parse_path {
4547              
4548 0         0 my($path,$pathsep) = @_;
4549 0         0  
4550 0         0 $path .= '/';
4551             my @subpath = ();
4552             while ($path =~ /
4553             ((?: [^\x81-\x9F\xE0-\xFD\/\\]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] )+?) [\/\\]
4554 0         0 /oxmsg
4555             ) {
4556             push @subpath, $1;
4557 0         0 }
4558 0         0  
4559 0         0 my $tail = pop @subpath;
4560             my $head = join $pathsep, @subpath;
4561             return $head, $tail;
4562             }
4563              
4564             #
4565             # via File::HomeDir::Windows 1.00
4566             #
4567             sub my_home_MSWin32 {
4568              
4569             # A lot of unix people and unix-derived tools rely on
4570 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4571 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4572             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4573             return $ENV{'HOME'};
4574             }
4575              
4576 0         0 # Do we have a user profile?
4577             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4578             return $ENV{'USERPROFILE'};
4579             }
4580              
4581 0         0 # Some Windows use something like $ENV{'HOME'}
4582             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4583             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4584 0         0 }
4585              
4586             return undef;
4587             }
4588              
4589             #
4590             # via File::HomeDir::Unix 1.00
4591 0     0 0 0 #
4592             sub my_home {
4593 0 0 0     0 my $home;
    0 0        
4594 0         0  
4595             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4596             $home = $ENV{'HOME'};
4597             }
4598              
4599             # This is from the original code, but I'm guessing
4600 0         0 # it means "login directory" and exists on some Unixes.
4601             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4602             $home = $ENV{'LOGDIR'};
4603             }
4604              
4605             ### More-desperate methods
4606              
4607 0         0 # Light desperation on any (Unixish) platform
4608             else {
4609             $home = CORE::eval q{ (getpwuid($<))[7] };
4610             }
4611              
4612 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4613 0         0 # For example, "nobody"-like users might use /nonexistant
4614             if (defined $home and ! Einformixv6als::d($home)) {
4615 0         0 $home = undef;
4616             }
4617             return $home;
4618             }
4619              
4620             #
4621             # INFORMIX V6 ALS file lstat (with parameter)
4622             #
4623 0 0   0 0 0 sub Einformixv6als::lstat(*) {
4624              
4625 0 0       0 local $_ = shift if @_;
    0          
4626 0         0  
4627             if (-e $_) {
4628             return CORE::lstat _;
4629             }
4630             elsif (_MSWin32_5Cended_path($_)) {
4631              
4632             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Einformixv6als::lstat()
4633             # on Windows opens the file for the path which has 5c at end.
4634 0         0 # (and so on)
4635 0 0       0  
4636 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4637 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4638 0 0       0 if (wantarray) {
4639 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4640             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4641             return @stat;
4642 0         0 }
4643 0 0       0 else {
4644 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4645             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4646             return $stat;
4647             }
4648 0 0       0 }
4649             }
4650             return wantarray ? () : undef;
4651             }
4652              
4653             #
4654             # INFORMIX V6 ALS file lstat (without parameter)
4655             #
4656 0 0   0 0 0 sub Einformixv6als::lstat_() {
    0          
4657 0         0  
4658             if (-e $_) {
4659             return CORE::lstat _;
4660 0         0 }
4661 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4662 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4663 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4664 0 0       0 if (wantarray) {
4665 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4666             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4667             return @stat;
4668 0         0 }
4669 0 0       0 else {
4670 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4671             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4672             return $stat;
4673             }
4674 0 0       0 }
4675             }
4676             return wantarray ? () : undef;
4677             }
4678              
4679             #
4680             # INFORMIX V6 ALS path opendir
4681             #
4682 0     0 0 0 sub Einformixv6als::opendir(*$) {
4683 0 0       0  
    0          
4684 0         0 my $dh = qualify_to_ref $_[0];
4685             if (CORE::opendir $dh, $_[1]) {
4686             return 1;
4687 0 0       0 }
4688 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4689             if (CORE::opendir $dh, "$_[1]/.") {
4690             return 1;
4691 0         0 }
4692             }
4693             return undef;
4694             }
4695              
4696             #
4697             # INFORMIX V6 ALS file stat (with parameter)
4698             #
4699 0 50   384 0 0 sub Einformixv6als::stat(*) {
4700              
4701 384         2882 local $_ = shift if @_;
4702 384 50       2572  
    50          
    0          
4703 384         14173 my $fh = qualify_to_ref $_;
4704             if (defined fileno $fh) {
4705             return CORE::stat $fh;
4706 0         0 }
4707             elsif (-e $_) {
4708             return CORE::stat _;
4709             }
4710             elsif (_MSWin32_5Cended_path($_)) {
4711              
4712             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Einformixv6als::stat()
4713             # on Windows opens the file for the path which has 5c at end.
4714 384         3385 # (and so on)
4715 0 0       0  
4716 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4717 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4718 0 0       0 if (wantarray) {
4719 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4720             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4721             return @stat;
4722 0         0 }
4723 0 0       0 else {
4724 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4725             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4726             return $stat;
4727             }
4728 0 0       0 }
4729             }
4730             return wantarray ? () : undef;
4731             }
4732              
4733             #
4734             # INFORMIX V6 ALS file stat (without parameter)
4735             #
4736 0     0 0 0 sub Einformixv6als::stat_() {
4737 0 0       0  
    0          
    0          
4738 0         0 my $fh = qualify_to_ref $_;
4739             if (defined fileno $fh) {
4740             return CORE::stat $fh;
4741 0         0 }
4742             elsif (-e $_) {
4743             return CORE::stat _;
4744 0         0 }
4745 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4746 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4747 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4748 0 0       0 if (wantarray) {
4749 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4750             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4751             return @stat;
4752 0         0 }
4753 0 0       0 else {
4754 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4755             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4756             return $stat;
4757             }
4758 0 0       0 }
4759             }
4760             return wantarray ? () : undef;
4761             }
4762              
4763             #
4764             # INFORMIX V6 ALS path unlink
4765             #
4766 0 0   0 0 0 sub Einformixv6als::unlink(@) {
4767              
4768 0         0 local @_ = ($_) unless @_;
4769 0         0  
4770 0 0       0 my $unlink = 0;
    0          
    0          
4771 0         0 for (@_) {
4772             if (CORE::unlink) {
4773             $unlink++;
4774             }
4775             elsif (Einformixv6als::d($_)) {
4776 0         0 }
4777 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4778 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4779 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4780             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4781 0         0 $file = qq{"$file"};
4782 0 0       0 }
4783 0 0       0 my $fh = gensym();
4784             if (_open_r($fh, $_)) {
4785             close($fh) or die "Can't close file: $_: $!";
4786 0 0 0     0  
    0          
4787 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4788             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4789             CORE::system 'DEL', '/F', $file, '2>NUL';
4790             }
4791              
4792 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4793             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4794             CORE::system 'DEL', '/F', $file, '2>NUL';
4795             }
4796              
4797             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4798 0         0 # command.com can not "2>NUL"
4799 0         0 else {
4800             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4801             CORE::system 'DEL', $file;
4802 0 0       0 }
4803 0 0       0  
4804             if (_open_r($fh, $_)) {
4805             close($fh) or die "Can't close file: $_: $!";
4806 0         0 }
4807             else {
4808             $unlink++;
4809             }
4810             }
4811 0         0 }
4812             }
4813             return $unlink;
4814             }
4815              
4816             #
4817             # INFORMIX V6 ALS chdir
4818             #
4819 0 0   0 0 0 sub Einformixv6als::chdir(;$) {
4820 0         0  
4821             if (@_ == 0) {
4822             return CORE::chdir;
4823 0         0 }
4824              
4825 0 0       0 my($dir) = @_;
4826 0 0       0  
4827 0         0 if (_MSWin32_5Cended_path($dir)) {
4828             if (not Einformixv6als::d $dir) {
4829             return 0;
4830 0 0 0     0 }
    0          
4831 0         0  
4832             if ($] =~ /^5\.005/oxms) {
4833             return CORE::chdir $dir;
4834 0         0 }
4835 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4836             local $@;
4837             my $chdir = CORE::eval q{
4838             CORE::require 'jacode.pl';
4839              
4840             # P.676 ${^WIDE_SYSTEM_CALLS}
4841             # in Chapter 28: Special Names
4842             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4843              
4844             # P.790 ${^WIDE_SYSTEM_CALLS}
4845             # in Chapter 25: Special Names
4846             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4847              
4848             local ${^WIDE_SYSTEM_CALLS} = 1;
4849 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4850 0         0 };
4851             if (not $@) {
4852             return $chdir;
4853             }
4854             }
4855              
4856             # old idea (Win32 module required)
4857             elsif (0) {
4858             local $@;
4859             my $shortdir = '';
4860             my $chdir = CORE::eval q{
4861             use Win32;
4862             $shortdir = Win32::GetShortPathName($dir);
4863             if ($shortdir ne $dir) {
4864             return CORE::chdir $shortdir;
4865             }
4866             else {
4867             return 0;
4868             }
4869             };
4870             if ($@) {
4871             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4872             while ($char[-1] eq "\x5C") {
4873             pop @char;
4874             }
4875             $dir = join '', @char;
4876             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4877             }
4878             elsif ($shortdir eq $dir) {
4879             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4880             while ($char[-1] eq "\x5C") {
4881             pop @char;
4882             }
4883             $dir = join '', @char;
4884             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4885             }
4886             return $chdir;
4887             }
4888 0         0  
4889             # rejected idea ...
4890             elsif (0) {
4891              
4892             # MSDN SetCurrentDirectory function
4893             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4894             #
4895             # Data Execution Prevention (DEP)
4896             # http://vlaurie.com/computers2/Articles/dep.htm
4897             #
4898             # Learning x86 assembler with Perl -- Shibuya.pm#11
4899             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4900             #
4901             # Introduction to Win32::API programming in Perl
4902             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4903             #
4904             # DynaLoader - Dynamically load C libraries into Perl code
4905             # http://perldoc.perl.org/DynaLoader.html
4906             #
4907             # Basic knowledge of DynaLoader
4908             # http://blog.64p.org/entry/20090313/1236934042
4909              
4910             if (($] =~ /^5\.006/oxms) and
4911             ($^O eq 'MSWin32') and
4912             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4913             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4914             ) {
4915             my $x86 = join('',
4916              
4917             # PUSH Iv
4918             "\x68", pack('P', "$dir\\\0"),
4919              
4920             # MOV eAX, Iv
4921             "\xb8", pack('L',
4922             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4923             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4924             'SetCurrentDirectoryA'
4925             )
4926             ),
4927              
4928             # CALL eAX
4929             "\xff\xd0",
4930              
4931             # RETN
4932             "\xc3",
4933             );
4934             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4935             _SetCurrentDirectoryA();
4936             chomp(my $chdir = qx{chdir});
4937             if (Einformixv6als::fc($chdir) eq Einformixv6als::fc($dir)) {
4938             return 1;
4939             }
4940             else {
4941             return 0;
4942             }
4943             }
4944             }
4945              
4946             # COMMAND.COM's unhelpful tips:
4947             # Displays a list of files and subdirectories in a directory.
4948             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4949             #
4950             # Syntax:
4951             #
4952             # DIR [drive:] [path] [filename] [/Switches]
4953             #
4954             # /Z Long file names are not displayed in the file listing
4955             #
4956             # Limitations
4957             # The undocumented /Z switch (no long names) would appear to
4958             # have been not fully developed and has a couple of problems:
4959             #
4960             # 1. It will only work if:
4961             # There is no path specified (ie. for the current directory in
4962             # the current drive)
4963             # The path is specified as the root directory of any drive
4964             # (eg. C:\, D:\, etc.)
4965             # The path is specified as the current directory of any drive
4966             # by using the drive letter only (eg. C:, D:, etc.)
4967             # The path is specified as the parent directory using the ..
4968             # notation (eg. DIR .. /Z)
4969             # Any other syntax results in a "File Not Found" error message.
4970             #
4971             # 2. The /Z switch is compatable with the /S switch to show
4972             # subdirectories (as long as the above rules are followed) and
4973             # all the files are shown with short names only. The
4974             # subdirectories are also shown with short names only. However,
4975             # the header for each subdirectory after the first level gives
4976             # the subdirectory's long name.
4977             #
4978             # 3. The /Z switch is also compatable with the /B switch to give
4979             # a simple list of files with short names only. When used with
4980             # the /S switch as well, all files are listed with their full
4981             # paths. The file names themselves are all in short form, and
4982             # the path of those files in the current directory are in short
4983             # form, but the paths of any files in subdirectories are in
4984 0         0 # long filename form.
4985 0         0  
4986 0         0 my $shortdir = '';
4987 0         0 my $i = 0;
4988 0         0 my @subdir = ();
4989 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4990 0         0 my $char = $1;
4991 0         0 if (($char eq '\\') or ($char eq '/')) {
4992 0         0 $i++;
4993             $subdir[$i] = $char;
4994             $i++;
4995 0         0 }
4996             else {
4997             $subdir[$i] .= $char;
4998 0 0 0     0 }
4999 0         0 }
5000             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
5001             pop @subdir;
5002             }
5003              
5004             # P.504 PERL5SHELL (Microsoft ports only)
5005             # in Chapter 19: The Command-Line Interface
5006             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5007              
5008             # P.597 PERL5SHELL (Microsoft ports only)
5009             # in Chapter 17: The Command-Line Interface
5010             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5011              
5012 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
5013 0         0 # cmd.exe on Windows NT, Windows 2000
5014 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
5015 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5016             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5017             if (Einformixv6als::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Einformixv6als::fc($subdir[-1])) {
5018 0         0  
5019 0         0 # short file name (8dot3name) here-----vv
5020 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5021 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5022             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5023             last;
5024             }
5025             }
5026             }
5027              
5028             # an idea (not so portable, only Windows 2000 or later)
5029             elsif (0) {
5030             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5031             }
5032              
5033 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5034 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5035 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5036             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5037             if (Einformixv6als::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Einformixv6als::fc($subdir[-1])) {
5038 0         0  
5039 0         0 # short file name (8dot3name) here-----vv
5040 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5041 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5042             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5043             last;
5044             }
5045             }
5046             }
5047              
5048 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5049 0         0 else {
  0         0  
5050 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5051             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5052             if (Einformixv6als::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Einformixv6als::fc($subdir[-1])) {
5053 0         0  
5054 0         0 # short file name (8dot3name) here-----v
5055 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5056 0         0 CORE::substr($shortleafdir,8,1) = '.';
5057 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5058             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5059             last;
5060             }
5061             }
5062 0 0       0 }
    0          
5063 0         0  
5064             if ($shortdir eq '') {
5065             return 0;
5066 0         0 }
5067             elsif (Einformixv6als::fc($shortdir) eq Einformixv6als::fc($dir)) {
5068 0         0 return 0;
5069             }
5070             return CORE::chdir $shortdir;
5071 0         0 }
5072             else {
5073             return CORE::chdir $dir;
5074             }
5075             }
5076              
5077             #
5078             # INFORMIX V6 ALS chr(0x5C) ended path on MSWin32
5079             #
5080 0 50 33 768   0 sub _MSWin32_5Cended_path {
5081 768 50       5340  
5082 768         4547 if ((@_ >= 1) and ($_[0] ne '')) {
5083 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5084 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5085             if ($char[-1] =~ / \x5C \z/oxms) {
5086             return 1;
5087             }
5088 0         0 }
5089             }
5090             return undef;
5091             }
5092              
5093             #
5094             # do INFORMIX V6 ALS file
5095             #
5096 768     0 0 2205 sub Einformixv6als::do($) {
5097              
5098 0         0 my($filename) = @_;
5099              
5100             my $realfilename;
5101             my $result;
5102 0         0 ITER_DO:
  0         0  
5103 0 0       0 {
5104 0         0 for my $prefix (@INC) {
5105             if ($^O eq 'MacOS') {
5106             $realfilename = "$prefix$filename";
5107 0         0 }
5108             else {
5109             $realfilename = "$prefix/$filename";
5110 0 0       0 }
5111              
5112 0         0 if (Einformixv6als::f($realfilename)) {
5113              
5114 0 0       0 my $script = '';
5115 0         0  
5116 0         0 if (Einformixv6als::e("$realfilename.e")) {
5117 0         0 my $e_mtime = (Einformixv6als::stat("$realfilename.e"))[9];
5118 0 0 0     0 my $mtime = (Einformixv6als::stat($realfilename))[9];
5119 0         0 my $module_mtime = (Einformixv6als::stat(__FILE__))[9];
5120             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5121             Einformixv6als::unlink "$realfilename.e";
5122             }
5123 0 0       0 }
5124 0         0  
5125 0 0       0 if (Einformixv6als::e("$realfilename.e")) {
5126 0 0       0 my $fh = gensym();
    0          
5127 0         0 if (_open_r($fh, "$realfilename.e")) {
5128             if ($^O eq 'MacOS') {
5129             CORE::eval q{
5130             CORE::require Mac::Files;
5131             Mac::Files::FSpSetFLock("$realfilename.e");
5132             };
5133             }
5134             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5135              
5136             # P.419 File Locking
5137             # in Chapter 16: Interprocess Communication
5138             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5139              
5140             # P.524 File Locking
5141             # in Chapter 15: Interprocess Communication
5142             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5143              
5144 0         0 # (and so on)
5145 0 0       0  
5146 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5147             if ($@) {
5148             carp "Can't immediately read-lock the file: $realfilename.e";
5149             }
5150 0         0 }
5151             else {
5152 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5153 0         0 }
5154 0 0       0 local $/ = undef; # slurp mode
5155 0         0 $script = <$fh>;
5156             if ($^O eq 'MacOS') {
5157             CORE::eval q{
5158             CORE::require Mac::Files;
5159             Mac::Files::FSpRstFLock("$realfilename.e");
5160 0 0       0 };
5161             }
5162             close($fh) or die "Can't close file: $realfilename.e: $!";
5163             }
5164 0         0 }
5165 0 0       0 else {
5166 0 0       0 my $fh = gensym();
    0          
5167 0         0 if (_open_r($fh, $realfilename)) {
5168             if ($^O eq 'MacOS') {
5169             CORE::eval q{
5170             CORE::require Mac::Files;
5171             Mac::Files::FSpSetFLock($realfilename);
5172             };
5173 0         0 }
5174 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5175 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5176             if ($@) {
5177             carp "Can't immediately read-lock the file: $realfilename";
5178             }
5179 0         0 }
5180             else {
5181 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5182 0         0 }
5183 0 0       0 local $/ = undef; # slurp mode
5184 0         0 $script = <$fh>;
5185             if ($^O eq 'MacOS') {
5186             CORE::eval q{
5187             CORE::require Mac::Files;
5188             Mac::Files::FSpRstFLock($realfilename);
5189 0 0       0 };
5190             }
5191             close($fh) or die "Can't close file: $realfilename.e: $!";
5192 0 0       0 }
5193 0         0  
5194 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
5195 0         0 CORE::require INFORMIXV6ALS;
5196 0 0       0 $script = INFORMIXV6ALS::escape_script($script);
5197 0 0       0 my $fh = gensym();
    0          
5198 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5199             if ($^O eq 'MacOS') {
5200             CORE::eval q{
5201             CORE::require Mac::Files;
5202             Mac::Files::FSpSetFLock("$realfilename.e");
5203             };
5204 0         0 }
5205 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5206 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5207             if ($@) {
5208             carp "Can't immediately write-lock the file: $realfilename.e";
5209             }
5210 0         0 }
5211             else {
5212 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5213 0 0       0 }
5214 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5215 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5216 0         0 print {$fh} $script;
5217             if ($^O eq 'MacOS') {
5218             CORE::eval q{
5219             CORE::require Mac::Files;
5220             Mac::Files::FSpRstFLock("$realfilename.e");
5221 0 0       0 };
5222             }
5223             close($fh) or die "Can't close file: $realfilename.e: $!";
5224             }
5225             }
5226 389     389   12981  
  389         3720  
  389         345387  
  0         0  
5227 0         0 {
5228             no strict;
5229 0         0 $result = scalar CORE::eval $script;
5230             }
5231             last ITER_DO;
5232             }
5233             }
5234 0 0       0 }
    0          
5235 0         0  
5236 0         0 if ($@) {
5237             $INC{$filename} = undef;
5238             return undef;
5239 0         0 }
5240             elsif (not $result) {
5241             return undef;
5242 0         0 }
5243 0         0 else {
5244             $INC{$filename} = $realfilename;
5245             return $result;
5246             }
5247             }
5248              
5249             #
5250             # require INFORMIX V6 ALS file
5251             #
5252              
5253             # require
5254             # in Chapter 3: Functions
5255             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5256             #
5257             # sub require {
5258             # my($filename) = @_;
5259             # return 1 if $INC{$filename};
5260             # my($realfilename, $result);
5261             # ITER: {
5262             # foreach $prefix (@INC) {
5263             # $realfilename = "$prefix/$filename";
5264             # if (-f $realfilename) {
5265             # $result = CORE::eval `cat $realfilename`;
5266             # last ITER;
5267             # }
5268             # }
5269             # die "Can't find $filename in \@INC";
5270             # }
5271             # die $@ if $@;
5272             # die "$filename did not return true value" unless $result;
5273             # $INC{$filename} = $realfilename;
5274             # return $result;
5275             # }
5276              
5277             # require
5278             # in Chapter 9: perlfunc: Perl builtin functions
5279             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5280             #
5281             # sub require {
5282             # my($filename) = @_;
5283             # if (exists $INC{$filename}) {
5284             # return 1 if $INC{$filename};
5285             # die "Compilation failed in require";
5286             # }
5287             # my($realfilename, $result);
5288             # ITER: {
5289             # foreach $prefix (@INC) {
5290             # $realfilename = "$prefix/$filename";
5291             # if (-f $realfilename) {
5292             # $INC{$filename} = $realfilename;
5293             # $result = do $realfilename;
5294             # last ITER;
5295             # }
5296             # }
5297             # die "Can't find $filename in \@INC";
5298             # }
5299             # if ($@) {
5300             # $INC{$filename} = undef;
5301             # die $@;
5302             # }
5303             # elsif (!$result) {
5304             # delete $INC{$filename};
5305             # die "$filename did not return true value";
5306             # }
5307             # else {
5308             # return $result;
5309             # }
5310             # }
5311              
5312 0 0   0 0 0 sub Einformixv6als::require(;$) {
5313              
5314 0 0       0 local $_ = shift if @_;
5315 0 0       0  
5316 0         0 if (exists $INC{$_}) {
5317             return 1 if $INC{$_};
5318             croak "Compilation failed in require: $_";
5319             }
5320              
5321             # jcode.pl
5322             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5323              
5324             # jacode.pl
5325 0 0       0 # http://search.cpan.org/dist/jacode/
5326 0         0  
5327             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5328             return CORE::require($_);
5329 0         0 }
5330              
5331             my $realfilename;
5332             my $result;
5333 0         0 ITER_REQUIRE:
  0         0  
5334 0 0       0 {
5335 0         0 for my $prefix (@INC) {
5336             if ($^O eq 'MacOS') {
5337             $realfilename = "$prefix$_";
5338 0         0 }
5339             else {
5340             $realfilename = "$prefix/$_";
5341 0 0       0 }
5342 0         0  
5343             if (Einformixv6als::f($realfilename)) {
5344 0         0 $INC{$_} = $realfilename;
5345              
5346 0 0       0 my $script = '';
5347 0         0  
5348 0         0 if (Einformixv6als::e("$realfilename.e")) {
5349 0         0 my $e_mtime = (Einformixv6als::stat("$realfilename.e"))[9];
5350 0 0 0     0 my $mtime = (Einformixv6als::stat($realfilename))[9];
5351 0         0 my $module_mtime = (Einformixv6als::stat(__FILE__))[9];
5352             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5353             Einformixv6als::unlink "$realfilename.e";
5354             }
5355 0 0       0 }
5356 0         0  
5357 0 0       0 if (Einformixv6als::e("$realfilename.e")) {
5358 0 0       0 my $fh = gensym();
    0          
5359 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5360             if ($^O eq 'MacOS') {
5361             CORE::eval q{
5362             CORE::require Mac::Files;
5363             Mac::Files::FSpSetFLock("$realfilename.e");
5364             };
5365 0         0 }
5366 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5367 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5368             if ($@) {
5369             carp "Can't immediately read-lock the file: $realfilename.e";
5370             }
5371 0         0 }
5372             else {
5373 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5374 0         0 }
5375 0 0       0 local $/ = undef; # slurp mode
5376 0         0 $script = <$fh>;
5377             if ($^O eq 'MacOS') {
5378             CORE::eval q{
5379             CORE::require Mac::Files;
5380             Mac::Files::FSpRstFLock("$realfilename.e");
5381 0 0       0 };
5382             }
5383             close($fh) or croak "Can't close file: $realfilename: $!";
5384 0         0 }
5385 0 0       0 else {
5386 0 0       0 my $fh = gensym();
    0          
5387 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5388             if ($^O eq 'MacOS') {
5389             CORE::eval q{
5390             CORE::require Mac::Files;
5391             Mac::Files::FSpSetFLock($realfilename);
5392             };
5393 0         0 }
5394 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5395 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5396             if ($@) {
5397             carp "Can't immediately read-lock the file: $realfilename";
5398             }
5399 0         0 }
5400             else {
5401 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5402 0         0 }
5403 0 0       0 local $/ = undef; # slurp mode
5404 0         0 $script = <$fh>;
5405             if ($^O eq 'MacOS') {
5406             CORE::eval q{
5407             CORE::require Mac::Files;
5408             Mac::Files::FSpRstFLock($realfilename);
5409 0 0       0 };
5410             }
5411 0 0       0 close($fh) or croak "Can't close file: $realfilename: $!";
5412 0         0  
5413 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
5414 0         0 CORE::require INFORMIXV6ALS;
5415 0 0       0 $script = INFORMIXV6ALS::escape_script($script);
5416 0 0       0 my $fh = gensym();
    0          
5417 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5418             if ($^O eq 'MacOS') {
5419             CORE::eval q{
5420             CORE::require Mac::Files;
5421             Mac::Files::FSpSetFLock("$realfilename.e");
5422             };
5423 0         0 }
5424 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5425 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5426             if ($@) {
5427             carp "Can't immediately write-lock the file: $realfilename.e";
5428             }
5429 0         0 }
5430             else {
5431 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5432 0 0       0 }
5433 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5434 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5435 0         0 print {$fh} $script;
5436             if ($^O eq 'MacOS') {
5437             CORE::eval q{
5438             CORE::require Mac::Files;
5439             Mac::Files::FSpRstFLock("$realfilename.e");
5440 0 0       0 };
5441             }
5442             close($fh) or croak "Can't close file: $realfilename: $!";
5443             }
5444             }
5445 389     389   6484  
  389         882  
  389         379631  
  0         0  
5446 0         0 {
5447             no strict;
5448 0         0 $result = scalar CORE::eval $script;
5449             }
5450             last ITER_REQUIRE;
5451 0         0 }
5452             }
5453             croak "Can't find $_ in \@INC";
5454 0 0       0 }
    0          
5455 0         0  
5456 0         0 if ($@) {
5457             $INC{$_} = undef;
5458             croak $@;
5459 0         0 }
5460 0         0 elsif (not $result) {
5461             delete $INC{$_};
5462             croak "$_ did not return true value";
5463 0         0 }
5464             else {
5465             return $result;
5466             }
5467             }
5468              
5469             #
5470             # INFORMIX V6 ALS telldir avoid warning
5471             #
5472 0     768 0 0 sub Einformixv6als::telldir(*) {
5473              
5474 768         2452 local $^W = 0;
5475              
5476             return CORE::telldir $_[0];
5477             }
5478              
5479             #
5480             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5481 768 0   0 0 31417 #
5482 0 0 0     0 sub Einformixv6als::PREMATCH {
5483 0         0 if (defined($&)) {
5484             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5485             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5486 0         0 }
5487             else {
5488             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5489             }
5490 0         0 }
5491             else {
5492 0         0 return '';
5493             }
5494             return $`;
5495             }
5496              
5497             #
5498             # ${^MATCH}, $MATCH, $& the string that matched
5499 0 0   0 0 0 #
5500 0 0       0 sub Einformixv6als::MATCH {
5501 0         0 if (defined($&)) {
5502             if (defined($1)) {
5503             return $1;
5504 0         0 }
5505             else {
5506             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5507             }
5508 0         0 }
5509             else {
5510 0         0 return '';
5511             }
5512             return $&;
5513             }
5514              
5515             #
5516             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5517 0     0 0 0 #
5518             sub Einformixv6als::POSTMATCH {
5519             return $';
5520             }
5521              
5522             #
5523             # INFORMIX V6 ALS character to order (with parameter)
5524             #
5525 0 0   0 1 0 sub INFORMIXV6ALS::ord(;$) {
5526              
5527 0 0       0 local $_ = shift if @_;
5528 0         0  
5529 0         0 if (/\A ($q_char) /oxms) {
5530 0         0 my @ord = unpack 'C*', $1;
5531 0         0 my $ord = 0;
5532             while (my $o = shift @ord) {
5533 0         0 $ord = $ord * 0x100 + $o;
5534             }
5535             return $ord;
5536 0         0 }
5537             else {
5538             return CORE::ord $_;
5539             }
5540             }
5541              
5542             #
5543             # INFORMIX V6 ALS character to order (without parameter)
5544             #
5545 0 0   0 0 0 sub INFORMIXV6ALS::ord_() {
5546 0         0  
5547 0         0 if (/\A ($q_char) /oxms) {
5548 0         0 my @ord = unpack 'C*', $1;
5549 0         0 my $ord = 0;
5550             while (my $o = shift @ord) {
5551 0         0 $ord = $ord * 0x100 + $o;
5552             }
5553             return $ord;
5554 0         0 }
5555             else {
5556             return CORE::ord $_;
5557             }
5558             }
5559              
5560             #
5561             # INFORMIX V6 ALS reverse
5562             #
5563 0 0   0 0 0 sub INFORMIXV6ALS::reverse(@) {
5564 0         0  
5565             if (wantarray) {
5566             return CORE::reverse @_;
5567             }
5568             else {
5569              
5570             # One of us once cornered Larry in an elevator and asked him what
5571             # problem he was solving with this, but he looked as far off into
5572             # the distance as he could in an elevator and said, "It seemed like
5573 0         0 # a good idea at the time."
5574              
5575             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5576             }
5577             }
5578              
5579             #
5580             # INFORMIX V6 ALS getc (with parameter, without parameter)
5581             #
5582 0     0 0 0 sub INFORMIXV6ALS::getc(;*@) {
5583 0 0       0  
5584 0 0 0     0 my($package) = caller;
5585             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5586 0         0 croak 'Too many arguments for INFORMIXV6ALS::getc' if @_ and not wantarray;
  0         0  
5587 0         0  
5588 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5589 0         0 my $getc = '';
5590 0 0       0 for my $length ($length[0] .. $length[-1]) {
5591 0 0       0 $getc .= CORE::getc($fh);
5592 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5593             if ($getc =~ /\A ${Einformixv6als::dot_s} \z/oxms) {
5594             return wantarray ? ($getc,@_) : $getc;
5595             }
5596 0 0       0 }
5597             }
5598             return wantarray ? ($getc,@_) : $getc;
5599             }
5600              
5601             #
5602             # INFORMIX V6 ALS length by character
5603             #
5604 0 0   0 1 0 sub INFORMIXV6ALS::length(;$) {
5605              
5606 0         0 local $_ = shift if @_;
5607 0         0  
5608             local @_ = /\G ($q_char) /oxmsg;
5609             return scalar @_;
5610             }
5611              
5612             #
5613             # INFORMIX V6 ALS substr by character
5614             #
5615             BEGIN {
5616              
5617             # P.232 The lvalue Attribute
5618             # in Chapter 6: Subroutines
5619             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5620              
5621             # P.336 The lvalue Attribute
5622             # in Chapter 7: Subroutines
5623             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5624              
5625             # P.144 8.4 Lvalue subroutines
5626             # in Chapter 8: perlsub: Perl subroutines
5627 389 50 0 389 1 234234 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
5628              
5629             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5630             # vv----------------------*******
5631             sub INFORMIXV6ALS::substr($$;$$) %s {
5632              
5633             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5634              
5635             # If the substring is beyond either end of the string, substr() returns the undefined
5636             # value and produces a warning. When used as an lvalue, specifying a substring that
5637             # is entirely outside the string raises an exception.
5638             # http://perldoc.perl.org/functions/substr.html
5639              
5640             # A return with no argument returns the scalar value undef in scalar context,
5641             # an empty list () in list context, and (naturally) nothing at all in void
5642             # context.
5643              
5644             my $offset = $_[1];
5645             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5646             return;
5647             }
5648              
5649             # substr($string,$offset,$length,$replacement)
5650             if (@_ == 4) {
5651             my(undef,undef,$length,$replacement) = @_;
5652             my $substr = join '', splice(@char, $offset, $length, $replacement);
5653             $_[0] = join '', @char;
5654              
5655             # return $substr; this doesn't work, don't say "return"
5656             $substr;
5657             }
5658              
5659             # substr($string,$offset,$length)
5660             elsif (@_ == 3) {
5661             my(undef,undef,$length) = @_;
5662             my $octet_offset = 0;
5663             my $octet_length = 0;
5664             if ($offset == 0) {
5665             $octet_offset = 0;
5666             }
5667             elsif ($offset > 0) {
5668             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5669             }
5670             else {
5671             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5672             }
5673             if ($length == 0) {
5674             $octet_length = 0;
5675             }
5676             elsif ($length > 0) {
5677             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5678             }
5679             else {
5680             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5681             }
5682             CORE::substr($_[0], $octet_offset, $octet_length);
5683             }
5684              
5685             # substr($string,$offset)
5686             else {
5687             my $octet_offset = 0;
5688             if ($offset == 0) {
5689             $octet_offset = 0;
5690             }
5691             elsif ($offset > 0) {
5692             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5693             }
5694             else {
5695             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5696             }
5697             CORE::substr($_[0], $octet_offset);
5698             }
5699             }
5700             END
5701             }
5702              
5703             #
5704             # INFORMIX V6 ALS index by character
5705             #
5706 0     0 1 0 sub INFORMIXV6ALS::index($$;$) {
5707 0 0       0  
5708 0         0 my $index;
5709             if (@_ == 3) {
5710             $index = Einformixv6als::index($_[0], $_[1], CORE::length(INFORMIXV6ALS::substr($_[0], 0, $_[2])));
5711 0         0 }
5712             else {
5713             $index = Einformixv6als::index($_[0], $_[1]);
5714 0 0       0 }
5715 0         0  
5716             if ($index == -1) {
5717             return -1;
5718 0         0 }
5719             else {
5720             return INFORMIXV6ALS::length(CORE::substr $_[0], 0, $index);
5721             }
5722             }
5723              
5724             #
5725             # INFORMIX V6 ALS rindex by character
5726             #
5727 0     0 1 0 sub INFORMIXV6ALS::rindex($$;$) {
5728 0 0       0  
5729 0         0 my $rindex;
5730             if (@_ == 3) {
5731             $rindex = Einformixv6als::rindex($_[0], $_[1], CORE::length(INFORMIXV6ALS::substr($_[0], 0, $_[2])));
5732 0         0 }
5733             else {
5734             $rindex = Einformixv6als::rindex($_[0], $_[1]);
5735 0 0       0 }
5736 0         0  
5737             if ($rindex == -1) {
5738             return -1;
5739 0         0 }
5740             else {
5741             return INFORMIXV6ALS::length(CORE::substr $_[0], 0, $rindex);
5742             }
5743             }
5744              
5745 389     389   5266 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         2762  
  389         51364  
5746             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5747             use vars qw($slash); $slash = 'm//';
5748              
5749             # ord() to ord() or INFORMIXV6ALS::ord()
5750             my $function_ord = 'ord';
5751              
5752             # ord to ord or INFORMIXV6ALS::ord_
5753             my $function_ord_ = 'ord';
5754              
5755             # reverse to reverse or INFORMIXV6ALS::reverse
5756             my $function_reverse = 'reverse';
5757              
5758             # getc to getc or INFORMIXV6ALS::getc
5759             my $function_getc = 'getc';
5760              
5761             # P.1023 Appendix W.9 Multibyte Anchoring
5762             # of ISBN 1-56592-224-7 CJKV Information Processing
5763              
5764             my $anchor = '';
5765 389     389   6385 $anchor = q{${Einformixv6als::anchor}};
  389     0   2449  
  389         22286003  
5766              
5767             use vars qw($nest);
5768              
5769             # regexp of nested parens in qqXX
5770              
5771             # P.340 Matching Nested Constructs with Embedded Code
5772             # in Chapter 7: Perl
5773             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5774              
5775             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5776             [^\x81-\x9F\xE0-\xFD\\()] |
5777             \( (?{$nest++}) |
5778             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5779             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5780             \\ [^\x81-\x9F\xE0-\xFDc] |
5781             \\c[\x40-\x5F] |
5782             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5783             [\x00-\xFF]
5784             }xms;
5785              
5786             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5787             [^\x81-\x9F\xE0-\xFD\\{}] |
5788             \{ (?{$nest++}) |
5789             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5790             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5791             \\ [^\x81-\x9F\xE0-\xFDc] |
5792             \\c[\x40-\x5F] |
5793             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5794             [\x00-\xFF]
5795             }xms;
5796              
5797             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5798             [^\x81-\x9F\xE0-\xFD\\\[\]] |
5799             \[ (?{$nest++}) |
5800             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5801             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5802             \\ [^\x81-\x9F\xE0-\xFDc] |
5803             \\c[\x40-\x5F] |
5804             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5805             [\x00-\xFF]
5806             }xms;
5807              
5808             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5809             [^\x81-\x9F\xE0-\xFD\\<>] |
5810             \< (?{$nest++}) |
5811             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5812             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5813             \\ [^\x81-\x9F\xE0-\xFDc] |
5814             \\c[\x40-\x5F] |
5815             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5816             [\x00-\xFF]
5817             }xms;
5818              
5819             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5820             (?: ::)? (?:
5821             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5822             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5823             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5824             ))
5825             }xms;
5826              
5827             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5828             (?: ::)? (?:
5829             (?>[0-9]+) |
5830             [^\x81-\x9F\xE0-\xFDa-zA-Z_0-9\[\]] |
5831             ^[A-Z] |
5832             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5833             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5834             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5835             ))
5836             }xms;
5837              
5838             my $qq_substr = qr{(?> Char::substr | INFORMIXV6ALS::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5839             }xms;
5840              
5841             # regexp of nested parens in qXX
5842             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5843             [^\x81-\x9F\xE0-\xFD()] |
5844             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5845             \( (?{$nest++}) |
5846             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5847             [\x00-\xFF]
5848             }xms;
5849              
5850             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5851             [^\x81-\x9F\xE0-\xFD\{\}] |
5852             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5853             \{ (?{$nest++}) |
5854             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5855             [\x00-\xFF]
5856             }xms;
5857              
5858             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5859             [^\x81-\x9F\xE0-\xFD\[\]] |
5860             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5861             \[ (?{$nest++}) |
5862             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5863             [\x00-\xFF]
5864             }xms;
5865              
5866             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5867             [^\x81-\x9F\xE0-\xFD<>] |
5868             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5869             \< (?{$nest++}) |
5870             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5871             [\x00-\xFF]
5872             }xms;
5873              
5874             my $matched = '';
5875             my $s_matched = '';
5876             $matched = q{$Einformixv6als::matched};
5877             $s_matched = q{ Einformixv6als::s_matched();};
5878              
5879             my $tr_variable = ''; # variable of tr///
5880             my $sub_variable = ''; # variable of s///
5881             my $bind_operator = ''; # =~ or !~
5882              
5883             my @heredoc = (); # here document
5884             my @heredoc_delimiter = ();
5885             my $here_script = ''; # here script
5886              
5887             #
5888             # escape INFORMIX V6 ALS script
5889 0 50   384 0 0 #
5890             sub INFORMIXV6ALS::escape(;$) {
5891             local($_) = $_[0] if @_;
5892              
5893             # P.359 The Study Function
5894             # in Chapter 7: Perl
5895 384         1432 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5896              
5897             study $_; # Yes, I studied study yesterday.
5898              
5899             # while all script
5900              
5901             # 6.14. Matching from Where the Last Pattern Left Off
5902             # in Chapter 6. Pattern Matching
5903             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5904             # (and so on)
5905              
5906             # one member of Tag-team
5907             #
5908             # P.128 Start of match (or end of previous match): \G
5909             # P.130 Advanced Use of \G with Perl
5910             # in Chapter 3: Overview of Regular Expression Features and Flavors
5911             # P.255 Use leading anchors
5912             # P.256 Expose ^ and \G at the front expressions
5913             # in Chapter 6: Crafting an Efficient Expression
5914             # P.315 "Tag-team" matching with /gc
5915             # in Chapter 7: Perl
5916 384         903 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5917 384         800  
5918 384         1688 my $e_script = '';
5919             while (not /\G \z/oxgc) { # member
5920             $e_script .= INFORMIXV6ALS::escape_token();
5921 187822         332378 }
5922              
5923             return $e_script;
5924             }
5925              
5926             #
5927             # escape INFORMIX V6 ALS token of script
5928             #
5929             sub INFORMIXV6ALS::escape_token {
5930              
5931 384     187822 0 7447 # \n output here document
5932              
5933             my $ignore_modules = join('|', qw(
5934             utf8
5935             bytes
5936             charnames
5937             I18N::Japanese
5938             I18N::Collate
5939             I18N::JExt
5940             File::DosGlob
5941             Wild
5942             Wildcard
5943             Japanese
5944             ));
5945              
5946             # another member of Tag-team
5947             #
5948             # P.315 "Tag-team" matching with /gc
5949             # in Chapter 7: Perl
5950 187822 100 100     255694 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
5951 187822         15804466  
5952 31404 100       44928 if (/\G ( \n ) /oxgc) { # another member (and so on)
5953 31404         61876 my $heredoc = '';
5954             if (scalar(@heredoc_delimiter) >= 1) {
5955 197         278 $slash = 'm//';
5956 197         469  
5957             $heredoc = join '', @heredoc;
5958             @heredoc = ();
5959 197         382  
5960 197         402 # skip here document
5961             for my $heredoc_delimiter (@heredoc_delimiter) {
5962 205         1351 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5963             }
5964 197         396 @heredoc_delimiter = ();
5965              
5966 197         319 $here_script = '';
5967             }
5968             return "\n" . $heredoc;
5969             }
5970 31404         101163  
5971             # ignore space, comment
5972             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5973              
5974             # if (, elsif (, unless (, while (, until (, given (, and when (
5975              
5976             # given, when
5977              
5978             # P.225 The given Statement
5979             # in Chapter 15: Smart Matching and given-when
5980             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5981              
5982             # P.133 The given Statement
5983             # in Chapter 4: Statements and Declarations
5984             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5985 42620         143164  
5986 3773         6344 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5987             $slash = 'm//';
5988             return $1;
5989             }
5990              
5991             # scalar variable ($scalar = ...) =~ tr///;
5992             # scalar variable ($scalar = ...) =~ s///;
5993              
5994             # state
5995              
5996             # P.68 Persistent, Private Variables
5997             # in Chapter 4: Subroutines
5998             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5999              
6000             # P.160 Persistent Lexically Scoped Variables: state
6001             # in Chapter 4: Statements and Declarations
6002             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6003              
6004             # (and so on)
6005 3773         12725  
6006             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
6007 170 50       511 my $e_string = e_string($1);
    50          
6008 170         7883  
6009 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6010 0         0 $tr_variable = $e_string . e_string($1);
6011 0         0 $bind_operator = $2;
6012             $slash = 'm//';
6013             return '';
6014 0         0 }
6015 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6016 0         0 $sub_variable = $e_string . e_string($1);
6017 0         0 $bind_operator = $2;
6018             $slash = 'm//';
6019             return '';
6020 0         0 }
6021 170         411 else {
6022             $slash = 'div';
6023             return $e_string;
6024             }
6025             }
6026              
6027 170         738 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
6028 4         12 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6029             $slash = 'div';
6030             return q{Einformixv6als::PREMATCH()};
6031             }
6032              
6033 4         14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
6034 28         61 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6035             $slash = 'div';
6036             return q{Einformixv6als::MATCH()};
6037             }
6038              
6039 28         87 # $', ${'} --> $', ${'}
6040 1         8 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6041             $slash = 'div';
6042             return $1;
6043             }
6044              
6045 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
6046 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6047             $slash = 'div';
6048             return q{Einformixv6als::POSTMATCH()};
6049             }
6050              
6051             # scalar variable $scalar =~ tr///;
6052             # scalar variable $scalar =~ s///;
6053             # substr() =~ tr///;
6054 3         9 # substr() =~ s///;
6055             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6056 2878 100       7163 my $scalar = e_string($1);
    100          
6057 2878         12670  
6058 9         16 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6059 9         16 $tr_variable = $scalar;
6060 9         14 $bind_operator = $1;
6061             $slash = 'm//';
6062             return '';
6063 9         25 }
6064 253         516 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6065 253         555 $sub_variable = $scalar;
6066 253         391 $bind_operator = $1;
6067             $slash = 'm//';
6068             return '';
6069 253         815 }
6070 2616         4390 else {
6071             $slash = 'div';
6072             return $scalar;
6073             }
6074             }
6075              
6076 2616         8086 # end of statement
6077             elsif (/\G ( [,;] ) /oxgc) {
6078             $slash = 'm//';
6079 12209         20729  
6080             # clear tr/// variable
6081             $tr_variable = '';
6082 12209         17381  
6083             # clear s/// variable
6084 12209         16187 $sub_variable = '';
6085              
6086 12209         15561 $bind_operator = '';
6087              
6088             return $1;
6089             }
6090              
6091 12209         45852 # bareword
6092             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6093             return $1;
6094             }
6095              
6096 0         0 # $0 --> $0
6097 2         6 elsif (/\G ( \$ 0 ) /oxmsgc) {
6098             $slash = 'div';
6099             return $1;
6100 2         9 }
6101 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6102             $slash = 'div';
6103             return $1;
6104             }
6105              
6106 0         0 # $$ --> $$
6107 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6108             $slash = 'div';
6109             return $1;
6110             }
6111              
6112             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6113 1         5 # $1, $2, $3 --> $1, $2, $3 otherwise
6114 219         354 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6115             $slash = 'div';
6116             return e_capture($1);
6117 219         613 }
6118 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6119             $slash = 'div';
6120             return e_capture($1);
6121             }
6122              
6123 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6124 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6125             $slash = 'div';
6126             return e_capture($1.'->'.$2);
6127             }
6128              
6129 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6130 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6131             $slash = 'div';
6132             return e_capture($1.'->'.$2);
6133             }
6134              
6135 0         0 # $$foo
6136 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6137             $slash = 'div';
6138             return e_capture($1);
6139             }
6140              
6141 0         0 # ${ foo }
6142 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6143             $slash = 'div';
6144             return '${' . $1 . '}';
6145             }
6146              
6147 0         0 # ${ ... }
6148 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6149             $slash = 'div';
6150             return e_capture($1);
6151             }
6152              
6153             # variable or function
6154 0         0 # $ @ % & * $ #
6155 605         1117 elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
6156             $slash = 'div';
6157             return $1;
6158             }
6159             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6160 605         2347 # $ @ # \ ' " / ? ( ) [ ] < >
6161 103         233 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6162             $slash = 'div';
6163             return $1;
6164             }
6165              
6166 103         419 # while ()
6167             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6168             return $1;
6169             }
6170              
6171             # while () --- glob
6172              
6173             # avoid "Error: Runtime exception" of perl version 5.005_03
6174 0         0  
6175             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\x9F\xE0-\xFD>\0\a\e\f\n\r\t]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6176             return 'while ($_ = Einformixv6als::glob("' . $1 . '"))';
6177             }
6178              
6179 0         0 # while (glob)
6180             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6181             return 'while ($_ = Einformixv6als::glob_)';
6182             }
6183              
6184 0         0 # while (glob(WILDCARD))
6185             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6186             return 'while ($_ = Einformixv6als::glob';
6187             }
6188 0         0  
  482         1275  
6189             # doit if, doit unless, doit while, doit until, doit for, doit when
6190             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6191 482         1979  
  19         38  
6192 19         64 # subroutines of package Einformixv6als
  0         0  
6193 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         27  
6194 13         48 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6195 0         0 elsif (/\G \b INFORMIXV6ALS::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         199  
6196 114         413 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
6197 2         8 elsif (/\G \b INFORMIXV6ALS::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval INFORMIXV6ALS::escape'; }
  2         4  
6198 2         7 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
6199 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::chop'; }
  0         0  
6200 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         4  
6201 2         6 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         3  
6202 2         7 elsif (/\G \b INFORMIXV6ALS::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'INFORMIXV6ALS::index'; }
  2         6  
6203 2         9 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::index'; }
  0         0  
6204 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
6205 2         7 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         3  
6206 2         7 elsif (/\G \b INFORMIXV6ALS::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'INFORMIXV6ALS::rindex'; }
  1         2  
6207 1         5 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::rindex'; }
  0         0  
6208 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lc'; }
  0         0  
6209 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lcfirst'; }
  0         0  
6210 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::uc'; }
  3         6  
6211             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::ucfirst'; }
6212             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::fc'; }
6213              
6214             # stacked file test operators
6215              
6216             # P.179 File Test Operators
6217             # in Chapter 12: File Tests
6218             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6219              
6220             # P.106 Named Unary and File Test Operators
6221             # in Chapter 3: Unary and Binary Operators
6222             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6223              
6224             # (and so on)
6225 3         10  
  0         0  
6226 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6227 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6228 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6229 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6230 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6231 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         3  
6232             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6233             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6234 1         9  
  5         11  
6235 5         23 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6236 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6237 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6238 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6239 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6240 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         2  
6241             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6242             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6243 1         8  
  0         0  
6244 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6245 0         0 { $slash = 'm//'; return "Einformixv6als::filetest(qw($1),$2)"; }
  0         0  
6246 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1),$2)"; }
  0         0  
6247             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest qw($1),"; }
6248 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1),$2)"; }
  0         0  
6249 0         0  
  0         0  
6250 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6251 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6252 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6253 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6254 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         7  
6255             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6256 2         9 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         179  
6257 103         326  
  0         0  
6258 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6259 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6260 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6261 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6262 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         8  
6263             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6264             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6265 2         18  
  6         13  
6266 6         30 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6267 0         0 { $slash = 'm//'; return "Einformixv6als::$1($2)"; }
  0         0  
6268 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1($2)"; }
  50         89  
6269 50         262 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1"; }
  2         6  
6270 2         10 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(::"."$2)"; }
  1         4  
6271 1         6 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         10  
6272             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lstat'; }
6273             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::stat'; }
6274 3         14  
  0         0  
6275 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6276 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6277 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6278 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6279 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6280 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6281             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6282 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6283 0         0  
  0         0  
6284 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6285 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6286 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6287 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6288 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6289             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6290             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6291 0         0  
  0         0  
6292 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6293 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6294 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6295             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6296 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         6  
6297 2         9  
  2         6  
6298 2         8 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         69  
6299 36         128 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         7  
6300 2         8 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::chr'; }
  2         6  
6301 2         10 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         28  
6302 8         52 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6303 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::glob'; }
  0         0  
6304 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lc_'; }
  0         0  
6305 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lcfirst_'; }
  0         0  
6306 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::uc_'; }
  0         0  
6307 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::ucfirst_'; }
  0         0  
6308 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::fc_'; }
  0         0  
6309             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lstat_'; }
6310 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::stat_'; }
  0         0  
6311             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6312 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest_(qw($1))"; }
  0         0  
6313             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6314 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Einformixv6als::${1}_"; }
  0         0  
6315              
6316 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6317 0         0  
  0         0  
6318 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6319 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6320 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::chr_'; }
  2         8  
6321 2         12 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6322 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         11  
6323 4         19 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::glob_'; }
  8         32  
6324 8         44 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         11  
6325 2         14 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6326 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Einformixv6als::opendir$1*"; }
  87         290  
6327             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Einformixv6als::opendir$1*"; }
6328             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::unlink'; }
6329              
6330 87         452 # chdir
6331             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6332 3         6 $slash = 'm//';
6333              
6334 3         4 my $e = 'Einformixv6als::chdir';
6335 3         12  
6336             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6337             $e .= $1;
6338             }
6339 3 50       11  
  3 100       257  
    50          
    50          
    50          
    0          
6340             # end of chdir
6341             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6342 0         0  
6343             # chdir scalar value
6344             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6345              
6346 1 0       3 # chdir qq//
  0         0  
6347             elsif (/\G \b (qq) \b /oxgc) {
6348 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6349 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6350 0         0 while (not /\G \z/oxgc) {
6351 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6352 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6353 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6354 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6355 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6356             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6357 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6358             }
6359             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6360             }
6361             }
6362              
6363 0 0       0 # chdir q//
  0         0  
6364             elsif (/\G \b (q) \b /oxgc) {
6365 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6366 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6367 0         0 while (not /\G \z/oxgc) {
6368 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6369 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6370 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6371 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6372 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6373             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6374 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6375             }
6376             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6377             }
6378             }
6379              
6380 0         0 # chdir ''
6381 2         5 elsif (/\G (\') /oxgc) {
6382 2 50       6 my $q_string = '';
  13 50       74  
    100          
    50          
6383 0         0 while (not /\G \z/oxgc) {
6384 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6385 2         8 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6386             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6387 11         23 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6388             }
6389             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6390             }
6391              
6392 0         0 # chdir ""
6393 0         0 elsif (/\G (\") /oxgc) {
6394 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6395 0         0 while (not /\G \z/oxgc) {
6396 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6397 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6398             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6399 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6400             }
6401             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6402             }
6403             }
6404              
6405 0         0 # split
6406             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6407 404         1106 $slash = 'm//';
6408 404         770  
6409 404         1593 my $e = '';
6410             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6411             $e .= $1;
6412             }
6413 401 100       1817  
  404 100       20142  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6414             # end of split
6415             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Einformixv6als::split' . $e; }
6416 3         15  
6417             # split scalar value
6418             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Einformixv6als::split' . $e . e_string($1); }
6419 1         9  
6420 0         0 # split literal space
6421 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Einformixv6als::split' . $e . qq {qq$1 $2}; }
6422 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6423 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6424 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6425 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6426 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6427 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Einformixv6als::split' . $e . qq {q$1 $2}; }
6428 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6429 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6430 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6431 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6432 13         83 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6433             elsif (/\G ' [ ] ' /oxgc) { return 'Einformixv6als::split' . $e . qq {' '}; }
6434             elsif (/\G " [ ] " /oxgc) { return 'Einformixv6als::split' . $e . qq {" "}; }
6435              
6436 2 0       9 # split qq//
  0         0  
6437             elsif (/\G \b (qq) \b /oxgc) {
6438 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6439 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6440 0         0 while (not /\G \z/oxgc) {
6441 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6442 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6443 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6444 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6445 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6446             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6447 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6448             }
6449             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6450             }
6451             }
6452              
6453 0 50       0 # split qr//
  124         958  
6454             elsif (/\G \b (qr) \b /oxgc) {
6455 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6456 124 50       356 else {
  124 50       6804  
    50          
    50          
    50          
    100          
    50          
    50          
6457 0         0 while (not /\G \z/oxgc) {
6458 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6459 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6460 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6461 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6462 56         221 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6463 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6464             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6465 68         363 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6466             }
6467             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6468             }
6469             }
6470              
6471 0 0       0 # split q//
  0         0  
6472             elsif (/\G \b (q) \b /oxgc) {
6473 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6474 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6475 0         0 while (not /\G \z/oxgc) {
6476 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6477 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6478 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6479 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6480 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6481             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6482 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6483             }
6484             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6485             }
6486             }
6487              
6488 0 50       0 # split m//
  136         1106  
6489             elsif (/\G \b (m) \b /oxgc) {
6490 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6491 136 50       417 else {
  136 50       8026  
    50          
    50          
    50          
    100          
    50          
    50          
6492 0         0 while (not /\G \z/oxgc) {
6493 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6494 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6495 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6496 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6497 56         292 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6498 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6499             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6500 80         380 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6501             }
6502             die __FILE__, ": Search pattern not terminated\n";
6503             }
6504             }
6505              
6506 0         0 # split ''
6507 0         0 elsif (/\G (\') /oxgc) {
6508 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6509 0         0 while (not /\G \z/oxgc) {
6510 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6511 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6512             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6513 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6514             }
6515             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6516             }
6517              
6518 0         0 # split ""
6519 0         0 elsif (/\G (\") /oxgc) {
6520 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6521 0         0 while (not /\G \z/oxgc) {
6522 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6523 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6524             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6525 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6526             }
6527             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6528             }
6529              
6530 0         0 # split //
6531 125         323 elsif (/\G (\/) /oxgc) {
6532 125 50       413 my $regexp = '';
  558 50       3265  
    100          
    50          
6533 0         0 while (not /\G \z/oxgc) {
6534 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6535 125         544 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6536             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6537 433         1057 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6538             }
6539             die __FILE__, ": Search pattern not terminated\n";
6540             }
6541             }
6542              
6543             # tr/// or y///
6544              
6545             # about [cdsrbB]* (/B modifier)
6546             #
6547             # P.559 appendix C
6548             # of ISBN 4-89052-384-7 Programming perl
6549             # (Japanese title is: Perl puroguramingu)
6550 0         0  
6551             elsif (/\G \b ( tr | y ) \b /oxgc) {
6552             my $ope = $1;
6553 11 50       28  
6554 11         244 # $1 $2 $3 $4 $5 $6
6555 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6556             my @tr = ($tr_variable,$2);
6557             return e_tr(@tr,'',$4,$6);
6558 0         0 }
6559 11         21 else {
6560 11 50       36 my $e = '';
  11 50       907  
    50          
    50          
    50          
    50          
6561             while (not /\G \z/oxgc) {
6562 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6563 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6564 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6565 0         0 while (not /\G \z/oxgc) {
6566 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6567 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6568 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6569 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6570             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6571 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6572             }
6573             die __FILE__, ": Transliteration replacement not terminated\n";
6574 0         0 }
6575 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6576 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6577 0         0 while (not /\G \z/oxgc) {
6578 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6579 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6580 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6581 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6582             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6583 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6584             }
6585             die __FILE__, ": Transliteration replacement not terminated\n";
6586 0         0 }
6587 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6588 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6589 0         0 while (not /\G \z/oxgc) {
6590 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6591 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6592 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6593 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6594             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6595 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6596             }
6597             die __FILE__, ": Transliteration replacement not terminated\n";
6598 0         0 }
6599 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6600 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6601 0         0 while (not /\G \z/oxgc) {
6602 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6603 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6604 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6605 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6606             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6607 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6608             }
6609             die __FILE__, ": Transliteration replacement not terminated\n";
6610             }
6611 0         0 # $1 $2 $3 $4 $5 $6
6612 11         43 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6613             my @tr = ($tr_variable,$2);
6614             return e_tr(@tr,'',$4,$6);
6615 11         42 }
6616             }
6617             die __FILE__, ": Transliteration pattern not terminated\n";
6618             }
6619             }
6620              
6621 0         0 # qq//
6622             elsif (/\G \b (qq) \b /oxgc) {
6623             my $ope = $1;
6624 5897 100       17508  
6625 5897         13308 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6626 40         61 if (/\G (\#) /oxgc) { # qq# #
6627 40 100       88 my $qq_string = '';
  1948 50       5479  
    100          
    50          
6628 80         156 while (not /\G \z/oxgc) {
6629 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6630 40         99 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6631             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6632 1828         3361 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6633             }
6634             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6635             }
6636 0         0  
6637 5857         8970 else {
6638 5857 50       15625 my $e = '';
  5857 50       24725  
    100          
    50          
    100          
    50          
6639             while (not /\G \z/oxgc) {
6640             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6641              
6642 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6643 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6644 0         0 my $qq_string = '';
6645 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6646 0         0 while (not /\G \z/oxgc) {
6647 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6648             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6649 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6650 0         0 elsif (/\G (\)) /oxgc) {
6651             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6652 0         0 else { $qq_string .= $1; }
6653             }
6654 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6655             }
6656             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6657             }
6658              
6659 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6660 5775         8931 elsif (/\G (\{) /oxgc) { # qq { }
6661 5775         9345 my $qq_string = '';
6662 5775 100       13266 local $nest = 1;
  246465 50       864033  
    100          
    100          
    50          
6663 720         1629 while (not /\G \z/oxgc) {
6664 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         2286  
6665             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6666 1384 100       2686 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         12753  
6667 5775         13823 elsif (/\G (\}) /oxgc) {
6668             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6669 1384         3192 else { $qq_string .= $1; }
6670             }
6671 237202         526636 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6672             }
6673             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6674             }
6675              
6676 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6677 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6678 0         0 my $qq_string = '';
6679 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6680 0         0 while (not /\G \z/oxgc) {
6681 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6682             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6683 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6684 0         0 elsif (/\G (\]) /oxgc) {
6685             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6686 0         0 else { $qq_string .= $1; }
6687             }
6688 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6689             }
6690             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6691             }
6692              
6693 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6694 62         125 elsif (/\G (\<) /oxgc) { # qq < >
6695 62         137 my $qq_string = '';
6696 62 100       188 local $nest = 1;
  2040 50       7601  
    100          
    100          
    50          
6697 22         56 while (not /\G \z/oxgc) {
6698 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         3  
6699             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6700 2 100       5 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         156  
6701 62         191 elsif (/\G (\>) /oxgc) {
6702             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6703 2         6 else { $qq_string .= $1; }
6704             }
6705 1952         3803 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6706             }
6707             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6708             }
6709              
6710 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6711 20         32 elsif (/\G (\S) /oxgc) { # qq * *
6712 20         22 my $delimiter = $1;
6713 20 50       38 my $qq_string = '';
  840 50       2471  
    100          
    50          
6714 0         0 while (not /\G \z/oxgc) {
6715 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6716 20         38 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6717             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6718 820         1518 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6719             }
6720             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6721 0         0 }
6722             }
6723             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6724             }
6725             }
6726              
6727 0         0 # qr//
6728 184 50       541 elsif (/\G \b (qr) \b /oxgc) {
6729 184         894 my $ope = $1;
6730             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6731             return e_qr($ope,$1,$3,$2,$4);
6732 0         0 }
6733 184         298 else {
6734 184 50       491 my $e = '';
  184 50       5209  
    100          
    50          
    50          
    100          
    50          
    50          
6735 0         0 while (not /\G \z/oxgc) {
6736 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6737 1         6 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6738 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6739 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6740 76         249 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6741 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6742             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6743 107         329 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6744             }
6745             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6746             }
6747             }
6748              
6749 0         0 # qw//
6750 34 50       137 elsif (/\G \b (qw) \b /oxgc) {
6751 34         132 my $ope = $1;
6752             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6753             return e_qw($ope,$1,$3,$2);
6754 0         0 }
6755 34         79 else {
6756 34 50       143 my $e = '';
  34 50       257  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6757             while (not /\G \z/oxgc) {
6758 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6759 34         149  
6760             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6761 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6762 0         0  
6763             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6764 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6765 0         0  
6766             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6767 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6768 0         0  
6769             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6770 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6771 0         0  
6772             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6773 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6774             }
6775             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6776             }
6777             }
6778              
6779 0         0 # qx//
6780 3 50       12 elsif (/\G \b (qx) \b /oxgc) {
6781 3         94 my $ope = $1;
6782             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6783             return e_qq($ope,$1,$3,$2);
6784 0         0 }
6785 3         12 else {
6786 3 50       15 my $e = '';
  3 50       530  
    100          
    50          
    50          
    50          
    50          
6787 0         0 while (not /\G \z/oxgc) {
6788 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6789 2         8 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6790 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6791 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6792 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6793             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6794 1         7 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6795             }
6796             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6797             }
6798             }
6799              
6800 0         0 # q//
6801             elsif (/\G \b (q) \b /oxgc) {
6802             my $ope = $1;
6803              
6804             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6805              
6806             # avoid "Error: Runtime exception" of perl version 5.005_03
6807 606 50       2249 # (and so on)
6808 606         2183  
6809 0         0 if (/\G (\#) /oxgc) { # q# #
6810 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6811 0         0 while (not /\G \z/oxgc) {
6812 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6813 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6814             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6815 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6816             }
6817             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6818             }
6819 0         0  
6820 606         1382 else {
6821 606 50       2285 my $e = '';
  606 100       4039  
    100          
    50          
    100          
    50          
6822             while (not /\G \z/oxgc) {
6823             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6824              
6825 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6826 1         3 elsif (/\G (\() /oxgc) { # q ( )
6827 1         2 my $q_string = '';
6828 1 50       3 local $nest = 1;
  7 50       64  
    50          
    50          
    100          
    50          
6829 0         0 while (not /\G \z/oxgc) {
6830 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6831 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6832             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6833 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         3  
6834 1         3 elsif (/\G (\)) /oxgc) {
6835             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6836 0         0 else { $q_string .= $1; }
6837             }
6838 6         15 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6839             }
6840             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6841             }
6842              
6843 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6844 599         1252 elsif (/\G (\{) /oxgc) { # q { }
6845 599         1317 my $q_string = '';
6846 599 50       2008 local $nest = 1;
  8319 50       44828  
    50          
    100          
    100          
    50          
6847 0         0 while (not /\G \z/oxgc) {
6848 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6849 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         218  
6850             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6851 114 100       257 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1889  
6852 599         2325 elsif (/\G (\}) /oxgc) {
6853             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6854 114         292 else { $q_string .= $1; }
6855             }
6856 7492         18731 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6857             }
6858             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6859             }
6860              
6861 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6862 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6863 0         0 my $q_string = '';
6864 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6865 0         0 while (not /\G \z/oxgc) {
6866 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6867 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6868             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6869 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6870 0         0 elsif (/\G (\]) /oxgc) {
6871             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6872 0         0 else { $q_string .= $1; }
6873             }
6874 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6875             }
6876             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6877             }
6878              
6879 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6880 5         14 elsif (/\G (\<) /oxgc) { # q < >
6881 5         12 my $q_string = '';
6882 5 50       24 local $nest = 1;
  82 50       503  
    50          
    50          
    100          
    50          
6883 0         0 while (not /\G \z/oxgc) {
6884 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6885 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6886             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6887 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         18  
6888 5         17 elsif (/\G (\>) /oxgc) {
6889             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6890 0         0 else { $q_string .= $1; }
6891             }
6892 77         182 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6893             }
6894             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6895             }
6896              
6897 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6898 1         3 elsif (/\G (\S) /oxgc) { # q * *
6899 1         4 my $delimiter = $1;
6900 1 50       5 my $q_string = '';
  14 50       104  
    100          
    50          
6901 0         0 while (not /\G \z/oxgc) {
6902 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6903 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6904             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6905 13         36 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6906             }
6907             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6908 0         0 }
6909             }
6910             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6911             }
6912             }
6913              
6914 0         0 # m//
6915 491 50       1430 elsif (/\G \b (m) \b /oxgc) {
6916 491         3225 my $ope = $1;
6917             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6918             return e_qr($ope,$1,$3,$2,$4);
6919 0         0 }
6920 491         824 else {
6921 491 50       1709 my $e = '';
  491 50       22766  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6922 0         0 while (not /\G \z/oxgc) {
6923 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6924 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6925 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6926 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6927 92         289 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6928 87         250 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6929 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6930             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6931 312         1161 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6932             }
6933             die __FILE__, ": Search pattern not terminated\n";
6934             }
6935             }
6936              
6937             # s///
6938              
6939             # about [cegimosxpradlunbB]* (/cg modifier)
6940             #
6941             # P.67 Pattern-Matching Operators
6942             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6943 0         0  
6944             elsif (/\G \b (s) \b /oxgc) {
6945             my $ope = $1;
6946 290 100       966  
6947 290         4998 # $1 $2 $3 $4 $5 $6
6948             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6949             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6950 1         7 }
6951 289         639 else {
6952 289 50       896 my $e = '';
  289 50       33327  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6953             while (not /\G \z/oxgc) {
6954 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6955 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6956 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6957             while (not /\G \z/oxgc) {
6958 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6959 0         0 # $1 $2 $3 $4
6960 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6963 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6964 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6965 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6966 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6967             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6968 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6969             }
6970             die __FILE__, ": Substitution replacement not terminated\n";
6971 0         0 }
6972 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6973 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6974             while (not /\G \z/oxgc) {
6975 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6976 0         0 # $1 $2 $3 $4
6977 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6979 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6980 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6981 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6982 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6983 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6984             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6985 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6986             }
6987             die __FILE__, ": Substitution replacement not terminated\n";
6988 0         0 }
6989 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6990 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6991             while (not /\G \z/oxgc) {
6992 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6993 0         0 # $1 $2 $3 $4
6994 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6995 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6996 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6997 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6998 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6999             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7000 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7001             }
7002             die __FILE__, ": Substitution replacement not terminated\n";
7003 0         0 }
7004 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
7005 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7006             while (not /\G \z/oxgc) {
7007 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7008 0         0 # $1 $2 $3 $4
7009 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7010 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7011 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7012 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7013 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7014 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7015 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7016             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7017 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7018             }
7019             die __FILE__, ": Substitution replacement not terminated\n";
7020             }
7021 0         0 # $1 $2 $3 $4 $5 $6
7022             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7023             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7024             }
7025 96         320 # $1 $2 $3 $4 $5 $6
7026             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7027             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7028             }
7029 2         31 # $1 $2 $3 $4 $5 $6
7030             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7031             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7032             }
7033 0         0 # $1 $2 $3 $4 $5 $6
7034             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7035             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7036 191         890 }
7037             }
7038             die __FILE__, ": Substitution pattern not terminated\n";
7039             }
7040             }
7041 0         0  
7042 1         7 # do
7043 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7044 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Einformixv6als::do'; }
7045 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7046             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7047             elsif (/\G \b do \b /oxmsgc) { return 'Einformixv6als::do'; }
7048 2         15  
7049 0         0 # require ignore module
7050 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7051             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "# require$1\n$2"; }
7052             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7053 0         0  
7054 0         0 # require version number
7055 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7056             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7057             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7058 0         0  
7059             # require bare package name
7060             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7061 18         146  
7062 0         0 # require else
7063             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Einformixv6als::require;'; }
7064             elsif (/\G \b require \b /oxmsgc) { return 'Einformixv6als::require'; }
7065 1         6  
7066 70         731 # use strict; --> use strict; no strict qw(refs);
7067 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7068             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7069             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7070              
7071 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7072 3         45 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7073             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7074             return "use $1; no strict qw(refs);";
7075 0         0 }
7076             else {
7077             return "use $1;";
7078             }
7079 3 0 0     19 }
      0        
7080 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7081             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7082             return "use $1; no strict qw(refs);";
7083 0         0 }
7084             else {
7085             return "use $1;";
7086             }
7087             }
7088 0         0  
7089 2         19 # ignore use module
7090 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7091             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "# use$1\n$2"; }
7092             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7093 0         0  
7094 0         0 # ignore no module
7095 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7096             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "# no$1\n$2"; }
7097             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7098 0         0  
7099 0         0 # use without import
7100 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7101 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7102 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7103 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7104 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7105 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7106 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7107 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7108             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7109             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7110 0         0  
7111             # use with import no parameter
7112             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7113 0         0  
7114 0         0 # use with import parameters
7115 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\x9F\xE0-\xFD)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7116 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\x9F\xE0-\xFD']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7117 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\x9F\xE0-\xFD"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7118 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\x9F\xE0-\xFD)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7119 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7120 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7121 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\x9F\xE0-\xFD>]* \>) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7122             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7123             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7124 0         0  
7125 0         0 # no without unimport
7126 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7127 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7128 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7129 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7130 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7131 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7132 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7133 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7134             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7135             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7136 0         0  
7137             # no with unimport no parameter
7138             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7139 0         0  
7140 0         0 # no with unimport parameters
7141 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\x9F\xE0-\xFD)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7142 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\x9F\xE0-\xFD']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7143 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\x9F\xE0-\xFD"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7144 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\x9F\xE0-\xFD)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7145 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7146 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7147 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\x9F\xE0-\xFD>]* \>) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7148             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7149             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7150 0         0  
7151             # use else
7152             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7153 0         0  
7154             # use else
7155             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7156              
7157 2         12 # ''
7158 3177         8172 elsif (/\G (?
7159 3177 100       9310 my $q_string = '';
  15808 100       62452  
    100          
    50          
7160 8         25 while (not /\G \z/oxgc) {
7161 48         119 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7162 3177         8368 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7163             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7164 12575         30966 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7165             }
7166             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7167             }
7168              
7169 0         0 # ""
7170 3404         8774 elsif (/\G (\") /oxgc) {
7171 3404 100       10365 my $qq_string = '';
  73908 100       234133  
    100          
    50          
7172 109         290 while (not /\G \z/oxgc) {
7173 14         36 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7174 3404         9437 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7175             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7176 70381         150444 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7177             }
7178             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7179             }
7180              
7181 0         0 # ``
7182 37         134 elsif (/\G (\`) /oxgc) {
7183 37 50       156 my $qx_string = '';
  313 50       2213  
    100          
    50          
7184 0         0 while (not /\G \z/oxgc) {
7185 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7186 37         142 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7187             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7188 276         700 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7189             }
7190             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7191             }
7192              
7193 0         0 # // --- not divide operator (num / num), not defined-or
7194 1231         3404 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7195 1231 100       3762 my $regexp = '';
  12510 50       48578  
    100          
    50          
7196 11         41 while (not /\G \z/oxgc) {
7197 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7198 1231         3551 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7199             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7200 11268         26245 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7201             }
7202             die __FILE__, ": Search pattern not terminated\n";
7203             }
7204              
7205 0         0 # ?? --- not conditional operator (condition ? then : else)
7206 92         254 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7207 92 50       261 my $regexp = '';
  266 50       1215  
    100          
    50          
7208 0         0 while (not /\G \z/oxgc) {
7209 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7210 92         253 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7211             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7212 174         491 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7213             }
7214             die __FILE__, ": Search pattern not terminated\n";
7215             }
7216 0         0  
  0         0  
7217             # <<>> (a safer ARGV)
7218             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7219 0         0  
  0         0  
7220             # << (bit shift) --- not here document
7221             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7222              
7223 0         0 # <<~'HEREDOC'
7224 6         16 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7225 6         12 $slash = 'm//';
7226             my $here_quote = $1;
7227             my $delimiter = $2;
7228 6 50       10  
7229 6         12 # get here document
7230 6         38 if ($here_script eq '') {
7231             $here_script = CORE::substr $_, pos $_;
7232 6 50       34 $here_script =~ s/.*?\n//oxm;
7233 6         53 }
7234 6         15 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7235 6         10 my $heredoc = $1;
7236 6         45 my $indent = $2;
7237 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
7238             push @heredoc, $heredoc . qq{\n$delimiter\n};
7239             push @heredoc_delimiter, qq{\\s*$delimiter};
7240 6         10 }
7241             else {
7242 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7243             }
7244             return qq{<<'$delimiter'};
7245             }
7246              
7247             # <<~\HEREDOC
7248              
7249             # P.66 2.6.6. "Here" Documents
7250             # in Chapter 2: Bits and Pieces
7251             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7252              
7253             # P.73 "Here" Documents
7254             # in Chapter 2: Bits and Pieces
7255             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7256 6         35  
7257 3         8 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7258 3         6 $slash = 'm//';
7259             my $here_quote = $1;
7260             my $delimiter = $2;
7261 3 50       7  
7262 3         9 # get here document
7263 3         15 if ($here_script eq '') {
7264             $here_script = CORE::substr $_, pos $_;
7265 3 50       18 $here_script =~ s/.*?\n//oxm;
7266 3         35 }
7267 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7268 3         4 my $heredoc = $1;
7269 3         34 my $indent = $2;
7270 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
7271             push @heredoc, $heredoc . qq{\n$delimiter\n};
7272             push @heredoc_delimiter, qq{\\s*$delimiter};
7273 3         8 }
7274             else {
7275 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7276             }
7277             return qq{<<\\$delimiter};
7278             }
7279              
7280 3         13 # <<~"HEREDOC"
7281 6         13 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7282 6         14 $slash = 'm//';
7283             my $here_quote = $1;
7284             my $delimiter = $2;
7285 6 50       9  
7286 6         13 # get here document
7287 6         28 if ($here_script eq '') {
7288             $here_script = CORE::substr $_, pos $_;
7289 6 50       31 $here_script =~ s/.*?\n//oxm;
7290 6         64 }
7291 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7292 6         11 my $heredoc = $1;
7293 6         44 my $indent = $2;
7294 6         16 $heredoc =~ s{^$indent}{}msg; # no /ox
7295             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7296             push @heredoc_delimiter, qq{\\s*$delimiter};
7297 6         14 }
7298             else {
7299 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7300             }
7301             return qq{<<"$delimiter"};
7302             }
7303              
7304 6         24 # <<~HEREDOC
7305 3         9 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7306 3         5 $slash = 'm//';
7307             my $here_quote = $1;
7308             my $delimiter = $2;
7309 3 50       7  
7310 3         7 # get here document
7311 3         14 if ($here_script eq '') {
7312             $here_script = CORE::substr $_, pos $_;
7313 3 50       16 $here_script =~ s/.*?\n//oxm;
7314 3         39 }
7315 3         6 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7316 3         5 my $heredoc = $1;
7317 3         35 my $indent = $2;
7318 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
7319             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7320             push @heredoc_delimiter, qq{\\s*$delimiter};
7321 3         9 }
7322             else {
7323 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7324             }
7325             return qq{<<$delimiter};
7326             }
7327              
7328 3         14 # <<~`HEREDOC`
7329 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7330 6         14 $slash = 'm//';
7331             my $here_quote = $1;
7332             my $delimiter = $2;
7333 6 50       9  
7334 6         13 # get here document
7335 6         29 if ($here_script eq '') {
7336             $here_script = CORE::substr $_, pos $_;
7337 6 50       41 $here_script =~ s/.*?\n//oxm;
7338 6         60 }
7339 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7340 6         8 my $heredoc = $1;
7341 6         51 my $indent = $2;
7342 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
7343             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7344             push @heredoc_delimiter, qq{\\s*$delimiter};
7345 6         12 }
7346             else {
7347 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7348             }
7349             return qq{<<`$delimiter`};
7350             }
7351              
7352 6         23 # <<'HEREDOC'
7353 86         233 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7354 86         222 $slash = 'm//';
7355             my $here_quote = $1;
7356             my $delimiter = $2;
7357 86 100       180  
7358 86         202 # get here document
7359 83         507 if ($here_script eq '') {
7360             $here_script = CORE::substr $_, pos $_;
7361 83 50       532 $here_script =~ s/.*?\n//oxm;
7362 86         760 }
7363 86         340 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7364             push @heredoc, $1 . qq{\n$delimiter\n};
7365             push @heredoc_delimiter, $delimiter;
7366 86         167 }
7367             else {
7368 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7369             }
7370             return $here_quote;
7371             }
7372              
7373             # <<\HEREDOC
7374              
7375             # P.66 2.6.6. "Here" Documents
7376             # in Chapter 2: Bits and Pieces
7377             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7378              
7379             # P.73 "Here" Documents
7380             # in Chapter 2: Bits and Pieces
7381             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7382 86         391  
7383 2         6 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7384 2         5 $slash = 'm//';
7385             my $here_quote = $1;
7386             my $delimiter = $2;
7387 2 100       5  
7388 2         5 # get here document
7389 1         6 if ($here_script eq '') {
7390             $here_script = CORE::substr $_, pos $_;
7391 1 50       6 $here_script =~ s/.*?\n//oxm;
7392 2         27 }
7393 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7394             push @heredoc, $1 . qq{\n$delimiter\n};
7395             push @heredoc_delimiter, $delimiter;
7396 2         16 }
7397             else {
7398 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7399             }
7400             return $here_quote;
7401             }
7402              
7403 2         11 # <<"HEREDOC"
7404 39         119 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7405 39         111 $slash = 'm//';
7406             my $here_quote = $1;
7407             my $delimiter = $2;
7408 39 100       77  
7409 39         111 # get here document
7410 38         274 if ($here_script eq '') {
7411             $here_script = CORE::substr $_, pos $_;
7412 38 50       230 $here_script =~ s/.*?\n//oxm;
7413 39         541 }
7414 39         137 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7415             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7416             push @heredoc_delimiter, $delimiter;
7417 39         100 }
7418             else {
7419 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7420             }
7421             return $here_quote;
7422             }
7423              
7424 39         166 # <
7425 54         152 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7426 54         129 $slash = 'm//';
7427             my $here_quote = $1;
7428             my $delimiter = $2;
7429 54 100       107  
7430 54         167 # get here document
7431 51         358 if ($here_script eq '') {
7432             $here_script = CORE::substr $_, pos $_;
7433 51 50       370 $here_script =~ s/.*?\n//oxm;
7434 54         757 }
7435 54         199 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7436             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7437             push @heredoc_delimiter, $delimiter;
7438 54         132 }
7439             else {
7440 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7441             }
7442             return $here_quote;
7443             }
7444              
7445 54         246 # <<`HEREDOC`
7446 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7447 0         0 $slash = 'm//';
7448             my $here_quote = $1;
7449             my $delimiter = $2;
7450 0 0       0  
7451 0         0 # get here document
7452 0         0 if ($here_script eq '') {
7453             $here_script = CORE::substr $_, pos $_;
7454 0 0       0 $here_script =~ s/.*?\n//oxm;
7455 0         0 }
7456 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7457             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7458             push @heredoc_delimiter, $delimiter;
7459 0         0 }
7460             else {
7461 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7462             }
7463             return $here_quote;
7464             }
7465              
7466 0         0 # <<= <=> <= < operator
7467             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7468             return $1;
7469             }
7470              
7471 13         139 #
7472             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7473             return $1;
7474             }
7475              
7476             # --- glob
7477              
7478             # avoid "Error: Runtime exception" of perl version 5.005_03
7479 0         0  
7480             elsif (/\G < ((?:[^\x81-\x9F\xE0-\xFD>\0\a\e\f\n\r\t]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])+?) > /oxgc) {
7481             return 'Einformixv6als::glob("' . $1 . '")';
7482             }
7483 0         0  
7484             # __DATA__
7485             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7486 0         0  
7487             # __END__
7488             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7489              
7490             # \cD Control-D
7491              
7492             # P.68 2.6.8. Other Literal Tokens
7493             # in Chapter 2: Bits and Pieces
7494             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7495              
7496             # P.76 Other Literal Tokens
7497             # in Chapter 2: Bits and Pieces
7498 384         3468 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7499              
7500             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7501 0         0  
7502             # \cZ Control-Z
7503             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7504              
7505             # any operator before div
7506             elsif (/\G (
7507             -- | \+\+ |
7508 0         0 [\)\}\]]
  14161         34704  
7509              
7510             ) /oxgc) { $slash = 'div'; return $1; }
7511              
7512             # yada-yada or triple-dot operator
7513             elsif (/\G (
7514 14161         75083 \.\.\.
  7         19  
7515              
7516             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7517              
7518             # any operator before m//
7519              
7520             # //, //= (defined-or)
7521              
7522             # P.164 Logical Operators
7523             # in Chapter 10: More Control Structures
7524             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7525              
7526             # P.119 C-Style Logical (Short-Circuit) Operators
7527             # in Chapter 3: Unary and Binary Operators
7528             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7529              
7530             # (and so on)
7531              
7532             # ~~
7533              
7534             # P.221 The Smart Match Operator
7535             # in Chapter 15: Smart Matching and given-when
7536             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7537              
7538             # P.112 Smartmatch Operator
7539             # in Chapter 3: Unary and Binary Operators
7540             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7541              
7542             # (and so on)
7543              
7544             elsif (/\G ((?>
7545              
7546             !~~ | !~ | != | ! |
7547             %= | % |
7548             &&= | && | &= | &\.= | &\. | & |
7549             -= | -> | - |
7550             :(?>\s*)= |
7551             : |
7552             <<>> |
7553             <<= | <=> | <= | < |
7554             == | => | =~ | = |
7555             >>= | >> | >= | > |
7556             \*\*= | \*\* | \*= | \* |
7557             \+= | \+ |
7558             \.\. | \.= | \. |
7559             \/\/= | \/\/ |
7560             \/= | \/ |
7561             \? |
7562             \\ |
7563             \^= | \^\.= | \^\. | \^ |
7564             \b x= |
7565             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7566             ~~ | ~\. | ~ |
7567             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7568             \b(?: print )\b |
7569              
7570 7         32 [,;\(\{\[]
  23792         57023  
7571              
7572             )) /oxgc) { $slash = 'm//'; return $1; }
7573 23792         125676  
  38298         91777  
7574             # other any character
7575             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7576              
7577 38298         224028 # system error
7578             else {
7579             die __FILE__, ": Oops, this shouldn't happen!\n";
7580             }
7581             }
7582              
7583 0     3097 0 0 # escape INFORMIX V6 ALS string
7584 3097         8258 sub e_string {
7585             my($string) = @_;
7586 3097         5146 my $e_string = '';
7587              
7588             local $slash = 'm//';
7589              
7590             # P.1024 Appendix W.10 Multibyte Processing
7591             # of ISBN 1-56592-224-7 CJKV Information Processing
7592 3097         5133 # (and so on)
7593              
7594             my @char = $string =~ / \G (?>[^\x81-\x9F\xE0-\xFD\\]|\\$q_char|$q_char) /oxmsg;
7595 3097 100 66     53935  
7596 3097 50       15894 # without { ... }
7597 3018         7574 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7598             if ($string !~ /<
7599             return $string;
7600             }
7601             }
7602 3018         8336  
7603 79 50       247 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
7604             while ($string !~ /\G \z/oxgc) {
7605             if (0) {
7606             }
7607 606         99006  
7608 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Einformixv6als::PREMATCH()]}
7609 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7610             $e_string .= q{Einformixv6als::PREMATCH()};
7611             $slash = 'div';
7612             }
7613              
7614 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Einformixv6als::MATCH()]}
7615 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7616             $e_string .= q{Einformixv6als::MATCH()};
7617             $slash = 'div';
7618             }
7619              
7620 0         0 # $', ${'} --> $', ${'}
7621 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7622             $e_string .= $1;
7623             $slash = 'div';
7624             }
7625              
7626 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Einformixv6als::POSTMATCH()]}
7627 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7628             $e_string .= q{Einformixv6als::POSTMATCH()};
7629             $slash = 'div';
7630             }
7631              
7632 0         0 # bareword
7633 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7634             $e_string .= $1;
7635             $slash = 'div';
7636             }
7637              
7638 0         0 # $0 --> $0
7639 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7640             $e_string .= $1;
7641             $slash = 'div';
7642 0         0 }
7643 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7644             $e_string .= $1;
7645             $slash = 'div';
7646             }
7647              
7648 0         0 # $$ --> $$
7649 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7650             $e_string .= $1;
7651             $slash = 'div';
7652             }
7653              
7654             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7655 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7656 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7657             $e_string .= e_capture($1);
7658             $slash = 'div';
7659 0         0 }
7660 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7661             $e_string .= e_capture($1);
7662             $slash = 'div';
7663             }
7664              
7665 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7666 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7667             $e_string .= e_capture($1.'->'.$2);
7668             $slash = 'div';
7669             }
7670              
7671 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7672 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7673             $e_string .= e_capture($1.'->'.$2);
7674             $slash = 'div';
7675             }
7676              
7677 0         0 # $$foo
7678 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7679             $e_string .= e_capture($1);
7680             $slash = 'div';
7681             }
7682              
7683 0         0 # ${ foo }
7684 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7685             $e_string .= '${' . $1 . '}';
7686             $slash = 'div';
7687             }
7688              
7689 0         0 # ${ ... }
7690 3         13 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7691             $e_string .= e_capture($1);
7692             $slash = 'div';
7693             }
7694              
7695             # variable or function
7696 3         19 # $ @ % & * $ #
7697 0         0 elsif ($string =~ /\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
7698             $e_string .= $1;
7699             $slash = 'div';
7700             }
7701             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7702 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7703 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7704             $e_string .= $1;
7705             $slash = 'div';
7706             }
7707 0         0  
  0         0  
7708 0         0 # subroutines of package Einformixv6als
  0         0  
7709 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7711 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7712 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7713 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::eval \b /oxgc) { $e_string .= 'eval INFORMIXV6ALS::escape'; $slash = 'm//'; }
  0         0  
7714 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7715 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Einformixv6als::chop'; $slash = 'm//'; }
  0         0  
7716 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7717 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7718 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::index \b /oxgc) { $e_string .= 'INFORMIXV6ALS::index'; $slash = 'm//'; }
  0         0  
7719 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Einformixv6als::index'; $slash = 'm//'; }
  0         0  
7720 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7721 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7722 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::rindex \b /oxgc) { $e_string .= 'INFORMIXV6ALS::rindex'; $slash = 'm//'; }
  0         0  
7723 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Einformixv6als::rindex'; $slash = 'm//'; }
  0         0  
7724 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::lc'; $slash = 'm//'; }
  0         0  
7725 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::lcfirst'; $slash = 'm//'; }
  0         0  
7726 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::uc'; $slash = 'm//'; }
  0         0  
7727             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::ucfirst'; $slash = 'm//'; }
7728 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::fc'; $slash = 'm//'; }
  0         0  
7729 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7730 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7731 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7732 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7733 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7734 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
7735             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7736             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7737 1         5  
  1         24  
7738 1         5 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7739 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7740 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7741 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7742 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7743 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
7744             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7745             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7746 1         4  
  0         0  
7747 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7748 0         0 { $e_string .= "Einformixv6als::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7749 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7750             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Einformixv6als::filetest qw($1),"; $slash = 'm//'; }
7751 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7752 0         0  
  0         0  
7753 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7754 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7755 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7756 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7757 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         15  
7758             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7759 2         7 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         9  
7760 1         4  
  0         0  
7761 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7762 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7763 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7764 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7765 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         24  
7766             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7767             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7768 2         10  
  0         0  
7769 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7770 0         0 { $e_string .= "Einformixv6als::$1($2)"; $slash = 'm//'; }
  0         0  
7771 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Einformixv6als::$1($2)"; $slash = 'm//'; }
  0         0  
7772 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Einformixv6als::$1"; $slash = 'm//'; }
  0         0  
7773 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Einformixv6als::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7774 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7775             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::lstat'; $slash = 'm//'; }
7776             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::stat'; $slash = 'm//'; }
7777 0         0  
  0         0  
7778 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7779 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7780 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7781 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7782 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7783 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7784             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7785 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
7786 0         0  
  0         0  
7787 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7788 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7789 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7790 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7791 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
7792             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7793             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7794 0         0  
  0         0  
7795 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7796 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7797 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7798             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7799 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7800 0         0  
  0         0  
7801 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::chr'; $slash = 'm//'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7805 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7806 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::glob'; $slash = 'm//'; }
  0         0  
7807 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Einformixv6als::lc_'; $slash = 'm//'; }
  0         0  
7808 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Einformixv6als::lcfirst_'; $slash = 'm//'; }
  0         0  
7809 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Einformixv6als::uc_'; $slash = 'm//'; }
  0         0  
7810 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Einformixv6als::ucfirst_'; $slash = 'm//'; }
  0         0  
7811 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Einformixv6als::fc_'; $slash = 'm//'; }
  0         0  
7812             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Einformixv6als::lstat_'; $slash = 'm//'; }
7813 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Einformixv6als::stat_'; $slash = 'm//'; }
  0         0  
7814 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7815 0         0 \b /oxgc) { $e_string .= "Einformixv6als::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7816             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Einformixv6als::${1}_"; $slash = 'm//'; }
7817 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7818 0         0  
  0         0  
7819 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7820 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7821 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Einformixv6als::chr_'; $slash = 'm//'; }
  0         0  
7822 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7823 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7824 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Einformixv6als::glob_'; $slash = 'm//'; }
  0         0  
7825 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7826 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7827 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Einformixv6als::opendir$1*"; $slash = 'm//'; }
  0         0  
7828             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Einformixv6als::opendir$1*"; $slash = 'm//'; }
7829             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Einformixv6als::unlink'; $slash = 'm//'; }
7830              
7831 0         0 # chdir
7832             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7833 0         0 $slash = 'm//';
7834              
7835 0         0 $e_string .= 'Einformixv6als::chdir';
7836 0         0  
7837             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7838             $e_string .= $1;
7839             }
7840 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7841             # end of chdir
7842             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7843 0         0  
  0         0  
7844             # chdir scalar value
7845             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7846              
7847 0 0       0 # chdir qq//
  0         0  
  0         0  
7848             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7849 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7850 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7851 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7852 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7853 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7854 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7855 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7856 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7857             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7858 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7859             }
7860             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7861             }
7862             }
7863              
7864 0 0       0 # chdir q//
  0         0  
  0         0  
7865             elsif ($string =~ /\G \b (q) \b /oxgc) {
7866 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7867 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7868 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7869 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7870 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7871 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7872 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7873 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7874             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7875 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q * * --> qr * *
7876             }
7877             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7878             }
7879             }
7880              
7881 0         0 # chdir ''
7882 0         0 elsif ($string =~ /\G (\') /oxgc) {
7883 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7884 0         0 while ($string !~ /\G \z/oxgc) {
7885 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7886 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7887             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7888 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7889             }
7890             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7891             }
7892              
7893 0         0 # chdir ""
7894 0         0 elsif ($string =~ /\G (\") /oxgc) {
7895 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7896 0         0 while ($string !~ /\G \z/oxgc) {
7897 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7898 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7899             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7900 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7901             }
7902             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7903             }
7904             }
7905              
7906 0         0 # split
7907             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7908 0         0 $slash = 'm//';
7909 0         0  
7910 0         0 my $e = '';
7911             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7912             $e .= $1;
7913             }
7914 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7915             # end of split
7916             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Einformixv6als::split' . $e; }
7917 0         0  
  0         0  
7918             # split scalar value
7919             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . e_string($1); next E_STRING_LOOP; }
7920 0         0  
  0         0  
7921 0         0 # split literal space
  0         0  
7922 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7923 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7924 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7925 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7926 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7927 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7928 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7929 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7930 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7931 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7932 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7933 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7934             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {' '}; next E_STRING_LOOP; }
7935             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {" "}; next E_STRING_LOOP; }
7936              
7937 0 0       0 # split qq//
  0         0  
  0         0  
7938             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7939 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7940 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7941 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7942 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7943 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7944 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7945 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7946 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7947             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7948 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
7949             }
7950             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7951             }
7952             }
7953              
7954 0 0       0 # split qr//
  0         0  
  0         0  
7955             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7956 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7957 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7958 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7959 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7960 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
7961 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
7962 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
7963 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
7964 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
7965             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7966 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
7967             }
7968             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7969             }
7970             }
7971              
7972 0 0       0 # split q//
  0         0  
  0         0  
7973             elsif ($string =~ /\G \b (q) \b /oxgc) {
7974 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7975 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7976 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7977 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7978 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7979 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7980 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7981 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7982             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7983 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
7984             }
7985             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7986             }
7987             }
7988              
7989 0 0       0 # split m//
  0         0  
  0         0  
7990             elsif ($string =~ /\G \b (m) \b /oxgc) {
7991 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
7992 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7993 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7994 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7995 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
7996 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
7997 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
7998 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
7999 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
8000             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
8001 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
8002             }
8003             die __FILE__, ": Search pattern not terminated\n";
8004             }
8005             }
8006              
8007 0         0 # split ''
8008 0         0 elsif ($string =~ /\G (\') /oxgc) {
8009 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
8010 0         0 while ($string !~ /\G \z/oxgc) {
8011 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
8012 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
8013             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
8014 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
8015             }
8016             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8017             }
8018              
8019 0         0 # split ""
8020 0         0 elsif ($string =~ /\G (\") /oxgc) {
8021 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
8022 0         0 while ($string !~ /\G \z/oxgc) {
8023 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8024 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8025             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8026 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8027             }
8028             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8029             }
8030              
8031 0         0 # split //
8032 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8033 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8034 0         0 while ($string !~ /\G \z/oxgc) {
8035 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8036 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8037             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8038 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8039             }
8040             die __FILE__, ": Search pattern not terminated\n";
8041             }
8042             }
8043              
8044 0         0 # qq//
8045 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8046 0         0 my $ope = $1;
8047             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8048             $e_string .= e_qq($ope,$1,$3,$2);
8049 0         0 }
8050 0         0 else {
8051 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8052 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8053 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8054 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8055 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8056 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8057             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8058 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8059             }
8060             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8061             }
8062             }
8063              
8064 0         0 # qx//
8065 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8066 0         0 my $ope = $1;
8067             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8068             $e_string .= e_qq($ope,$1,$3,$2);
8069 0         0 }
8070 0         0 else {
8071 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8072 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8073 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8074 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8075 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8076 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8077 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8078             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8079 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8080             }
8081             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8082             }
8083             }
8084              
8085 0         0 # q//
8086 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8087 0         0 my $ope = $1;
8088             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8089             $e_string .= e_q($ope,$1,$3,$2);
8090 0         0 }
8091 0         0 else {
8092 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8093 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8094 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8095 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8096 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8097 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8098             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8099 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
8100             }
8101             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8102             }
8103             }
8104 0         0  
8105             # ''
8106             elsif ($string =~ /\G (?
8107 44         208  
8108             # ""
8109             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8110 6         99  
8111             # ``
8112             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8113 0         0  
8114             # <<>> (a safer ARGV)
8115             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8116 0         0  
8117             # <<= <=> <= < operator
8118             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8119 0         0  
8120             #
8121             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8122              
8123 0         0 # --- glob
8124             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8125             $e_string .= 'Einformixv6als::glob("' . $1 . '")';
8126             }
8127              
8128 0         0 # << (bit shift) --- not here document
8129 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8130             $slash = 'm//';
8131             $e_string .= $1;
8132             }
8133              
8134 0         0 # <<~'HEREDOC'
8135 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8136 0         0 $slash = 'm//';
8137             my $here_quote = $1;
8138             my $delimiter = $2;
8139 0 0       0  
8140 0         0 # get here document
8141 0         0 if ($here_script eq '') {
8142             $here_script = CORE::substr $_, pos $_;
8143 0 0       0 $here_script =~ s/.*?\n//oxm;
8144 0         0 }
8145 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8146 0         0 my $heredoc = $1;
8147 0         0 my $indent = $2;
8148 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8149             push @heredoc, $heredoc . qq{\n$delimiter\n};
8150             push @heredoc_delimiter, qq{\\s*$delimiter};
8151 0         0 }
8152             else {
8153 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8154             }
8155             $e_string .= qq{<<'$delimiter'};
8156             }
8157              
8158 0         0 # <<~\HEREDOC
8159 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8160 0         0 $slash = 'm//';
8161             my $here_quote = $1;
8162             my $delimiter = $2;
8163 0 0       0  
8164 0         0 # get here document
8165 0         0 if ($here_script eq '') {
8166             $here_script = CORE::substr $_, pos $_;
8167 0 0       0 $here_script =~ s/.*?\n//oxm;
8168 0         0 }
8169 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8170 0         0 my $heredoc = $1;
8171 0         0 my $indent = $2;
8172 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8173             push @heredoc, $heredoc . qq{\n$delimiter\n};
8174             push @heredoc_delimiter, qq{\\s*$delimiter};
8175 0         0 }
8176             else {
8177 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8178             }
8179             $e_string .= qq{<<\\$delimiter};
8180             }
8181              
8182 0         0 # <<~"HEREDOC"
8183 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8184 0         0 $slash = 'm//';
8185             my $here_quote = $1;
8186             my $delimiter = $2;
8187 0 0       0  
8188 0         0 # get here document
8189 0         0 if ($here_script eq '') {
8190             $here_script = CORE::substr $_, pos $_;
8191 0 0       0 $here_script =~ s/.*?\n//oxm;
8192 0         0 }
8193 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8194 0         0 my $heredoc = $1;
8195 0         0 my $indent = $2;
8196 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8197             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8198             push @heredoc_delimiter, qq{\\s*$delimiter};
8199 0         0 }
8200             else {
8201 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8202             }
8203             $e_string .= qq{<<"$delimiter"};
8204             }
8205              
8206 0         0 # <<~HEREDOC
8207 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8208 0         0 $slash = 'm//';
8209             my $here_quote = $1;
8210             my $delimiter = $2;
8211 0 0       0  
8212 0         0 # get here document
8213 0         0 if ($here_script eq '') {
8214             $here_script = CORE::substr $_, pos $_;
8215 0 0       0 $here_script =~ s/.*?\n//oxm;
8216 0         0 }
8217 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8218 0         0 my $heredoc = $1;
8219 0         0 my $indent = $2;
8220 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8221             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8222             push @heredoc_delimiter, qq{\\s*$delimiter};
8223 0         0 }
8224             else {
8225 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8226             }
8227             $e_string .= qq{<<$delimiter};
8228             }
8229              
8230 0         0 # <<~`HEREDOC`
8231 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8232 0         0 $slash = 'm//';
8233             my $here_quote = $1;
8234             my $delimiter = $2;
8235 0 0       0  
8236 0         0 # get here document
8237 0         0 if ($here_script eq '') {
8238             $here_script = CORE::substr $_, pos $_;
8239 0 0       0 $here_script =~ s/.*?\n//oxm;
8240 0         0 }
8241 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8242 0         0 my $heredoc = $1;
8243 0         0 my $indent = $2;
8244 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8245             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8246             push @heredoc_delimiter, qq{\\s*$delimiter};
8247 0         0 }
8248             else {
8249 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8250             }
8251             $e_string .= qq{<<`$delimiter`};
8252             }
8253              
8254 0         0 # <<'HEREDOC'
8255 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8256 0         0 $slash = 'm//';
8257             my $here_quote = $1;
8258             my $delimiter = $2;
8259 0 0       0  
8260 0         0 # get here document
8261 0         0 if ($here_script eq '') {
8262             $here_script = CORE::substr $_, pos $_;
8263 0 0       0 $here_script =~ s/.*?\n//oxm;
8264 0         0 }
8265 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8266             push @heredoc, $1 . qq{\n$delimiter\n};
8267             push @heredoc_delimiter, $delimiter;
8268 0         0 }
8269             else {
8270 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8271             }
8272             $e_string .= $here_quote;
8273             }
8274              
8275 0         0 # <<\HEREDOC
8276 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8277 0         0 $slash = 'm//';
8278             my $here_quote = $1;
8279             my $delimiter = $2;
8280 0 0       0  
8281 0         0 # get here document
8282 0         0 if ($here_script eq '') {
8283             $here_script = CORE::substr $_, pos $_;
8284 0 0       0 $here_script =~ s/.*?\n//oxm;
8285 0         0 }
8286 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8287             push @heredoc, $1 . qq{\n$delimiter\n};
8288             push @heredoc_delimiter, $delimiter;
8289 0         0 }
8290             else {
8291 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8292             }
8293             $e_string .= $here_quote;
8294             }
8295              
8296 0         0 # <<"HEREDOC"
8297 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8298 0         0 $slash = 'm//';
8299             my $here_quote = $1;
8300             my $delimiter = $2;
8301 0 0       0  
8302 0         0 # get here document
8303 0         0 if ($here_script eq '') {
8304             $here_script = CORE::substr $_, pos $_;
8305 0 0       0 $here_script =~ s/.*?\n//oxm;
8306 0         0 }
8307 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8308             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8309             push @heredoc_delimiter, $delimiter;
8310 0         0 }
8311             else {
8312 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8313             }
8314             $e_string .= $here_quote;
8315             }
8316              
8317 0         0 # <
8318 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8319 0         0 $slash = 'm//';
8320             my $here_quote = $1;
8321             my $delimiter = $2;
8322 0 0       0  
8323 0         0 # get here document
8324 0         0 if ($here_script eq '') {
8325             $here_script = CORE::substr $_, pos $_;
8326 0 0       0 $here_script =~ s/.*?\n//oxm;
8327 0         0 }
8328 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8329             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8330             push @heredoc_delimiter, $delimiter;
8331 0         0 }
8332             else {
8333 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8334             }
8335             $e_string .= $here_quote;
8336             }
8337              
8338 0         0 # <<`HEREDOC`
8339 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8340 0         0 $slash = 'm//';
8341             my $here_quote = $1;
8342             my $delimiter = $2;
8343 0 0       0  
8344 0         0 # get here document
8345 0         0 if ($here_script eq '') {
8346             $here_script = CORE::substr $_, pos $_;
8347 0 0       0 $here_script =~ s/.*?\n//oxm;
8348 0         0 }
8349 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8350             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8351             push @heredoc_delimiter, $delimiter;
8352 0         0 }
8353             else {
8354 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8355             }
8356             $e_string .= $here_quote;
8357             }
8358              
8359             # any operator before div
8360             elsif ($string =~ /\G (
8361             -- | \+\+ |
8362 0         0 [\)\}\]]
  80         199  
8363              
8364             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8365              
8366             # yada-yada or triple-dot operator
8367             elsif ($string =~ /\G (
8368 80         332 \.\.\.
  0         0  
8369              
8370             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8371              
8372             # any operator before m//
8373             elsif ($string =~ /\G ((?>
8374              
8375             !~~ | !~ | != | ! |
8376             %= | % |
8377             &&= | && | &= | &\.= | &\. | & |
8378             -= | -> | - |
8379             :(?>\s*)= |
8380             : |
8381             <<>> |
8382             <<= | <=> | <= | < |
8383             == | => | =~ | = |
8384             >>= | >> | >= | > |
8385             \*\*= | \*\* | \*= | \* |
8386             \+= | \+ |
8387             \.\. | \.= | \. |
8388             \/\/= | \/\/ |
8389             \/= | \/ |
8390             \? |
8391             \\ |
8392             \^= | \^\.= | \^\. | \^ |
8393             \b x= |
8394             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8395             ~~ | ~\. | ~ |
8396             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8397             \b(?: print )\b |
8398              
8399 0         0 [,;\(\{\[]
  112         292  
8400              
8401             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8402 112         876  
8403             # other any character
8404             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8405              
8406 353         1739 # system error
8407             else {
8408             die __FILE__, ": Oops, this shouldn't happen!\n";
8409             }
8410 0         0 }
8411              
8412             return $e_string;
8413             }
8414              
8415             #
8416             # character class
8417 79     5342 0 365 #
8418             sub character_class {
8419 5342 100       11261 my($char,$modifier) = @_;
8420 5342 100       9215  
8421 115         292 if ($char eq '.') {
8422             if ($modifier =~ /s/) {
8423             return '${Einformixv6als::dot_s}';
8424 23         70 }
8425             else {
8426             return '${Einformixv6als::dot}';
8427             }
8428 92         223 }
8429             else {
8430             return Einformixv6als::classic_character_class($char);
8431             }
8432             }
8433              
8434             #
8435             # escape capture ($1, $2, $3, ...)
8436             #
8437 5227     637 0 9783 sub e_capture {
8438 637         2930  
8439             return join '', '${Einformixv6als::capture(', $_[0], ')}';
8440             return join '', '${', $_[0], '}';
8441             }
8442              
8443             #
8444             # escape transliteration (tr/// or y///)
8445 0     11 0 0 #
8446 11         60 sub e_tr {
8447 11   100     26 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8448             my $e_tr = '';
8449 11         32 $modifier ||= '';
8450              
8451             $slash = 'div';
8452 11         19  
8453             # quote character class 1
8454             $charclass = q_tr($charclass);
8455 11         26  
8456             # quote character class 2
8457             $charclass2 = q_tr($charclass2);
8458 11 50       24  
8459 11 0       31 # /b /B modifier
8460 0         0 if ($modifier =~ tr/bB//d) {
8461             if ($variable eq '') {
8462             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8463 0         0 }
8464             else {
8465             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8466             }
8467 0 100       0 }
8468 11         26 else {
8469             if ($variable eq '') {
8470             $e_tr = qq{Einformixv6als::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8471 2         6 }
8472             else {
8473             $e_tr = qq{Einformixv6als::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8474             }
8475             }
8476 9         32  
8477 11         15 # clear tr/// variable
8478             $tr_variable = '';
8479 11         16 $bind_operator = '';
8480              
8481             return $e_tr;
8482             }
8483              
8484             #
8485             # quote for escape transliteration (tr/// or y///)
8486 11     22 0 71 #
8487             sub q_tr {
8488             my($charclass) = @_;
8489 22 50       38  
    0          
    0          
    0          
    0          
    0          
8490 22         51 # quote character class
8491             if ($charclass !~ /'/oxms) {
8492             return e_q('', "'", "'", $charclass); # --> q' '
8493 22         35 }
8494             elsif ($charclass !~ /\//oxms) {
8495             return e_q('q', '/', '/', $charclass); # --> q/ /
8496 0         0 }
8497             elsif ($charclass !~ /\#/oxms) {
8498             return e_q('q', '#', '#', $charclass); # --> q# #
8499 0         0 }
8500             elsif ($charclass !~ /[\<\>]/oxms) {
8501             return e_q('q', '<', '>', $charclass); # --> q< >
8502 0         0 }
8503             elsif ($charclass !~ /[\(\)]/oxms) {
8504             return e_q('q', '(', ')', $charclass); # --> q( )
8505 0         0 }
8506             elsif ($charclass !~ /[\{\}]/oxms) {
8507             return e_q('q', '{', '}', $charclass); # --> q{ }
8508 0         0 }
8509 0 0       0 else {
8510 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8511             if ($charclass !~ /\Q$char\E/xms) {
8512             return e_q('q', $char, $char, $charclass);
8513             }
8514             }
8515 0         0 }
8516              
8517             return e_q('q', '{', '}', $charclass);
8518             }
8519              
8520             #
8521             # escape q string (q//, '')
8522 0     3967 0 0 #
8523             sub e_q {
8524 3967         11632 my($ope,$delimiter,$end_delimiter,$string) = @_;
8525              
8526 3967         6772 $slash = 'div';
8527 3967         31057  
8528             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8529             for (my $i=0; $i <= $#char; $i++) {
8530 3967 100 100     12145  
    100 100        
8531 21453         138411 # escape last octet of multiple-octet
8532             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8533             $char[$i] = $1 . '\\' . $2;
8534 1         5 }
8535             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8536             $char[$i] = $1 . '\\' . $2;
8537 22 100 100     106 }
8538 3967         16974 }
8539             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8540             $char[-1] = $1 . '\\' . $2;
8541 204         746 }
8542 3967         23953  
8543             return join '', $ope, $delimiter, @char, $end_delimiter;
8544             return join '', $ope, $delimiter, $string, $end_delimiter;
8545             }
8546              
8547             #
8548             # escape qq string (qq//, "", qx//, ``)
8549 0     9552 0 0 #
8550             sub e_qq {
8551 9552         24131 my($ope,$delimiter,$end_delimiter,$string) = @_;
8552              
8553 9552         15333 $slash = 'div';
8554 9552         13199  
8555             my $left_e = 0;
8556             my $right_e = 0;
8557 9552         12840  
8558             # split regexp
8559             my @char = $string =~ /\G((?>
8560             [^\x81-\x9F\xE0-\xFD\\\$]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
8561             \\x\{ (?>[0-9A-Fa-f]+) \} |
8562             \\o\{ (?>[0-7]+) \} |
8563             \\N\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
8564             \\ $q_char |
8565             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8566             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8567             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8568             \$ (?>\s* [0-9]+) |
8569             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8570             \$ \$ (?![\w\{]) |
8571             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8572             $q_char
8573 9552         400815 ))/oxmsg;
8574              
8575             for (my $i=0; $i <= $#char; $i++) {
8576 9552 50 66     32961  
    50 33        
    100          
    100          
    50          
8577 312224         1086909 # "\L\u" --> "\u\L"
8578             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8579             @char[$i,$i+1] = @char[$i+1,$i];
8580             }
8581              
8582 0         0 # "\U\l" --> "\l\U"
8583             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8584             @char[$i,$i+1] = @char[$i+1,$i];
8585             }
8586              
8587 0         0 # octal escape sequence
8588             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8589             $char[$i] = Einformixv6als::octchr($1);
8590             }
8591              
8592 1         4 # hexadecimal escape sequence
8593             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8594             $char[$i] = Einformixv6als::hexchr($1);
8595             }
8596              
8597 1         6 # \N{CHARNAME} --> N{CHARNAME}
8598             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
8599             $char[$i] = $1;
8600 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8601              
8602             if (0) {
8603             }
8604              
8605             # escape last octet of multiple-octet
8606 312224         3143568 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8607 0         0 # variable $delimiter and $end_delimiter can be ''
8608             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8609             $char[$i] = $1 . '\\' . $2;
8610             }
8611              
8612             # \F
8613             #
8614             # P.69 Table 2-6. Translation escapes
8615             # in Chapter 2: Bits and Pieces
8616             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8617             # (and so on)
8618              
8619 1342 50       4726 # \u \l \U \L \F \Q \E
8620 647         1924 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8621             if ($right_e < $left_e) {
8622             $char[$i] = '\\' . $char[$i];
8623             }
8624             }
8625             elsif ($char[$i] eq '\u') {
8626              
8627             # "STRING @{[ LIST EXPR ]} MORE STRING"
8628              
8629             # P.257 Other Tricks You Can Do with Hard References
8630             # in Chapter 8: References
8631             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8632              
8633             # P.353 Other Tricks You Can Do with Hard References
8634             # in Chapter 8: References
8635             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8636              
8637 0         0 # (and so on)
8638 0         0  
8639             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
8640             $left_e++;
8641 0         0 }
8642 0         0 elsif ($char[$i] eq '\l') {
8643             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
8644             $left_e++;
8645 0         0 }
8646 0         0 elsif ($char[$i] eq '\U') {
8647             $char[$i] = '@{[Einformixv6als::uc qq<';
8648             $left_e++;
8649 0         0 }
8650 6         7 elsif ($char[$i] eq '\L') {
8651             $char[$i] = '@{[Einformixv6als::lc qq<';
8652             $left_e++;
8653 6         12 }
8654 9         17 elsif ($char[$i] eq '\F') {
8655             $char[$i] = '@{[Einformixv6als::fc qq<';
8656             $left_e++;
8657 9         20 }
8658 0         0 elsif ($char[$i] eq '\Q') {
8659             $char[$i] = '@{[CORE::quotemeta qq<';
8660             $left_e++;
8661 0 50       0 }
8662 12         26 elsif ($char[$i] eq '\E') {
8663 12         13 if ($right_e < $left_e) {
8664             $char[$i] = '>]}';
8665             $right_e++;
8666 12         25 }
8667             else {
8668             $char[$i] = '';
8669             }
8670 0         0 }
8671 0 0       0 elsif ($char[$i] eq '\Q') {
8672 0         0 while (1) {
8673             if (++$i > $#char) {
8674 0 0       0 last;
8675 0         0 }
8676             if ($char[$i] eq '\E') {
8677             last;
8678             }
8679             }
8680             }
8681             elsif ($char[$i] eq '\E') {
8682             }
8683              
8684             # $0 --> $0
8685             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8686             }
8687             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8688             }
8689              
8690             # $$ --> $$
8691             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8692             }
8693              
8694             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8695 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8696             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8697             $char[$i] = e_capture($1);
8698 415         1341 }
8699             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8700             $char[$i] = e_capture($1);
8701             }
8702              
8703 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8704             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8705             $char[$i] = e_capture($1.'->'.$2);
8706             }
8707              
8708 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8709             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8710             $char[$i] = e_capture($1.'->'.$2);
8711             }
8712              
8713 0         0 # $$foo
8714             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8715             $char[$i] = e_capture($1);
8716             }
8717              
8718 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
8719             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8720             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
8721             }
8722              
8723 44         164 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
8724             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8725             $char[$i] = '@{[Einformixv6als::MATCH()]}';
8726             }
8727              
8728 45         146 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
8729             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8730             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
8731             }
8732              
8733             # ${ foo } --> ${ foo }
8734             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8735             }
8736              
8737 33         107 # ${ ... }
8738             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8739             $char[$i] = e_capture($1);
8740             }
8741             }
8742 0 100       0  
8743 9552         22417 # return string
8744             if ($left_e > $right_e) {
8745 3         19 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8746             }
8747             return join '', $ope, $delimiter, @char, $end_delimiter;
8748             }
8749              
8750             #
8751             # escape qw string (qw//)
8752 9549     34 0 85649 #
8753             sub e_qw {
8754 34         209 my($ope,$delimiter,$end_delimiter,$string) = @_;
8755              
8756             $slash = 'div';
8757 34         88  
  34         385  
8758 621 50       1285 # choice again delimiter
    0          
    0          
    0          
    0          
8759 34         217 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8760             if (not $octet{$end_delimiter}) {
8761             return join '', $ope, $delimiter, $string, $end_delimiter;
8762 34         325 }
8763             elsif (not $octet{')'}) {
8764             return join '', $ope, '(', $string, ')';
8765 0         0 }
8766             elsif (not $octet{'}'}) {
8767             return join '', $ope, '{', $string, '}';
8768 0         0 }
8769             elsif (not $octet{']'}) {
8770             return join '', $ope, '[', $string, ']';
8771 0         0 }
8772             elsif (not $octet{'>'}) {
8773             return join '', $ope, '<', $string, '>';
8774 0         0 }
8775 0 0       0 else {
8776 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8777             if (not $octet{$char}) {
8778             return join '', $ope, $char, $string, $char;
8779             }
8780             }
8781             }
8782 0         0  
8783 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8784 0         0 my @string = CORE::split(/\s+/, $string);
8785 0         0 for my $string (@string) {
8786 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8787 0         0 for my $octet (@octet) {
8788             if ($octet =~ /\A (['\\]) \z/oxms) {
8789             $octet = '\\' . $1;
8790 0         0 }
8791             }
8792 0         0 $string = join '', @octet;
  0         0  
8793             }
8794             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8795             }
8796              
8797             #
8798             # escape here document (<<"HEREDOC", <
8799 0     108 0 0 #
8800             sub e_heredoc {
8801 108         299 my($string) = @_;
8802              
8803 108         196 $slash = 'm//';
8804              
8805 108         377 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8806 108         185  
8807             my $left_e = 0;
8808             my $right_e = 0;
8809 108         159  
8810             # split regexp
8811             my @char = $string =~ /\G((?>
8812             [^\x81-\x9F\xE0-\xFD\\\$]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
8813             \\x\{ (?>[0-9A-Fa-f]+) \} |
8814             \\o\{ (?>[0-7]+) \} |
8815             \\N\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
8816             \\ $q_char |
8817             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8818             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8819             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8820             \$ (?>\s* [0-9]+) |
8821             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8822             \$ \$ (?![\w\{]) |
8823             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8824             $q_char
8825 108         12929 ))/oxmsg;
8826              
8827             for (my $i=0; $i <= $#char; $i++) {
8828 108 50 66     582  
    50 33        
    100          
    100          
    50          
8829 3459         11047 # "\L\u" --> "\u\L"
8830             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8831             @char[$i,$i+1] = @char[$i+1,$i];
8832             }
8833              
8834 0         0 # "\U\l" --> "\l\U"
8835             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8836             @char[$i,$i+1] = @char[$i+1,$i];
8837             }
8838              
8839 0         0 # octal escape sequence
8840             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8841             $char[$i] = Einformixv6als::octchr($1);
8842             }
8843              
8844 1         4 # hexadecimal escape sequence
8845             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8846             $char[$i] = Einformixv6als::hexchr($1);
8847             }
8848              
8849 1         3 # \N{CHARNAME} --> N{CHARNAME}
8850             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
8851             $char[$i] = $1;
8852 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8853              
8854             if (0) {
8855             }
8856 3459         31146  
8857 0         0 # escape character
8858             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8859             $char[$i] = $1 . '\\' . $2;
8860             }
8861              
8862 57 50       223 # \u \l \U \L \F \Q \E
8863 72         161 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8864             if ($right_e < $left_e) {
8865             $char[$i] = '\\' . $char[$i];
8866             }
8867 0         0 }
8868 0         0 elsif ($char[$i] eq '\u') {
8869             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
8870             $left_e++;
8871 0         0 }
8872 0         0 elsif ($char[$i] eq '\l') {
8873             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
8874             $left_e++;
8875 0         0 }
8876 0         0 elsif ($char[$i] eq '\U') {
8877             $char[$i] = '@{[Einformixv6als::uc qq<';
8878             $left_e++;
8879 0         0 }
8880 6         9 elsif ($char[$i] eq '\L') {
8881             $char[$i] = '@{[Einformixv6als::lc qq<';
8882             $left_e++;
8883 6         11 }
8884 0         0 elsif ($char[$i] eq '\F') {
8885             $char[$i] = '@{[Einformixv6als::fc qq<';
8886             $left_e++;
8887 0         0 }
8888 0         0 elsif ($char[$i] eq '\Q') {
8889             $char[$i] = '@{[CORE::quotemeta qq<';
8890             $left_e++;
8891 0 50       0 }
8892 3         7 elsif ($char[$i] eq '\E') {
8893 3         5 if ($right_e < $left_e) {
8894             $char[$i] = '>]}';
8895             $right_e++;
8896 3         5 }
8897             else {
8898             $char[$i] = '';
8899             }
8900 0         0 }
8901 0 0       0 elsif ($char[$i] eq '\Q') {
8902 0         0 while (1) {
8903             if (++$i > $#char) {
8904 0 0       0 last;
8905 0         0 }
8906             if ($char[$i] eq '\E') {
8907             last;
8908             }
8909             }
8910             }
8911             elsif ($char[$i] eq '\E') {
8912             }
8913              
8914             # $0 --> $0
8915             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8916             }
8917             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8918             }
8919              
8920             # $$ --> $$
8921             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8922             }
8923              
8924             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8925 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8926             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8927             $char[$i] = e_capture($1);
8928 0         0 }
8929             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8930             $char[$i] = e_capture($1);
8931             }
8932              
8933 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8934             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8935             $char[$i] = e_capture($1.'->'.$2);
8936             }
8937              
8938 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8939             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8940             $char[$i] = e_capture($1.'->'.$2);
8941             }
8942              
8943 0         0 # $$foo
8944             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8945             $char[$i] = e_capture($1);
8946             }
8947              
8948 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
8949             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8950             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
8951             }
8952              
8953 8         54 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
8954             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8955             $char[$i] = '@{[Einformixv6als::MATCH()]}';
8956             }
8957              
8958 8         50 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
8959             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8960             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
8961             }
8962              
8963             # ${ foo } --> ${ foo }
8964             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8965             }
8966              
8967 6         36 # ${ ... }
8968             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8969             $char[$i] = e_capture($1);
8970             }
8971             }
8972 0 100       0  
8973 108         307 # return string
8974             if ($left_e > $right_e) {
8975 3         21 return join '', @char, '>]}' x ($left_e - $right_e);
8976             }
8977             return join '', @char;
8978             }
8979              
8980             #
8981             # escape regexp (m//, qr//)
8982 105     1835 0 838 #
8983 1835   100     8338 sub e_qr {
8984             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8985 1835         6964 $modifier ||= '';
8986 1835 50       3686  
8987 1835         4979 $modifier =~ tr/p//d;
8988 0         0 if ($modifier =~ /([adlu])/oxms) {
8989 0 0       0 my $line = 0;
8990 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8991 0         0 if ($filename ne __FILE__) {
8992             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8993             last;
8994 0         0 }
8995             }
8996             die qq{Unsupported modifier "$1" used at line $line.\n};
8997 0         0 }
8998              
8999             $slash = 'div';
9000 1835 100       3219  
    100          
9001 1835         5496 # literal null string pattern
9002 8         13 if ($string eq '') {
9003 8         16 $modifier =~ tr/bB//d;
9004             $modifier =~ tr/i//d;
9005             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9006             }
9007              
9008             # /b /B modifier
9009             elsif ($modifier =~ tr/bB//d) {
9010 8 50       47  
9011 240         634 # choice again delimiter
9012 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9013 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9014 0         0 my %octet = map {$_ => 1} @char;
9015 0         0 if (not $octet{')'}) {
9016             $delimiter = '(';
9017             $end_delimiter = ')';
9018 0         0 }
9019 0         0 elsif (not $octet{'}'}) {
9020             $delimiter = '{';
9021             $end_delimiter = '}';
9022 0         0 }
9023 0         0 elsif (not $octet{']'}) {
9024             $delimiter = '[';
9025             $end_delimiter = ']';
9026 0         0 }
9027 0         0 elsif (not $octet{'>'}) {
9028             $delimiter = '<';
9029             $end_delimiter = '>';
9030 0         0 }
9031 0 0       0 else {
9032 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9033 0         0 if (not $octet{$char}) {
9034 0         0 $delimiter = $char;
9035             $end_delimiter = $char;
9036             last;
9037             }
9038             }
9039             }
9040 0 100 100     0 }
9041 240         1168  
9042             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9043             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9044 90         524 }
9045             else {
9046             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9047             }
9048 150 100       965 }
9049 1587         3977  
9050             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9051             my $metachar = qr/[\@\\|[\]{^]/oxms;
9052 1587         6092  
9053             # split regexp
9054             my @char = $string =~ /\G((?>
9055             [^\x81-\x9F\xE0-\xFD\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
9056             \\x (?>[0-9A-Fa-f]{1,2}) |
9057             \\ (?>[0-7]{2,3}) |
9058             \\c [\x40-\x5F] |
9059             \\x\{ (?>[0-9A-Fa-f]+) \} |
9060             \\o\{ (?>[0-7]+) \} |
9061             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
9062             \\ $q_char |
9063             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9064             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9065             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9066             [\$\@] $qq_variable |
9067             \$ (?>\s* [0-9]+) |
9068             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9069             \$ \$ (?![\w\{]) |
9070             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9071             \[\^ |
9072             \[\: (?>[a-z]+) :\] |
9073             \[\:\^ (?>[a-z]+) :\] |
9074             \(\? |
9075             $q_char
9076             ))/oxmsg;
9077 1587 50       162587  
9078 1587         7955 # choice again delimiter
  0         0  
9079 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9080 0         0 my %octet = map {$_ => 1} @char;
9081 0         0 if (not $octet{')'}) {
9082             $delimiter = '(';
9083             $end_delimiter = ')';
9084 0         0 }
9085 0         0 elsif (not $octet{'}'}) {
9086             $delimiter = '{';
9087             $end_delimiter = '}';
9088 0         0 }
9089 0         0 elsif (not $octet{']'}) {
9090             $delimiter = '[';
9091             $end_delimiter = ']';
9092 0         0 }
9093 0         0 elsif (not $octet{'>'}) {
9094             $delimiter = '<';
9095             $end_delimiter = '>';
9096 0         0 }
9097 0 0       0 else {
9098 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9099 0         0 if (not $octet{$char}) {
9100 0         0 $delimiter = $char;
9101             $end_delimiter = $char;
9102             last;
9103             }
9104             }
9105             }
9106 0         0 }
9107 1587         2672  
9108 1587         2409 my $left_e = 0;
9109             my $right_e = 0;
9110             for (my $i=0; $i <= $#char; $i++) {
9111 1587 50 66     4241  
    50 66        
    100          
    100          
    100          
    100          
9112 5422         29141 # "\L\u" --> "\u\L"
9113             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9114             @char[$i,$i+1] = @char[$i+1,$i];
9115             }
9116              
9117 0         0 # "\U\l" --> "\l\U"
9118             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9119             @char[$i,$i+1] = @char[$i+1,$i];
9120             }
9121              
9122 0         0 # octal escape sequence
9123             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9124             $char[$i] = Einformixv6als::octchr($1);
9125             }
9126              
9127 1         5 # hexadecimal escape sequence
9128             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9129             $char[$i] = Einformixv6als::hexchr($1);
9130             }
9131              
9132             # \b{...} --> b\{...}
9133             # \B{...} --> B\{...}
9134             # \N{CHARNAME} --> N\{CHARNAME}
9135             # \p{PROPERTY} --> p\{PROPERTY}
9136 1         9 # \P{PROPERTY} --> P\{PROPERTY}
9137             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
9138             $char[$i] = $1 . '\\' . $2;
9139             }
9140              
9141 6         24 # \p, \P, \X --> p, P, X
9142             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9143             $char[$i] = $1;
9144 4 100 100     13 }
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9145              
9146             if (0) {
9147             }
9148 5422         38443  
9149 0         0 # escape last octet of multiple-octet
9150             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9151             $char[$i] = $1 . '\\' . $2;
9152             }
9153              
9154 77 50 33     354 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9155 6         146 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9156             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
9157             $char[$i] .= join '', splice @char, $i+1, 3;
9158 0         0 }
9159             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
9160             $char[$i] .= join '', splice @char, $i+1, 2;
9161 0         0 }
9162             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
9163             $char[$i] .= join '', splice @char, $i+1, 1;
9164             }
9165             }
9166              
9167 0         0 # open character class [...]
9168             elsif ($char[$i] eq '[') {
9169             my $left = $i;
9170              
9171             # [] make die "Unmatched [] in regexp ...\n"
9172 586 100       1001 # (and so on)
9173 586         1691  
9174             if ($char[$i+1] eq ']') {
9175             $i++;
9176 3         8 }
9177 586 50       854  
9178 2583         4280 while (1) {
9179             if (++$i > $#char) {
9180 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9181 2583         4559 }
9182             if ($char[$i] eq ']') {
9183             my $right = $i;
9184 586 100       838  
9185 586         3242 # [...]
  90         247  
9186             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9187             splice @char, $left, $right-$left+1, sprintf(q{@{[Einformixv6als::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9188 270         585 }
9189             else {
9190             splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
9191 496         1826 }
9192 586         1289  
9193             $i = $left;
9194             last;
9195             }
9196             }
9197             }
9198              
9199 586         1791 # open character class [^...]
9200             elsif ($char[$i] eq '[^') {
9201             my $left = $i;
9202              
9203             # [^] make die "Unmatched [] in regexp ...\n"
9204 328 100       562 # (and so on)
9205 328         861  
9206             if ($char[$i+1] eq ']') {
9207             $i++;
9208 5         11 }
9209 328 50       504  
9210 1447         2502 while (1) {
9211             if (++$i > $#char) {
9212 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9213 1447         2633 }
9214             if ($char[$i] eq ']') {
9215             my $right = $i;
9216 328 100       487  
9217 328         2129 # [^...]
  90         233  
9218             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9219             splice @char, $left, $right-$left+1, sprintf(q{@{[Einformixv6als::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9220 270         657 }
9221             else {
9222             splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9223 238         859 }
9224 328         709  
9225             $i = $left;
9226             last;
9227             }
9228             }
9229             }
9230              
9231 328         1058 # rewrite character class or escape character
9232             elsif (my $char = character_class($char[$i],$modifier)) {
9233             $char[$i] = $char;
9234             }
9235              
9236 215 50       638 # /i modifier
9237 238         510 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
9238             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
9239             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
9240 238         521 }
9241             else {
9242             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
9243             }
9244             }
9245              
9246 0 50       0 # \u \l \U \L \F \Q \E
9247 1         6 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9248             if ($right_e < $left_e) {
9249             $char[$i] = '\\' . $char[$i];
9250             }
9251 0         0 }
9252 0         0 elsif ($char[$i] eq '\u') {
9253             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
9254             $left_e++;
9255 0         0 }
9256 0         0 elsif ($char[$i] eq '\l') {
9257             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
9258             $left_e++;
9259 0         0 }
9260 1         3 elsif ($char[$i] eq '\U') {
9261             $char[$i] = '@{[Einformixv6als::uc qq<';
9262             $left_e++;
9263 1         5 }
9264 1         3 elsif ($char[$i] eq '\L') {
9265             $char[$i] = '@{[Einformixv6als::lc qq<';
9266             $left_e++;
9267 1         4 }
9268 9         24 elsif ($char[$i] eq '\F') {
9269             $char[$i] = '@{[Einformixv6als::fc qq<';
9270             $left_e++;
9271 9         22 }
9272 22         54 elsif ($char[$i] eq '\Q') {
9273             $char[$i] = '@{[CORE::quotemeta qq<';
9274             $left_e++;
9275 22 50       52 }
9276 33         75 elsif ($char[$i] eq '\E') {
9277 33         52 if ($right_e < $left_e) {
9278             $char[$i] = '>]}';
9279             $right_e++;
9280 33         73 }
9281             else {
9282             $char[$i] = '';
9283             }
9284 0         0 }
9285 0 0       0 elsif ($char[$i] eq '\Q') {
9286 0         0 while (1) {
9287             if (++$i > $#char) {
9288 0 0       0 last;
9289 0         0 }
9290             if ($char[$i] eq '\E') {
9291             last;
9292             }
9293             }
9294             }
9295             elsif ($char[$i] eq '\E') {
9296             }
9297              
9298 0 0       0 # $0 --> $0
9299 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9300             if ($ignorecase) {
9301             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9302             }
9303 0 0       0 }
9304 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9305             if ($ignorecase) {
9306             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9307             }
9308             }
9309              
9310             # $$ --> $$
9311             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9312             }
9313              
9314             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9315 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9316 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9317 0         0 $char[$i] = e_capture($1);
9318             if ($ignorecase) {
9319             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9320             }
9321 0         0 }
9322 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9323 0         0 $char[$i] = e_capture($1);
9324             if ($ignorecase) {
9325             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9326             }
9327             }
9328              
9329 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9330 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
9331 0         0 $char[$i] = e_capture($1.'->'.$2);
9332             if ($ignorecase) {
9333             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9334             }
9335             }
9336              
9337 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9338 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
9339 0         0 $char[$i] = e_capture($1.'->'.$2);
9340             if ($ignorecase) {
9341             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9342             }
9343             }
9344              
9345 0         0 # $$foo
9346 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9347 0         0 $char[$i] = e_capture($1);
9348             if ($ignorecase) {
9349             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9350             }
9351             }
9352              
9353 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
9354 8         29 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9355             if ($ignorecase) {
9356             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::PREMATCH())]}';
9357 0         0 }
9358             else {
9359             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
9360             }
9361             }
9362              
9363 8 50       28 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
9364 8         21 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9365             if ($ignorecase) {
9366             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::MATCH())]}';
9367 0         0 }
9368             else {
9369             $char[$i] = '@{[Einformixv6als::MATCH()]}';
9370             }
9371             }
9372              
9373 8 50       29 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
9374 6         18 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9375             if ($ignorecase) {
9376             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::POSTMATCH())]}';
9377 0         0 }
9378             else {
9379             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
9380             }
9381             }
9382              
9383 6 0       22 # ${ foo }
9384 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
9385             if ($ignorecase) {
9386             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9387             }
9388             }
9389              
9390 0         0 # ${ ... }
9391 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9392 0         0 $char[$i] = e_capture($1);
9393             if ($ignorecase) {
9394             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9395             }
9396             }
9397              
9398 0         0 # $scalar or @array
9399 31 100       138 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9400 31         118 $char[$i] = e_string($char[$i]);
9401             if ($ignorecase) {
9402             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9403             }
9404             }
9405              
9406 4 100 66     17 # quote character before ? + * {
    50          
9407             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9408             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9409 188         2068 }
9410 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9411 0         0 my $char = $char[$i-1];
9412             if ($char[$i] eq '{') {
9413             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9414 0         0 }
9415             else {
9416             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9417             }
9418 0         0 }
9419             else {
9420             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9421             }
9422             }
9423             }
9424 187         863  
9425 1587 50       3359 # make regexp string
9426 1587 0 0     4235 $modifier =~ tr/i//d;
9427 0         0 if ($left_e > $right_e) {
9428             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9429             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9430 0         0 }
9431             else {
9432             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9433 0 100 100     0 }
9434 1587         9253 }
9435             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9436             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9437 94         919 }
9438             else {
9439             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9440             }
9441             }
9442              
9443             #
9444             # double quote stuff
9445 1493     540 0 14233 #
9446             sub qq_stuff {
9447             my($delimiter,$end_delimiter,$stuff) = @_;
9448 540 100       1221  
9449 540         1301 # scalar variable or array variable
9450             if ($stuff =~ /\A [\$\@] /oxms) {
9451             return $stuff;
9452             }
9453 300         1301  
  240         669  
9454 280         860 # quote by delimiter
9455 240 50       693 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9456 240 50       469 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9457 240 50       436 next if $char eq $delimiter;
9458 240         517 next if $char eq $end_delimiter;
9459             if (not $octet{$char}) {
9460             return join '', 'qq', $char, $stuff, $char;
9461 240         1066 }
9462             }
9463             return join '', 'qq', '<', $stuff, '>';
9464             }
9465              
9466             #
9467             # escape regexp (m'', qr'', and m''b, qr''b)
9468 0     163 0 0 #
9469 163   100     779 sub e_qr_q {
9470             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9471 163         549 $modifier ||= '';
9472 163 50       417  
9473 163         391 $modifier =~ tr/p//d;
9474 0         0 if ($modifier =~ /([adlu])/oxms) {
9475 0 0       0 my $line = 0;
9476 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9477 0         0 if ($filename ne __FILE__) {
9478             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9479             last;
9480 0         0 }
9481             }
9482             die qq{Unsupported modifier "$1" used at line $line.\n};
9483 0         0 }
9484              
9485             $slash = 'div';
9486 163 100       280  
    100          
9487 163         431 # literal null string pattern
9488 8         13 if ($string eq '') {
9489 8         12 $modifier =~ tr/bB//d;
9490             $modifier =~ tr/i//d;
9491             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9492             }
9493              
9494 8         62 # with /b /B modifier
9495             elsif ($modifier =~ tr/bB//d) {
9496             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9497             }
9498              
9499 89         251 # without /b /B modifier
9500             else {
9501             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9502             }
9503             }
9504              
9505             #
9506             # escape regexp (m'', qr'')
9507 66     66 0 157 #
9508             sub e_qr_qt {
9509 66 100       160 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9510              
9511             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9512 66         183  
9513             # split regexp
9514             my @char = $string =~ /\G((?>
9515             [^\x81-\x9F\xE0-\xFD\\\[\$\@\/] |
9516             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
9517             \[\^ |
9518             \[\: (?>[a-z]+) \:\] |
9519             \[\:\^ (?>[a-z]+) \:\] |
9520             [\$\@\/] |
9521             \\ (?:$q_char) |
9522             (?:$q_char)
9523             ))/oxmsg;
9524 66         829  
9525 66 100 100     214 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9526             for (my $i=0; $i <= $#char; $i++) {
9527             if (0) {
9528             }
9529 79         811  
9530 0         0 # escape last octet of multiple-octet
9531             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9532             $char[$i] = $1 . '\\' . $2;
9533             }
9534              
9535 2         21 # open character class [...]
9536 0 0       0 elsif ($char[$i] eq '[') {
9537 0         0 my $left = $i;
9538             if ($char[$i+1] eq ']') {
9539 0         0 $i++;
9540 0 0       0 }
9541 0         0 while (1) {
9542             if (++$i > $#char) {
9543 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9544 0         0 }
9545             if ($char[$i] eq ']') {
9546             my $right = $i;
9547 0         0  
9548             # [...]
9549 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
9550 0         0  
9551             $i = $left;
9552             last;
9553             }
9554             }
9555             }
9556              
9557 0         0 # open character class [^...]
9558 0 0       0 elsif ($char[$i] eq '[^') {
9559 0         0 my $left = $i;
9560             if ($char[$i+1] eq ']') {
9561 0         0 $i++;
9562 0 0       0 }
9563 0         0 while (1) {
9564             if (++$i > $#char) {
9565 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9566 0         0 }
9567             if ($char[$i] eq ']') {
9568             my $right = $i;
9569 0         0  
9570             # [^...]
9571 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9572 0         0  
9573             $i = $left;
9574             last;
9575             }
9576             }
9577             }
9578              
9579 0         0 # escape $ @ / and \
9580             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9581             $char[$i] = '\\' . $char[$i];
9582             }
9583              
9584 0         0 # rewrite character class or escape character
9585             elsif (my $char = character_class($char[$i],$modifier)) {
9586             $char[$i] = $char;
9587             }
9588              
9589 0 50       0 # /i modifier
9590 16         43 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
9591             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
9592             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
9593 16         45 }
9594             else {
9595             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
9596             }
9597             }
9598              
9599 0 0       0 # quote character before ? + * {
9600             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9601             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9602 0         0 }
9603             else {
9604             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9605             }
9606             }
9607 0         0 }
9608 66         172  
9609             $delimiter = '/';
9610 66         88 $end_delimiter = '/';
9611 66         115  
9612             $modifier =~ tr/i//d;
9613             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9614             }
9615              
9616             #
9617             # escape regexp (m''b, qr''b)
9618 66     89 0 515 #
9619             sub e_qr_qb {
9620             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9621 89         207  
9622             # split regexp
9623             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9624 89         412  
9625 89 50       256 # unescape character
    50          
9626             for (my $i=0; $i <= $#char; $i++) {
9627             if (0) {
9628             }
9629 199         638  
9630             # remain \\
9631             elsif ($char[$i] eq '\\\\') {
9632             }
9633              
9634 0         0 # escape $ @ / and \
9635             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9636             $char[$i] = '\\' . $char[$i];
9637             }
9638 0         0 }
9639 89         144  
9640 89         122 $delimiter = '/';
9641             $end_delimiter = '/';
9642             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9643             }
9644              
9645             #
9646             # escape regexp (s/here//)
9647 89     194 0 563 #
9648 194   100     698 sub e_s1 {
9649             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9650 194         701 $modifier ||= '';
9651 194 50       352  
9652 194         742 $modifier =~ tr/p//d;
9653 0         0 if ($modifier =~ /([adlu])/oxms) {
9654 0 0       0 my $line = 0;
9655 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9656 0         0 if ($filename ne __FILE__) {
9657             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9658             last;
9659 0         0 }
9660             }
9661             die qq{Unsupported modifier "$1" used at line $line.\n};
9662 0         0 }
9663              
9664             $slash = 'div';
9665 194 100       463  
    100          
9666 194         753 # literal null string pattern
9667 8         10 if ($string eq '') {
9668 8         16 $modifier =~ tr/bB//d;
9669             $modifier =~ tr/i//d;
9670             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9671             }
9672              
9673             # /b /B modifier
9674             elsif ($modifier =~ tr/bB//d) {
9675 8 50       57  
9676 44         96 # choice again delimiter
9677 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9678 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9679 0         0 my %octet = map {$_ => 1} @char;
9680 0         0 if (not $octet{')'}) {
9681             $delimiter = '(';
9682             $end_delimiter = ')';
9683 0         0 }
9684 0         0 elsif (not $octet{'}'}) {
9685             $delimiter = '{';
9686             $end_delimiter = '}';
9687 0         0 }
9688 0         0 elsif (not $octet{']'}) {
9689             $delimiter = '[';
9690             $end_delimiter = ']';
9691 0         0 }
9692 0         0 elsif (not $octet{'>'}) {
9693             $delimiter = '<';
9694             $end_delimiter = '>';
9695 0         0 }
9696 0 0       0 else {
9697 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9698 0         0 if (not $octet{$char}) {
9699 0         0 $delimiter = $char;
9700             $end_delimiter = $char;
9701             last;
9702             }
9703             }
9704             }
9705 0         0 }
9706 44         61  
9707 44         66 my $prematch = '';
9708             $prematch = q{(\G[\x00-\xFF]*?)};
9709             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9710 44 100       311 }
9711 142         440  
9712             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9713             my $metachar = qr/[\@\\|[\]{^]/oxms;
9714 142         595  
9715             # split regexp
9716             my @char = $string =~ /\G((?>
9717             [^\x81-\x9F\xE0-\xFD\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
9718             \\ (?>[1-9][0-9]*) |
9719             \\g (?>\s*) (?>[1-9][0-9]*) |
9720             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9721             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9722             \\x (?>[0-9A-Fa-f]{1,2}) |
9723             \\ (?>[0-7]{2,3}) |
9724             \\c [\x40-\x5F] |
9725             \\x\{ (?>[0-9A-Fa-f]+) \} |
9726             \\o\{ (?>[0-7]+) \} |
9727             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
9728             \\ $q_char |
9729             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9730             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9731             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9732             [\$\@] $qq_variable |
9733             \$ (?>\s* [0-9]+) |
9734             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9735             \$ \$ (?![\w\{]) |
9736             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9737             \[\^ |
9738             \[\: (?>[a-z]+) :\] |
9739             \[\:\^ (?>[a-z]+) :\] |
9740             \(\? |
9741             $q_char
9742             ))/oxmsg;
9743 142 50       44665  
9744 142         1432 # choice again delimiter
  0         0  
9745 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9746 0         0 my %octet = map {$_ => 1} @char;
9747 0         0 if (not $octet{')'}) {
9748             $delimiter = '(';
9749             $end_delimiter = ')';
9750 0         0 }
9751 0         0 elsif (not $octet{'}'}) {
9752             $delimiter = '{';
9753             $end_delimiter = '}';
9754 0         0 }
9755 0         0 elsif (not $octet{']'}) {
9756             $delimiter = '[';
9757             $end_delimiter = ']';
9758 0         0 }
9759 0         0 elsif (not $octet{'>'}) {
9760             $delimiter = '<';
9761             $end_delimiter = '>';
9762 0         0 }
9763 0 0       0 else {
9764 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9765 0         0 if (not $octet{$char}) {
9766 0         0 $delimiter = $char;
9767             $end_delimiter = $char;
9768             last;
9769             }
9770             }
9771             }
9772             }
9773 0         0  
  142         385  
9774             # count '('
9775 476         1064 my $parens = grep { $_ eq '(' } @char;
9776 142         256  
9777 142         294 my $left_e = 0;
9778             my $right_e = 0;
9779             for (my $i=0; $i <= $#char; $i++) {
9780 142 50 33     522  
    50 33        
    100          
    100          
    50          
    50          
9781 397         3112 # "\L\u" --> "\u\L"
9782             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9783             @char[$i,$i+1] = @char[$i+1,$i];
9784             }
9785              
9786 0         0 # "\U\l" --> "\l\U"
9787             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9788             @char[$i,$i+1] = @char[$i+1,$i];
9789             }
9790              
9791 0         0 # octal escape sequence
9792             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9793             $char[$i] = Einformixv6als::octchr($1);
9794             }
9795              
9796 1         5 # hexadecimal escape sequence
9797             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9798             $char[$i] = Einformixv6als::hexchr($1);
9799             }
9800              
9801             # \b{...} --> b\{...}
9802             # \B{...} --> B\{...}
9803             # \N{CHARNAME} --> N\{CHARNAME}
9804             # \p{PROPERTY} --> p\{PROPERTY}
9805 1         6 # \P{PROPERTY} --> P\{PROPERTY}
9806             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
9807             $char[$i] = $1 . '\\' . $2;
9808             }
9809              
9810 0         0 # \p, \P, \X --> p, P, X
9811             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9812             $char[$i] = $1;
9813 0 100 100     0 }
    50 100        
    100 100        
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9814              
9815             if (0) {
9816             }
9817 397         5010  
9818 0         0 # escape last octet of multiple-octet
9819             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9820             $char[$i] = $1 . '\\' . $2;
9821             }
9822              
9823 23 0 0     148 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9824 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9825             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
9826             $char[$i] .= join '', splice @char, $i+1, 3;
9827 0         0 }
9828             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
9829             $char[$i] .= join '', splice @char, $i+1, 2;
9830 0         0 }
9831             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
9832             $char[$i] .= join '', splice @char, $i+1, 1;
9833             }
9834             }
9835              
9836 0         0 # open character class [...]
9837 20 50       48 elsif ($char[$i] eq '[') {
9838 20         70 my $left = $i;
9839             if ($char[$i+1] eq ']') {
9840 0         0 $i++;
9841 20 50       38 }
9842 79         147 while (1) {
9843             if (++$i > $#char) {
9844 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9845 79         272 }
9846             if ($char[$i] eq ']') {
9847             my $right = $i;
9848 20 50       59  
9849 20         196 # [...]
  0         0  
9850             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9851             splice @char, $left, $right-$left+1, sprintf(q{@{[Einformixv6als::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9852 0         0 }
9853             else {
9854             splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
9855 20         119 }
9856 20         51  
9857             $i = $left;
9858             last;
9859             }
9860             }
9861             }
9862              
9863 20         77 # open character class [^...]
9864 0 0       0 elsif ($char[$i] eq '[^') {
9865 0         0 my $left = $i;
9866             if ($char[$i+1] eq ']') {
9867 0         0 $i++;
9868 0 0       0 }
9869 0         0 while (1) {
9870             if (++$i > $#char) {
9871 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9872 0         0 }
9873             if ($char[$i] eq ']') {
9874             my $right = $i;
9875 0 0       0  
9876 0         0 # [^...]
  0         0  
9877             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9878             splice @char, $left, $right-$left+1, sprintf(q{@{[Einformixv6als::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9879 0         0 }
9880             else {
9881             splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9882 0         0 }
9883 0         0  
9884             $i = $left;
9885             last;
9886             }
9887             }
9888             }
9889              
9890 0         0 # rewrite character class or escape character
9891             elsif (my $char = character_class($char[$i],$modifier)) {
9892             $char[$i] = $char;
9893             }
9894              
9895 11 50       29 # /i modifier
9896 11         25 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
9897             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
9898             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
9899 11         23 }
9900             else {
9901             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
9902             }
9903             }
9904              
9905 0 50       0 # \u \l \U \L \F \Q \E
9906 8         28 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9907             if ($right_e < $left_e) {
9908             $char[$i] = '\\' . $char[$i];
9909             }
9910 0         0 }
9911 0         0 elsif ($char[$i] eq '\u') {
9912             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
9913             $left_e++;
9914 0         0 }
9915 0         0 elsif ($char[$i] eq '\l') {
9916             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
9917             $left_e++;
9918 0         0 }
9919 0         0 elsif ($char[$i] eq '\U') {
9920             $char[$i] = '@{[Einformixv6als::uc qq<';
9921             $left_e++;
9922 0         0 }
9923 0         0 elsif ($char[$i] eq '\L') {
9924             $char[$i] = '@{[Einformixv6als::lc qq<';
9925             $left_e++;
9926 0         0 }
9927 0         0 elsif ($char[$i] eq '\F') {
9928             $char[$i] = '@{[Einformixv6als::fc qq<';
9929             $left_e++;
9930 0         0 }
9931 7         14 elsif ($char[$i] eq '\Q') {
9932             $char[$i] = '@{[CORE::quotemeta qq<';
9933             $left_e++;
9934 7 50       17 }
9935 7         16 elsif ($char[$i] eq '\E') {
9936 7         12 if ($right_e < $left_e) {
9937             $char[$i] = '>]}';
9938             $right_e++;
9939 7         18 }
9940             else {
9941             $char[$i] = '';
9942             }
9943 0         0 }
9944 0 0       0 elsif ($char[$i] eq '\Q') {
9945 0         0 while (1) {
9946             if (++$i > $#char) {
9947 0 0       0 last;
9948 0         0 }
9949             if ($char[$i] eq '\E') {
9950             last;
9951             }
9952             }
9953             }
9954             elsif ($char[$i] eq '\E') {
9955             }
9956              
9957             # \0 --> \0
9958             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9959             }
9960              
9961             # \g{N}, \g{-N}
9962              
9963             # P.108 Using Simple Patterns
9964             # in Chapter 7: In the World of Regular Expressions
9965             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9966              
9967             # P.221 Capturing
9968             # in Chapter 5: Pattern Matching
9969             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9970              
9971             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9972             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9973             }
9974              
9975 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9976 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9977             if ($1 <= $parens) {
9978             $char[$i] = '\\g{' . ($1 + 1) . '}';
9979             }
9980             }
9981              
9982 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9983 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9984             if ($1 <= $parens) {
9985             $char[$i] = '\\g' . ($1 + 1);
9986             }
9987             }
9988              
9989 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9990 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9991             if ($1 <= $parens) {
9992             $char[$i] = '\\' . ($1 + 1);
9993             }
9994             }
9995              
9996 0 0       0 # $0 --> $0
9997 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9998             if ($ignorecase) {
9999             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10000             }
10001 0 0       0 }
10002 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10003             if ($ignorecase) {
10004             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10005             }
10006             }
10007              
10008             # $$ --> $$
10009             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10010             }
10011              
10012             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10013 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10014 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10015 0         0 $char[$i] = e_capture($1);
10016             if ($ignorecase) {
10017             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10018             }
10019 0         0 }
10020 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10021 0         0 $char[$i] = e_capture($1);
10022             if ($ignorecase) {
10023             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10024             }
10025             }
10026              
10027 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10028 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10029 0         0 $char[$i] = e_capture($1.'->'.$2);
10030             if ($ignorecase) {
10031             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10032             }
10033             }
10034              
10035 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10036 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10037 0         0 $char[$i] = e_capture($1.'->'.$2);
10038             if ($ignorecase) {
10039             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10040             }
10041             }
10042              
10043 0         0 # $$foo
10044 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10045 0         0 $char[$i] = e_capture($1);
10046             if ($ignorecase) {
10047             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10048             }
10049             }
10050              
10051 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
10052 4         17 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10053             if ($ignorecase) {
10054             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::PREMATCH())]}';
10055 0         0 }
10056             else {
10057             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
10058             }
10059             }
10060              
10061 4 50       20 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
10062 4         18 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10063             if ($ignorecase) {
10064             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::MATCH())]}';
10065 0         0 }
10066             else {
10067             $char[$i] = '@{[Einformixv6als::MATCH()]}';
10068             }
10069             }
10070              
10071 4 50       19 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
10072 3         13 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10073             if ($ignorecase) {
10074             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::POSTMATCH())]}';
10075 0         0 }
10076             else {
10077             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
10078             }
10079             }
10080              
10081 3 0       13 # ${ foo }
10082 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10083             if ($ignorecase) {
10084             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10085             }
10086             }
10087              
10088 0         0 # ${ ... }
10089 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10090 0         0 $char[$i] = e_capture($1);
10091             if ($ignorecase) {
10092             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10093             }
10094             }
10095              
10096 0         0 # $scalar or @array
10097 13 50       50 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10098 13         70 $char[$i] = e_string($char[$i]);
10099             if ($ignorecase) {
10100             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10101             }
10102             }
10103              
10104 0 50       0 # quote character before ? + * {
10105             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10106             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10107 23         141 }
10108             else {
10109             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10110             }
10111             }
10112             }
10113 23         134  
10114 142         392 # make regexp string
10115 142         406 my $prematch = '';
10116 142 50       287 $prematch = "($anchor)";
10117 142         397 $modifier =~ tr/i//d;
10118             if ($left_e > $right_e) {
10119 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10120             }
10121             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10122             }
10123              
10124             #
10125             # escape regexp (s'here'' or s'here''b)
10126 142     96 0 1942 #
10127 96   100     240 sub e_s1_q {
10128             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10129 96         259 $modifier ||= '';
10130 96 50       247  
10131 96         248 $modifier =~ tr/p//d;
10132 0         0 if ($modifier =~ /([adlu])/oxms) {
10133 0 0       0 my $line = 0;
10134 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10135 0         0 if ($filename ne __FILE__) {
10136             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10137             last;
10138 0         0 }
10139             }
10140             die qq{Unsupported modifier "$1" used at line $line.\n};
10141 0         0 }
10142              
10143             $slash = 'div';
10144 96 100       159  
    100          
10145 96         246 # literal null string pattern
10146 8         14 if ($string eq '') {
10147 8         12 $modifier =~ tr/bB//d;
10148             $modifier =~ tr/i//d;
10149             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10150             }
10151              
10152 8         54 # with /b /B modifier
10153             elsif ($modifier =~ tr/bB//d) {
10154             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10155             }
10156              
10157 44         99 # without /b /B modifier
10158             else {
10159             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10160             }
10161             }
10162              
10163             #
10164             # escape regexp (s'here'')
10165 44     44 0 113 #
10166             sub e_s1_qt {
10167 44 100       111 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10168              
10169             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10170 44         112  
10171             # split regexp
10172             my @char = $string =~ /\G((?>
10173             [^\x81-\x9F\xE0-\xFD\\\[\$\@\/] |
10174             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
10175             \[\^ |
10176             \[\: (?>[a-z]+) \:\] |
10177             \[\:\^ (?>[a-z]+) \:\] |
10178             [\$\@\/] |
10179             \\ (?:$q_char) |
10180             (?:$q_char)
10181             ))/oxmsg;
10182 44         633  
10183 44 50 100     152 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10184             for (my $i=0; $i <= $#char; $i++) {
10185             if (0) {
10186             }
10187 62         619  
10188 0         0 # escape last octet of multiple-octet
10189             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10190             $char[$i] = $1 . '\\' . $2;
10191             }
10192              
10193 0         0 # open character class [...]
10194 0 0       0 elsif ($char[$i] eq '[') {
10195 0         0 my $left = $i;
10196             if ($char[$i+1] eq ']') {
10197 0         0 $i++;
10198 0 0       0 }
10199 0         0 while (1) {
10200             if (++$i > $#char) {
10201 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10202 0         0 }
10203             if ($char[$i] eq ']') {
10204             my $right = $i;
10205 0         0  
10206             # [...]
10207 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
10208 0         0  
10209             $i = $left;
10210             last;
10211             }
10212             }
10213             }
10214              
10215 0         0 # open character class [^...]
10216 0 0       0 elsif ($char[$i] eq '[^') {
10217 0         0 my $left = $i;
10218             if ($char[$i+1] eq ']') {
10219 0         0 $i++;
10220 0 0       0 }
10221 0         0 while (1) {
10222             if (++$i > $#char) {
10223 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10224 0         0 }
10225             if ($char[$i] eq ']') {
10226             my $right = $i;
10227 0         0  
10228             # [^...]
10229 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10230 0         0  
10231             $i = $left;
10232             last;
10233             }
10234             }
10235             }
10236              
10237 0         0 # escape $ @ / and \
10238             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10239             $char[$i] = '\\' . $char[$i];
10240             }
10241              
10242 0         0 # rewrite character class or escape character
10243             elsif (my $char = character_class($char[$i],$modifier)) {
10244             $char[$i] = $char;
10245             }
10246              
10247 6 50       17 # /i modifier
10248 8         18 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
10249             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
10250             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
10251 8         19 }
10252             else {
10253             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
10254             }
10255             }
10256              
10257 0 0       0 # quote character before ? + * {
10258             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10259             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10260 0         0 }
10261             else {
10262             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10263             }
10264             }
10265 0         0 }
10266 44         99  
10267 44         86 $modifier =~ tr/i//d;
10268 44         70 $delimiter = '/';
10269 44         72 $end_delimiter = '/';
10270 44         91 my $prematch = '';
10271             $prematch = "($anchor)";
10272             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10273             }
10274              
10275             #
10276             # escape regexp (s'here''b)
10277 44     44 0 355 #
10278             sub e_s1_qb {
10279             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10280 44         94  
10281             # split regexp
10282             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10283 44         173  
10284 44 50       119 # unescape character
    50          
10285             for (my $i=0; $i <= $#char; $i++) {
10286             if (0) {
10287             }
10288 98         384  
10289             # remain \\
10290             elsif ($char[$i] eq '\\\\') {
10291             }
10292              
10293 0         0 # escape $ @ / and \
10294             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10295             $char[$i] = '\\' . $char[$i];
10296             }
10297 0         0 }
10298 44         76  
10299 44         68 $delimiter = '/';
10300 44         56 $end_delimiter = '/';
10301 44         55 my $prematch = '';
10302             $prematch = q{(\G[\x00-\xFF]*?)};
10303             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10304             }
10305              
10306             #
10307             # escape regexp (s''here')
10308 44     91 0 319 #
10309             sub e_s2_q {
10310 91         213 my($ope,$delimiter,$end_delimiter,$string) = @_;
10311              
10312 91         141 $slash = 'div';
10313 91         384  
10314 91 50 66     263 my @char = $string =~ / \G (?>[^\x81-\x9F\xE0-\xFD\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10315             for (my $i=0; $i <= $#char; $i++) {
10316             if (0) {
10317             }
10318 9         103  
10319 0         0 # escape last octet of multiple-octet
10320             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10321             $char[$i] = $1 . '\\' . $2;
10322 0         0 }
10323             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10324             $char[$i] = $1 . '\\' . $2;
10325             }
10326              
10327             # not escape \\
10328             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10329             }
10330              
10331 0         0 # escape $ @ / and \
10332             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10333             $char[$i] = '\\' . $char[$i];
10334 5 50 66     20 }
10335 91         247 }
10336             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10337             $char[-1] = $1 . '\\' . $2;
10338 0         0 }
10339              
10340             return join '', $ope, $delimiter, @char, $end_delimiter;
10341             }
10342              
10343             #
10344             # escape regexp (s/here/and here/modifier)
10345 91     290 0 312 #
10346 290   100     2314 sub e_sub {
10347             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10348 290         1314 $modifier ||= '';
10349 290 50       623  
10350 290         1044 $modifier =~ tr/p//d;
10351 0         0 if ($modifier =~ /([adlu])/oxms) {
10352 0 0       0 my $line = 0;
10353 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10354 0         0 if ($filename ne __FILE__) {
10355             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10356             last;
10357 0         0 }
10358             }
10359             die qq{Unsupported modifier "$1" used at line $line.\n};
10360 0 100       0 }
10361 290         773  
10362 37         78 if ($variable eq '') {
10363             $variable = '$_';
10364             $bind_operator = ' =~ ';
10365 37         66 }
10366              
10367             $slash = 'div';
10368              
10369             # P.128 Start of match (or end of previous match): \G
10370             # P.130 Advanced Use of \G with Perl
10371             # in Chapter 3: Overview of Regular Expression Features and Flavors
10372             # P.312 Iterative Matching: Scalar Context, with /g
10373             # in Chapter 7: Perl
10374             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10375              
10376             # P.181 Where You Left Off: The \G Assertion
10377             # in Chapter 5: Pattern Matching
10378             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10379              
10380             # P.220 Where You Left Off: The \G Assertion
10381             # in Chapter 5: Pattern Matching
10382 290         505 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10383 290         480  
10384             my $e_modifier = $modifier =~ tr/e//d;
10385 290         493 my $r_modifier = $modifier =~ tr/r//d;
10386 290 50       492  
10387 290         837 my $my = '';
10388 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10389 0         0 $my = $variable;
10390             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10391             $variable =~ s/ = .+ \z//oxms;
10392 0         0 }
10393 290         772  
10394             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10395             $variable_basename =~ s/ \s+ \z//oxms;
10396 290         571  
10397 290 100       469 # quote replacement string
10398 290         738 my $e_replacement = '';
10399 17         71 if ($e_modifier >= 1) {
10400             $e_replacement = e_qq('', '', '', $replacement);
10401             $e_modifier--;
10402 17 100       32 }
10403 273         628 else {
10404             if ($delimiter2 eq "'") {
10405             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10406 91         246 }
10407             else {
10408             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10409             }
10410 182         495 }
10411              
10412             my $sub = '';
10413 290 100       563  
10414 290 100       640 # with /r
    50          
10415             if ($r_modifier) {
10416             if (0) {
10417             }
10418 8         29  
10419 0 50       0 # s///gr with multibyte anchoring
10420             elsif ($modifier =~ /g/oxms) {
10421             $sub = sprintf(
10422             # 1 2 3 4 5
10423             q,
10424              
10425             $variable, # 1
10426             ($delimiter1 eq "'") ? # 2
10427             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10428             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10429             $s_matched, # 3
10430             $e_replacement, # 4
10431             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10432             );
10433             }
10434              
10435 4 0       20 # s///gr without multibyte anchoring
10436             elsif ($modifier =~ /g/oxms) {
10437             $sub = sprintf(
10438             # 1 2 3 4 5
10439             q,
10440              
10441             $variable, # 1
10442             ($delimiter1 eq "'") ? # 2
10443             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10444             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10445             $s_matched, # 3
10446             $e_replacement, # 4
10447             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10448             );
10449             }
10450              
10451             # s///r
10452 0         0 else {
10453 4         8  
10454             my $prematch = q{$`};
10455 4 50       6 $prematch = q{${1}};
10456              
10457             $sub = sprintf(
10458             # 1 2 3 4 5 6 7
10459             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Einformixv6als::re_r=%s; %s"%s$Einformixv6als::re_r$'" } : %s>,
10460              
10461             $variable, # 1
10462             ($delimiter1 eq "'") ? # 2
10463             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10464             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10465             $s_matched, # 3
10466             $e_replacement, # 4
10467             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10468             $prematch, # 6
10469             $variable, # 7
10470             );
10471             }
10472 4 50       17  
10473 8         28 # $var !~ s///r doesn't make sense
10474             if ($bind_operator =~ / !~ /oxms) {
10475             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10476             }
10477             }
10478              
10479 0 100       0 # without /r
    50          
10480             else {
10481             if (0) {
10482             }
10483 282         1021  
10484 0 100       0 # s///g with multibyte anchoring
    100          
10485             elsif ($modifier =~ /g/oxms) {
10486             $sub = sprintf(
10487             # 1 2 3 4 5 6 7 8 9 10
10488             q,
10489              
10490             $variable, # 1
10491             ($delimiter1 eq "'") ? # 2
10492             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10493             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10494             $s_matched, # 3
10495             $e_replacement, # 4
10496             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10497             $variable, # 6
10498             $variable, # 7
10499             $variable, # 8
10500             $variable, # 9
10501              
10502             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10503             # It returns false if the match succeeds, and true if it fails.
10504             # (and so on)
10505              
10506             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10507             );
10508             }
10509              
10510 35 0       164 # s///g without multibyte anchoring
    0          
10511             elsif ($modifier =~ /g/oxms) {
10512             $sub = sprintf(
10513             # 1 2 3 4 5 6 7 8
10514             q,
10515              
10516             $variable, # 1
10517             ($delimiter1 eq "'") ? # 2
10518             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10519             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10520             $s_matched, # 3
10521             $e_replacement, # 4
10522             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10523             $variable, # 6
10524             $variable, # 7
10525             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10526             );
10527             }
10528              
10529             # s///
10530 0         0 else {
10531 247         457  
10532             my $prematch = q{$`};
10533 247 100       393 $prematch = q{${1}};
    100          
10534              
10535             $sub = sprintf(
10536              
10537             ($bind_operator =~ / =~ /oxms) ?
10538              
10539             # 1 2 3 4 5 6 7 8
10540             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Einformixv6als::re_r=%s; %s%s="%s$Einformixv6als::re_r$'"; 1 } : undef> :
10541              
10542             # 1 2 3 4 5 6 7 8
10543             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Einformixv6als::re_r=%s; %s%s="%s$Einformixv6als::re_r$'"; undef }>,
10544              
10545             $variable, # 1
10546             $bind_operator, # 2
10547             ($delimiter1 eq "'") ? # 3
10548             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10549             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10550             $s_matched, # 4
10551             $e_replacement, # 5
10552             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 6
10553             $variable, # 7
10554             $prematch, # 8
10555             );
10556             }
10557             }
10558 247 50       1241  
10559 290         871 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10560             if ($my ne '') {
10561             $sub = "($my, $sub)[1]";
10562             }
10563 0         0  
10564 290         491 # clear s/// variable
10565             $sub_variable = '';
10566 290         417 $bind_operator = '';
10567              
10568             return $sub;
10569             }
10570              
10571             #
10572             # escape chdir (qq//, "")
10573 290     0 0 2537 #
10574             sub e_chdir {
10575 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10576 0 0       0  
10577 0 0       0 if ($^W) {
10578 0         0 if (Einformixv6als::_MSWin32_5Cended_path($string)) {
10579 0         0 if ($] !~ /^5\.005/oxms) {
10580             warn <
10581             @{[__FILE__]}: Can't chdir to '$string'
10582              
10583             chdir does not work with chr(0x5C) at end of path
10584             http://bugs.activestate.com/show_bug.cgi?id=81839
10585             END
10586             }
10587             }
10588 0         0 }
10589              
10590             return e_qq($ope,$delimiter,$end_delimiter,$string);
10591             }
10592              
10593             #
10594             # escape chdir (q//, '')
10595 0     2 0 0 #
10596             sub e_chdir_q {
10597 2 50       7 my($ope,$delimiter,$end_delimiter,$string) = @_;
10598 2 0       6  
10599 0 0       0 if ($^W) {
10600 0         0 if (Einformixv6als::_MSWin32_5Cended_path($string)) {
10601 0         0 if ($] !~ /^5\.005/oxms) {
10602             warn <
10603             @{[__FILE__]}: Can't chdir to '$string'
10604              
10605             chdir does not work with chr(0x5C) at end of path
10606             http://bugs.activestate.com/show_bug.cgi?id=81839
10607             END
10608             }
10609             }
10610 0         0 }
10611              
10612             return e_q($ope,$delimiter,$end_delimiter,$string);
10613             }
10614              
10615             #
10616             # escape regexp of split qr//
10617 2     273 0 12 #
10618 273   100     1334 sub e_split {
10619             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10620 273         1085 $modifier ||= '';
10621 273 50       544  
10622 273         778 $modifier =~ tr/p//d;
10623 0         0 if ($modifier =~ /([adlu])/oxms) {
10624 0 0       0 my $line = 0;
10625 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10626 0         0 if ($filename ne __FILE__) {
10627             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10628             last;
10629 0         0 }
10630             }
10631             die qq{Unsupported modifier "$1" used at line $line.\n};
10632 0         0 }
10633              
10634             $slash = 'div';
10635 273 100       511  
10636 273         646 # /b /B modifier
10637             if ($modifier =~ tr/bB//d) {
10638             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10639 84 100       483 }
10640 189         681  
10641             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10642             my $metachar = qr/[\@\\|[\]{^]/oxms;
10643 189         718  
10644             # split regexp
10645             my @char = $string =~ /\G((?>
10646             [^\x81-\x9F\xE0-\xFD\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
10647             \\x (?>[0-9A-Fa-f]{1,2}) |
10648             \\ (?>[0-7]{2,3}) |
10649             \\c [\x40-\x5F] |
10650             \\x\{ (?>[0-9A-Fa-f]+) \} |
10651             \\o\{ (?>[0-7]+) \} |
10652             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
10653             \\ $q_char |
10654             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10655             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10656             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10657             [\$\@] $qq_variable |
10658             \$ (?>\s* [0-9]+) |
10659             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10660             \$ \$ (?![\w\{]) |
10661             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10662             \[\^ |
10663             \[\: (?>[a-z]+) :\] |
10664             \[\:\^ (?>[a-z]+) :\] |
10665             \(\? |
10666             $q_char
10667 189         20661 ))/oxmsg;
10668 189         728  
10669 189         322 my $left_e = 0;
10670             my $right_e = 0;
10671             for (my $i=0; $i <= $#char; $i++) {
10672 189 50 33     693  
    50 33        
    100          
    100          
    50          
    50          
10673 372         2367 # "\L\u" --> "\u\L"
10674             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10675             @char[$i,$i+1] = @char[$i+1,$i];
10676             }
10677              
10678 0         0 # "\U\l" --> "\l\U"
10679             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10680             @char[$i,$i+1] = @char[$i+1,$i];
10681             }
10682              
10683 0         0 # octal escape sequence
10684             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10685             $char[$i] = Einformixv6als::octchr($1);
10686             }
10687              
10688 1         3 # hexadecimal escape sequence
10689             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10690             $char[$i] = Einformixv6als::hexchr($1);
10691             }
10692              
10693             # \b{...} --> b\{...}
10694             # \B{...} --> B\{...}
10695             # \N{CHARNAME} --> N\{CHARNAME}
10696             # \p{PROPERTY} --> p\{PROPERTY}
10697 1         5 # \P{PROPERTY} --> P\{PROPERTY}
10698             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
10699             $char[$i] = $1 . '\\' . $2;
10700             }
10701              
10702 0         0 # \p, \P, \X --> p, P, X
10703             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10704             $char[$i] = $1;
10705 0 50 100     0 }
    50 100        
    100 66        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
10706              
10707             if (0) {
10708             }
10709 372         3519  
10710 0         0 # escape last octet of multiple-octet
10711             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10712             $char[$i] = $1 . '\\' . $2;
10713             }
10714              
10715 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10716 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10717             if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
10718             $char[$i] .= join '', splice @char, $i+1, 3;
10719 0         0 }
10720             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
10721             $char[$i] .= join '', splice @char, $i+1, 2;
10722 0         0 }
10723             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
10724             $char[$i] .= join '', splice @char, $i+1, 1;
10725             }
10726             }
10727              
10728 0         0 # open character class [...]
10729 3 50       14 elsif ($char[$i] eq '[') {
10730 3         14 my $left = $i;
10731             if ($char[$i+1] eq ']') {
10732 0         0 $i++;
10733 3 50       5 }
10734 7         17 while (1) {
10735             if (++$i > $#char) {
10736 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10737 7         16 }
10738             if ($char[$i] eq ']') {
10739             my $right = $i;
10740 3 50       5  
10741 3         24 # [...]
  0         0  
10742             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10743             splice @char, $left, $right-$left+1, sprintf(q{@{[Einformixv6als::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10744 0         0 }
10745             else {
10746             splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
10747 3         15 }
10748 3         5  
10749             $i = $left;
10750             last;
10751             }
10752             }
10753             }
10754              
10755 3         19 # open character class [^...]
10756 1 50       2 elsif ($char[$i] eq '[^') {
10757 1         5 my $left = $i;
10758             if ($char[$i+1] eq ']') {
10759 0         0 $i++;
10760 1 50       2 }
10761 2         6 while (1) {
10762             if (++$i > $#char) {
10763 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10764 2         6 }
10765             if ($char[$i] eq ']') {
10766             my $right = $i;
10767 1 50       3  
10768 1         8 # [^...]
  0         0  
10769             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10770             splice @char, $left, $right-$left+1, sprintf(q{@{[Einformixv6als::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10771 0         0 }
10772             else {
10773             splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10774 1         20 }
10775 1         3  
10776             $i = $left;
10777             last;
10778             }
10779             }
10780             }
10781              
10782 1         3 # rewrite character class or escape character
10783             elsif (my $char = character_class($char[$i],$modifier)) {
10784             $char[$i] = $char;
10785             }
10786              
10787             # P.794 29.2.161. split
10788             # in Chapter 29: Functions
10789             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10790              
10791             # P.951 split
10792             # in Chapter 27: Functions
10793             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10794              
10795             # said "The //m modifier is assumed when you split on the pattern /^/",
10796             # but perl5.008 is not so. Therefore, this software adds //m.
10797             # (and so on)
10798              
10799 5         21 # split(m/^/) --> split(m/^/m)
10800             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10801             $modifier .= 'm';
10802             }
10803              
10804 11 50       47 # /i modifier
10805 18         42 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
10806             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
10807             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
10808 18         55 }
10809             else {
10810             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
10811             }
10812             }
10813              
10814 0 50       0 # \u \l \U \L \F \Q \E
10815 2         9 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10816             if ($right_e < $left_e) {
10817             $char[$i] = '\\' . $char[$i];
10818             }
10819 0         0 }
10820 0         0 elsif ($char[$i] eq '\u') {
10821             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
10822             $left_e++;
10823 0         0 }
10824 0         0 elsif ($char[$i] eq '\l') {
10825             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
10826             $left_e++;
10827 0         0 }
10828 0         0 elsif ($char[$i] eq '\U') {
10829             $char[$i] = '@{[Einformixv6als::uc qq<';
10830             $left_e++;
10831 0         0 }
10832 0         0 elsif ($char[$i] eq '\L') {
10833             $char[$i] = '@{[Einformixv6als::lc qq<';
10834             $left_e++;
10835 0         0 }
10836 0         0 elsif ($char[$i] eq '\F') {
10837             $char[$i] = '@{[Einformixv6als::fc qq<';
10838             $left_e++;
10839 0         0 }
10840 0         0 elsif ($char[$i] eq '\Q') {
10841             $char[$i] = '@{[CORE::quotemeta qq<';
10842             $left_e++;
10843 0 0       0 }
10844 0         0 elsif ($char[$i] eq '\E') {
10845 0         0 if ($right_e < $left_e) {
10846             $char[$i] = '>]}';
10847             $right_e++;
10848 0         0 }
10849             else {
10850             $char[$i] = '';
10851             }
10852 0         0 }
10853 0 0       0 elsif ($char[$i] eq '\Q') {
10854 0         0 while (1) {
10855             if (++$i > $#char) {
10856 0 0       0 last;
10857 0         0 }
10858             if ($char[$i] eq '\E') {
10859             last;
10860             }
10861             }
10862             }
10863             elsif ($char[$i] eq '\E') {
10864             }
10865              
10866 0 0       0 # $0 --> $0
10867 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10868             if ($ignorecase) {
10869             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10870             }
10871 0 0       0 }
10872 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10873             if ($ignorecase) {
10874             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10875             }
10876             }
10877              
10878             # $$ --> $$
10879             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10880             }
10881              
10882             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10883 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10884 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10885 0         0 $char[$i] = e_capture($1);
10886             if ($ignorecase) {
10887             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10888             }
10889 0         0 }
10890 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10891 0         0 $char[$i] = e_capture($1);
10892             if ($ignorecase) {
10893             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10894             }
10895             }
10896              
10897 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10898 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10899 0         0 $char[$i] = e_capture($1.'->'.$2);
10900             if ($ignorecase) {
10901             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10902             }
10903             }
10904              
10905 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10906 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10907 0         0 $char[$i] = e_capture($1.'->'.$2);
10908             if ($ignorecase) {
10909             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10910             }
10911             }
10912              
10913 0         0 # $$foo
10914 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10915 0         0 $char[$i] = e_capture($1);
10916             if ($ignorecase) {
10917             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10918             }
10919             }
10920              
10921 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
10922 12         39 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10923             if ($ignorecase) {
10924             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::PREMATCH())]}';
10925 0         0 }
10926             else {
10927             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
10928             }
10929             }
10930              
10931 12 50       66 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
10932 12         42 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10933             if ($ignorecase) {
10934             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::MATCH())]}';
10935 0         0 }
10936             else {
10937             $char[$i] = '@{[Einformixv6als::MATCH()]}';
10938             }
10939             }
10940              
10941 12 50       74 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
10942 9         31 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10943             if ($ignorecase) {
10944             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::POSTMATCH())]}';
10945 0         0 }
10946             else {
10947             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
10948             }
10949             }
10950              
10951 9 0       56 # ${ foo }
10952 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10953             if ($ignorecase) {
10954             $char[$i] = '@{[Einformixv6als::ignorecase(' . $1 . ')]}';
10955             }
10956             }
10957              
10958 0         0 # ${ ... }
10959 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10960 0         0 $char[$i] = e_capture($1);
10961             if ($ignorecase) {
10962             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10963             }
10964             }
10965              
10966 0         0 # $scalar or @array
10967 3 50       12 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10968 3         18 $char[$i] = e_string($char[$i]);
10969             if ($ignorecase) {
10970             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10971             }
10972             }
10973              
10974 0 100       0 # quote character before ? + * {
10975             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10976             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10977 7         74 }
10978             else {
10979             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10980             }
10981             }
10982             }
10983 4         25  
10984 189 50       463 # make regexp string
10985 189         458 $modifier =~ tr/i//d;
10986             if ($left_e > $right_e) {
10987 0         0 return join '', 'Einformixv6als::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10988             }
10989             return join '', 'Einformixv6als::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10990             }
10991              
10992             #
10993             # escape regexp of split qr''
10994 189     112 0 1890 #
10995 112   100     583 sub e_split_q {
10996             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10997 112         377 $modifier ||= '';
10998 112 50       262  
10999 112         378 $modifier =~ tr/p//d;
11000 0         0 if ($modifier =~ /([adlu])/oxms) {
11001 0 0       0 my $line = 0;
11002 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
11003 0         0 if ($filename ne __FILE__) {
11004             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
11005             last;
11006 0         0 }
11007             }
11008             die qq{Unsupported modifier "$1" used at line $line.\n};
11009 0         0 }
11010              
11011             $slash = 'div';
11012 112 100       224  
11013 112         274 # /b /B modifier
11014             if ($modifier =~ tr/bB//d) {
11015             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
11016 56 100       328 }
11017              
11018             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11019 56         165  
11020             # split regexp
11021             my @char = $string =~ /\G((?>
11022             [^\x81-\x9F\xE0-\xFD\\\[] |
11023             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
11024             \[\^ |
11025             \[\: (?>[a-z]+) \:\] |
11026             \[\:\^ (?>[a-z]+) \:\] |
11027             \\ (?:$q_char) |
11028             (?:$q_char)
11029             ))/oxmsg;
11030 56         444  
11031 56 50 33     187 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11032             for (my $i=0; $i <= $#char; $i++) {
11033             if (0) {
11034             }
11035 56         622  
11036 0         0 # escape last octet of multiple-octet
11037             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11038             $char[$i] = $1 . '\\' . $2;
11039             }
11040              
11041 0         0 # open character class [...]
11042 0 0       0 elsif ($char[$i] eq '[') {
11043 0         0 my $left = $i;
11044             if ($char[$i+1] eq ']') {
11045 0         0 $i++;
11046 0 0       0 }
11047 0         0 while (1) {
11048             if (++$i > $#char) {
11049 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11050 0         0 }
11051             if ($char[$i] eq ']') {
11052             my $right = $i;
11053 0         0  
11054             # [...]
11055 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
11056 0         0  
11057             $i = $left;
11058             last;
11059             }
11060             }
11061             }
11062              
11063 0         0 # open character class [^...]
11064 0 0       0 elsif ($char[$i] eq '[^') {
11065 0         0 my $left = $i;
11066             if ($char[$i+1] eq ']') {
11067 0         0 $i++;
11068 0 0       0 }
11069 0         0 while (1) {
11070             if (++$i > $#char) {
11071 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11072 0         0 }
11073             if ($char[$i] eq ']') {
11074             my $right = $i;
11075 0         0  
11076             # [^...]
11077 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11078 0         0  
11079             $i = $left;
11080             last;
11081             }
11082             }
11083             }
11084              
11085 0         0 # rewrite character class or escape character
11086             elsif (my $char = character_class($char[$i],$modifier)) {
11087             $char[$i] = $char;
11088             }
11089              
11090 0         0 # split(m/^/) --> split(m/^/m)
11091             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11092             $modifier .= 'm';
11093             }
11094              
11095 0 50       0 # /i modifier
11096 12         31 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
11097             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
11098             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
11099 12         36 }
11100             else {
11101             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
11102             }
11103             }
11104              
11105 0 0       0 # quote character before ? + * {
11106             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11107             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11108 0         0 }
11109             else {
11110             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11111             }
11112             }
11113 0         0 }
11114 56         147  
11115             $modifier =~ tr/i//d;
11116             return join '', 'Einformixv6als::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11117             }
11118              
11119             #
11120             # escape use without import
11121 56     0 0 406 #
11122             sub e_use_noimport {
11123 0           my($module) = @_;
11124              
11125 0           my $expr = _pathof($module);
11126 0            
11127             my $fh = gensym();
11128 0 0         for my $realfilename (_realfilename($expr)) {
11129 0            
11130 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11131 0 0         local $/ = undef; # slurp mode
11132             my $script = <$fh>;
11133 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11134 0            
11135             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11136 0           return qq;
11137             }
11138             last;
11139             }
11140 0           }
11141              
11142             return qq;
11143             }
11144              
11145             #
11146             # escape no without unimport
11147 0     0 0   #
11148             sub e_no_nounimport {
11149 0           my($module) = @_;
11150              
11151 0           my $expr = _pathof($module);
11152 0            
11153             my $fh = gensym();
11154 0 0         for my $realfilename (_realfilename($expr)) {
11155 0            
11156 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11157 0 0         local $/ = undef; # slurp mode
11158             my $script = <$fh>;
11159 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11160 0            
11161             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11162 0           return qq;
11163             }
11164             last;
11165             }
11166 0           }
11167              
11168             return qq;
11169             }
11170              
11171             #
11172             # escape use with import no parameter
11173 0     0 0   #
11174             sub e_use_noparam {
11175 0           my($module) = @_;
11176              
11177 0           my $expr = _pathof($module);
11178 0            
11179             my $fh = gensym();
11180 0 0         for my $realfilename (_realfilename($expr)) {
11181 0            
11182 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11183 0 0         local $/ = undef; # slurp mode
11184             my $script = <$fh>;
11185 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11186              
11187             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11188              
11189             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11190             # in Chapter 12: Objects
11191             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11192              
11193             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11194             # in Chapter 12: Objects
11195             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11196              
11197 0           # (and so on)
11198              
11199 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->import() if $module->can('import'); }];
11200             }
11201             last;
11202             }
11203 0           }
11204              
11205             return qq;
11206             }
11207              
11208             #
11209             # escape no with unimport no parameter
11210 0     0 0   #
11211             sub e_no_noparam {
11212 0           my($module) = @_;
11213              
11214 0           my $expr = _pathof($module);
11215 0            
11216             my $fh = gensym();
11217 0 0         for my $realfilename (_realfilename($expr)) {
11218 0            
11219 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11220 0 0         local $/ = undef; # slurp mode
11221             my $script = <$fh>;
11222 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11223 0            
11224             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11225 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11226             }
11227             last;
11228             }
11229 0           }
11230              
11231             return qq;
11232             }
11233              
11234             #
11235             # escape use with import parameters
11236 0     0 0   #
11237             sub e_use {
11238 0           my($module,$list) = @_;
11239              
11240 0           my $expr = _pathof($module);
11241 0            
11242             my $fh = gensym();
11243 0 0         for my $realfilename (_realfilename($expr)) {
11244 0            
11245 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11246 0 0         local $/ = undef; # slurp mode
11247             my $script = <$fh>;
11248 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11249 0            
11250             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11251 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->import($list) if $module->can('import'); }];
11252             }
11253             last;
11254             }
11255 0           }
11256              
11257             return qq;
11258             }
11259              
11260             #
11261             # escape no with unimport parameters
11262 0     0 0   #
11263             sub e_no {
11264 0           my($module,$list) = @_;
11265              
11266 0           my $expr = _pathof($module);
11267 0            
11268             my $fh = gensym();
11269 0 0         for my $realfilename (_realfilename($expr)) {
11270 0            
11271 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11272 0 0         local $/ = undef; # slurp mode
11273             my $script = <$fh>;
11274 0 0         close($fh) or die "Can't close file: $realfilename: $!";
11275 0            
11276             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11277 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11278             }
11279             last;
11280             }
11281 0           }
11282              
11283             return qq;
11284             }
11285              
11286             #
11287             # file path of module
11288 0     0     #
11289             sub _pathof {
11290 0 0         my($expr) = @_;
11291 0            
11292             if ($^O eq 'MacOS') {
11293             $expr =~ s#::#:#g;
11294 0           }
11295             else {
11296 0 0         $expr =~ s#::#/#g;
11297             }
11298 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11299              
11300             return $expr;
11301             }
11302              
11303             #
11304             # real file name of module
11305 0     0     #
11306             sub _realfilename {
11307 0 0         my($expr) = @_;
11308 0            
  0            
11309             if ($^O eq 'MacOS') {
11310             return map {"$_$expr"} @INC;
11311 0           }
  0            
11312             else {
11313             return map {"$_/$expr"} @INC;
11314             }
11315             }
11316              
11317             #
11318             # instead of Carp::carp
11319 0     0 0   #
11320 0           sub carp {
11321             my($package,$filename,$line) = caller(1);
11322             print STDERR "@_ at $filename line $line.\n";
11323             }
11324              
11325             #
11326             # instead of Carp::croak
11327 0     0 0   #
11328 0           sub croak {
11329 0           my($package,$filename,$line) = caller(1);
11330             print STDERR "@_ at $filename line $line.\n";
11331             die "\n";
11332             }
11333              
11334             #
11335             # instead of Carp::cluck
11336 0     0 0   #
11337 0           sub cluck {
11338 0           my $i = 0;
11339 0           my @cluck = ();
11340 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11341             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11342 0           $i++;
11343 0           }
11344 0           print STDERR CORE::reverse @cluck;
11345             print STDERR "\n";
11346             print STDERR @_;
11347             }
11348              
11349             #
11350             # instead of Carp::confess
11351 0     0 0   #
11352 0           sub confess {
11353 0           my $i = 0;
11354 0           my @confess = ();
11355 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11356             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11357 0           $i++;
11358 0           }
11359 0           print STDERR CORE::reverse @confess;
11360 0           print STDERR "\n";
11361             print STDERR @_;
11362             die "\n";
11363             }
11364              
11365             1;
11366              
11367             __END__