File Coverage

blib/lib/Einformixv6als.pm
Criterion Covered Total %
statement 1206 4691 25.7
branch 1360 4560 29.8
condition 162 496 32.6
subroutine 68 190 35.7
pod 8 148 5.4
total 2804 10085 27.8


line stmt bran cond sub pod time code
1             package Einformixv6als;
2 389     389   11747 use strict;
  389         2972  
  389         12601  
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   7239 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         2932  
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   3225 use vars qw($VERSION);
  389         4480  
  389         61987  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   6338 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         713 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         58663 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   34711 CORE::eval q{
  389     389   5678  
  389     150   896  
  389         63223  
  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       178687 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 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     1152 0 0 my($name) = @_;
73              
74 1152 50       2865 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
75 1152         4558 return $name;
76             }
77             elsif (Einformixv6als::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Einformixv6als::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 1152         9017 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 50   1152 0 0 if (defined $_[1]) {
112 389     389   5294 no strict qw(refs);
  389         727  
  389         30009  
113 1152         3523 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 389     389   4221 no strict qw(refs);
  389     0   2142  
  389         75491  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         1951  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]|[\x00-\xFF]};
148 389     389   4220 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         958  
  389         38767  
149 389     389   4002 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         2189  
  389         704492  
150              
151             #
152             # INFORMIX V6 ALS character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # INFORMIX V6 ALS case conversion
158             #
159             my %lc = ();
160             @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)} =
161             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);
162             my %uc = ();
163             @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)} =
164             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);
165             my %fc = ();
166             @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)} =
167             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);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Einformixv6als \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0x80],
175             [0xA0..0xDF],
176             [0xFE..0xFF],
177             ],
178             2 => [ [0x81..0x9F],[0x40..0x7E],
179             [0x81..0x9F],[0x80..0xFC],
180             [0xE0..0xFC],[0x40..0x7E],
181             [0xE0..0xFC],[0x80..0xFC],
182             ],
183             3 => [ [0xFD..0xFD],[0xA1..0xFE],[0xA1..0xFE],
184             ],
185             );
186             }
187              
188             else {
189             croak "Don't know my package name '@{[__PACKAGE__]}'";
190             }
191              
192             #
193             # @ARGV wildcard globbing
194             #
195             sub import {
196              
197 1152 50   5   5981 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
198 5         84 my @argv = ();
199 0         0 for (@ARGV) {
200              
201             # has space
202 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
203 0 0       0 if (my @glob = Einformixv6als::glob(qq{"$_"})) {
204 0         0 push @argv, @glob;
205             }
206             else {
207 0         0 push @argv, $_;
208             }
209             }
210              
211             # has wildcard metachar
212             elsif (/\A (?:$q_char)*? [*?] /oxms) {
213 0 0       0 if (my @glob = Einformixv6als::glob($_)) {
214 0         0 push @argv, @glob;
215             }
216             else {
217 0         0 push @argv, $_;
218             }
219             }
220              
221             # no wildcard globbing
222             else {
223 0         0 push @argv, $_;
224             }
225             }
226 0         0 @ARGV = @argv;
227             }
228              
229 0         0 *Char::ord = \&INFORMIXV6ALS::ord;
230 5         30 *Char::ord_ = \&INFORMIXV6ALS::ord_;
231 5         15 *Char::reverse = \&INFORMIXV6ALS::reverse;
232 5         12 *Char::getc = \&INFORMIXV6ALS::getc;
233 5         12 *Char::length = \&INFORMIXV6ALS::length;
234 5         20 *Char::substr = \&INFORMIXV6ALS::substr;
235 5         11 *Char::index = \&INFORMIXV6ALS::index;
236 5         11 *Char::rindex = \&INFORMIXV6ALS::rindex;
237 5         10 *Char::eval = \&INFORMIXV6ALS::eval;
238 5         35 *Char::escape = \&INFORMIXV6ALS::escape;
239 5         12 *Char::escape_token = \&INFORMIXV6ALS::escape_token;
240 5         129 *Char::escape_script = \&INFORMIXV6ALS::escape_script;
241             }
242              
243             # P.230 Care with Prototypes
244             # in Chapter 6: Subroutines
245             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
246             #
247             # If you aren't careful, you can get yourself into trouble with prototypes.
248             # But if you are careful, you can do a lot of neat things with them. This is
249             # all very powerful, of course, and should only be used in moderation to make
250             # the world a better place.
251              
252             # P.332 Care with Prototypes
253             # in Chapter 7: Subroutines
254             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
255             #
256             # If you aren't careful, you can get yourself into trouble with prototypes.
257             # But if you are careful, you can do a lot of neat things with them. This is
258             # all very powerful, of course, and should only be used in moderation to make
259             # the world a better place.
260              
261             #
262             # Prototypes of subroutines
263             #
264       0     sub unimport {}
265             sub Einformixv6als::split(;$$$);
266             sub Einformixv6als::tr($$$$;$);
267             sub Einformixv6als::chop(@);
268             sub Einformixv6als::index($$;$);
269             sub Einformixv6als::rindex($$;$);
270             sub Einformixv6als::lcfirst(@);
271             sub Einformixv6als::lcfirst_();
272             sub Einformixv6als::lc(@);
273             sub Einformixv6als::lc_();
274             sub Einformixv6als::ucfirst(@);
275             sub Einformixv6als::ucfirst_();
276             sub Einformixv6als::uc(@);
277             sub Einformixv6als::uc_();
278             sub Einformixv6als::fc(@);
279             sub Einformixv6als::fc_();
280             sub Einformixv6als::ignorecase;
281             sub Einformixv6als::classic_character_class;
282             sub Einformixv6als::capture;
283             sub Einformixv6als::chr(;$);
284             sub Einformixv6als::chr_();
285             sub Einformixv6als::filetest;
286             sub Einformixv6als::r(;*@);
287             sub Einformixv6als::w(;*@);
288             sub Einformixv6als::x(;*@);
289             sub Einformixv6als::o(;*@);
290             sub Einformixv6als::R(;*@);
291             sub Einformixv6als::W(;*@);
292             sub Einformixv6als::X(;*@);
293             sub Einformixv6als::O(;*@);
294             sub Einformixv6als::e(;*@);
295             sub Einformixv6als::z(;*@);
296             sub Einformixv6als::s(;*@);
297             sub Einformixv6als::f(;*@);
298             sub Einformixv6als::d(;*@);
299             sub Einformixv6als::l(;*@);
300             sub Einformixv6als::p(;*@);
301             sub Einformixv6als::S(;*@);
302             sub Einformixv6als::b(;*@);
303             sub Einformixv6als::c(;*@);
304             sub Einformixv6als::u(;*@);
305             sub Einformixv6als::g(;*@);
306             sub Einformixv6als::k(;*@);
307             sub Einformixv6als::T(;*@);
308             sub Einformixv6als::B(;*@);
309             sub Einformixv6als::M(;*@);
310             sub Einformixv6als::A(;*@);
311             sub Einformixv6als::C(;*@);
312             sub Einformixv6als::filetest_;
313             sub Einformixv6als::r_();
314             sub Einformixv6als::w_();
315             sub Einformixv6als::x_();
316             sub Einformixv6als::o_();
317             sub Einformixv6als::R_();
318             sub Einformixv6als::W_();
319             sub Einformixv6als::X_();
320             sub Einformixv6als::O_();
321             sub Einformixv6als::e_();
322             sub Einformixv6als::z_();
323             sub Einformixv6als::s_();
324             sub Einformixv6als::f_();
325             sub Einformixv6als::d_();
326             sub Einformixv6als::l_();
327             sub Einformixv6als::p_();
328             sub Einformixv6als::S_();
329             sub Einformixv6als::b_();
330             sub Einformixv6als::c_();
331             sub Einformixv6als::u_();
332             sub Einformixv6als::g_();
333             sub Einformixv6als::k_();
334             sub Einformixv6als::T_();
335             sub Einformixv6als::B_();
336             sub Einformixv6als::M_();
337             sub Einformixv6als::A_();
338             sub Einformixv6als::C_();
339             sub Einformixv6als::glob($);
340             sub Einformixv6als::glob_();
341             sub Einformixv6als::lstat(*);
342             sub Einformixv6als::lstat_();
343             sub Einformixv6als::opendir(*$);
344             sub Einformixv6als::stat(*);
345             sub Einformixv6als::stat_();
346             sub Einformixv6als::unlink(@);
347             sub Einformixv6als::chdir(;$);
348             sub Einformixv6als::do($);
349             sub Einformixv6als::require(;$);
350             sub Einformixv6als::telldir(*);
351              
352             sub INFORMIXV6ALS::ord(;$);
353             sub INFORMIXV6ALS::ord_();
354             sub INFORMIXV6ALS::reverse(@);
355             sub INFORMIXV6ALS::getc(;*@);
356             sub INFORMIXV6ALS::length(;$);
357             sub INFORMIXV6ALS::substr($$;$$);
358             sub INFORMIXV6ALS::index($$;$);
359             sub INFORMIXV6ALS::rindex($$;$);
360             sub INFORMIXV6ALS::escape(;$);
361              
362             #
363             # Regexp work
364             #
365 389         42244 use vars qw(
366             $re_a
367             $re_t
368             $re_n
369             $re_r
370 389     389   4306 );
  389         2159  
371              
372             #
373             # Character class
374             #
375 389         129300 use vars qw(
376             $dot
377             $dot_s
378             $eD
379             $eS
380             $eW
381             $eH
382             $eV
383             $eR
384             $eN
385             $not_alnum
386             $not_alpha
387             $not_ascii
388             $not_blank
389             $not_cntrl
390             $not_digit
391             $not_graph
392             $not_lower
393             $not_lower_i
394             $not_print
395             $not_punct
396             $not_space
397             $not_upper
398             $not_upper_i
399             $not_word
400             $not_xdigit
401             $eb
402             $eB
403 389     389   4860 );
  389         2481  
404              
405 389         4842840 use vars qw(
406             $anchor
407             $matched
408 389     389   6462 );
  389         715  
409             ${Einformixv6als::anchor} = qr{\G(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])*?}oxms;
410              
411             # unless LONG_STRING_FOR_RE
412             if (1) {
413             }
414              
415             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
416              
417             # Quantifiers
418             # {n,m} --- Match at least n but not more than m times
419             #
420             # n and m are limited to non-negative integral values less than a
421             # preset limit defined when perl is built. This is usually 32766 on
422             # the most common platforms.
423             #
424             # The following code is an attempt to solve the above limitations
425             # in a multi-byte anchoring.
426              
427             # avoid "Segmentation fault" and "Error: Parse exception"
428              
429             # perl5101delta
430             # http://perldoc.perl.org/perl5101delta.html
431             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
432             # [RT #60034, #60464]. For example, this match would fail:
433             # ("ab" x 32768) =~ /^(ab)*$/
434              
435             # SEE ALSO
436             #
437             # Complex regular subexpression recursion limit
438             # http://www.perlmonks.org/?node_id=810857
439             #
440             # regexp iteration limits
441             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
442             #
443             # latest Perl won't match certain regexes more than 32768 characters long
444             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
445             #
446             # Break through the limitations of regular expressions of Perl
447             # http://d.hatena.ne.jp/gfx/20110212/1297512479
448              
449             if (($] >= 5.010001) or
450             # ActivePerl 5.6 or later (include 5.10.0)
451             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
452             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
453             ) {
454             my $sbcs = ''; # Single Byte Character Set
455             for my $range (@{ $range_tr{1} }) {
456             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
457             }
458              
459             if (0) {
460             }
461              
462             # INFORMIX V6 ALS encoding
463             elsif (__PACKAGE__ =~ / \b Einformixv6als \z/oxms) {
464             ${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;
465             # ************************ octets not in multiple octet char (always char boundary)
466             # **************************************** 2 octet chars
467             # ************************** 3 octet chars
468             # **** malformed octet?
469             }
470              
471             # other encoding
472             else {
473             ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
474             # ******* octets not in multiple octet char (always char boundary)
475             # **************** 2 octet chars
476             }
477              
478             ${Einformixv6als::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
479             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;
480             # qr{
481             # \G # (1), (2)
482             # (? # (3)
483             # (?=.{0,32766}\z) # (4)
484             # (?:[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])*?| # (5)
485             # (?(?=[$sbcs]+\z) # (6)
486             # .*?| #(7)
487             # (?:${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
488             # ))}oxms;
489              
490             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
491             local $^W = 0;
492              
493             if (((('A' x 32768).'B') !~ / ${Einformixv6als::anchor} B /oxms) and
494             ((('A' x 32768).'B') =~ / ${Einformixv6als::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
495             ) {
496             ${Einformixv6als::anchor} = ${Einformixv6als::anchor_SADAHIRO_Tomoyuki_2002_01_17};
497             }
498             else {
499             undef ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17};
500             }
501             }
502              
503             # (1)
504             # P.128 Start of match (or end of previous match): \G
505             # P.130 Advanced Use of \G with Perl
506             # in Chapter3: Over view of Regular Expression Features and Flavors
507             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
508              
509             # (2)
510             # P.255 Use leading anchors
511             # P.256 Expose ^ and \G at the front of expressions
512             # in Chapter6: Crafting an Efficient Expression
513             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
514              
515             # (3)
516             # P.138 Conditional: (? if then| else)
517             # in Chapter3: Over view of Regular Expression Features and Flavors
518             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
519              
520             # (4)
521             # perlre
522             # http://perldoc.perl.org/perlre.html
523             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
524             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
525             # integral values less than a preset limit defined when perl is built.
526             # This is usually 32766 on the most common platforms. The actual limit
527             # can be seen in the error message generated by code such as this:
528             # $_ **= $_ , / {$_} / for 2 .. 42;
529              
530             # (5)
531             # P.1023 Multiple-Byte Anchoring
532             # in Appendix W Perl Code Examples
533             # of ISBN 1-56592-224-7 CJKV Information Processing
534              
535             # (6)
536             # if string has only SBCS (Single Byte Character Set)
537              
538             # (7)
539             # then .*? (isn't limited to 32766)
540              
541             # (8)
542             # else INFORMIX V6 ALS::Regexp::Const (SADAHIRO Tomoyuki)
543             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
544             # http://search.cpan.org/~sadahiro/INFORMIX V6 ALS-Regexp/
545             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE]{2})*?';
546             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE]{2})*?';
547             # $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})*?)';
548              
549             ${Einformixv6als::dot} = qr{(?>[^\x81-\x9F\xE0-\xFD\x0A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
550             ${Einformixv6als::dot_s} = qr{(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
551             ${Einformixv6als::eD} = qr{(?>[^\x81-\x9F\xE0-\xFD0-9]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
552              
553             # Vertical tabs are now whitespace
554             # \s in a regex now matches a vertical tab in all circumstances.
555             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
556             # ${Einformixv6als::eS} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x0A \x0C\x0D\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
557             # ${Einformixv6als::eS} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
558             ${Einformixv6als::eS} = qr{(?>[^\x81-\x9F\xE0-\xFD\s]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
559              
560             ${Einformixv6als::eW} = qr{(?>[^\x81-\x9F\xE0-\xFD0-9A-Z_a-z]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
561             ${Einformixv6als::eH} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
562             ${Einformixv6als::eV} = qr{(?>[^\x81-\x9F\xE0-\xFD\x0A\x0B\x0C\x0D]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
563             ${Einformixv6als::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
564             ${Einformixv6als::eN} = qr{(?>[^\x81-\x9F\xE0-\xFD\x0A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
565             ${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])};
566             ${Einformixv6als::not_alpha} = qr{(?>[^\x81-\x9F\xE0-\xFD\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
567             ${Einformixv6als::not_ascii} = qr{(?>[^\x81-\x9F\xE0-\xFD\x00-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
568             ${Einformixv6als::not_blank} = qr{(?>[^\x81-\x9F\xE0-\xFD\x09\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
569             ${Einformixv6als::not_cntrl} = qr{(?>[^\x81-\x9F\xE0-\xFD\x00-\x1F\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
570             ${Einformixv6als::not_digit} = qr{(?>[^\x81-\x9F\xE0-\xFD\x30-\x39]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
571             ${Einformixv6als::not_graph} = qr{(?>[^\x81-\x9F\xE0-\xFD\x21-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
572             ${Einformixv6als::not_lower} = qr{(?>[^\x81-\x9F\xE0-\xFD\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
573             ${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
574             # ${Einformixv6als::not_lower_i} = qr{(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])}; # older Perl compatible
575             ${Einformixv6als::not_print} = qr{(?>[^\x81-\x9F\xE0-\xFD\x20-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
576             ${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])};
577             ${Einformixv6als::not_space} = qr{(?>[^\x81-\x9F\xE0-\xFD\s\x0B]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
578             ${Einformixv6als::not_upper} = qr{(?>[^\x81-\x9F\xE0-\xFD\x41-\x5A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])};
579             ${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
580             # ${Einformixv6als::not_upper_i} = qr{(?>[^\x81-\x9F\xE0-\xFD]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])}; # older Perl compatible
581             ${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])};
582             ${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])};
583             ${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))};
584             ${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]))};
585              
586             # avoid: Name "Einformixv6als::foo" used only once: possible typo at here.
587             ${Einformixv6als::dot} = ${Einformixv6als::dot};
588             ${Einformixv6als::dot_s} = ${Einformixv6als::dot_s};
589             ${Einformixv6als::eD} = ${Einformixv6als::eD};
590             ${Einformixv6als::eS} = ${Einformixv6als::eS};
591             ${Einformixv6als::eW} = ${Einformixv6als::eW};
592             ${Einformixv6als::eH} = ${Einformixv6als::eH};
593             ${Einformixv6als::eV} = ${Einformixv6als::eV};
594             ${Einformixv6als::eR} = ${Einformixv6als::eR};
595             ${Einformixv6als::eN} = ${Einformixv6als::eN};
596             ${Einformixv6als::not_alnum} = ${Einformixv6als::not_alnum};
597             ${Einformixv6als::not_alpha} = ${Einformixv6als::not_alpha};
598             ${Einformixv6als::not_ascii} = ${Einformixv6als::not_ascii};
599             ${Einformixv6als::not_blank} = ${Einformixv6als::not_blank};
600             ${Einformixv6als::not_cntrl} = ${Einformixv6als::not_cntrl};
601             ${Einformixv6als::not_digit} = ${Einformixv6als::not_digit};
602             ${Einformixv6als::not_graph} = ${Einformixv6als::not_graph};
603             ${Einformixv6als::not_lower} = ${Einformixv6als::not_lower};
604             ${Einformixv6als::not_lower_i} = ${Einformixv6als::not_lower_i};
605             ${Einformixv6als::not_print} = ${Einformixv6als::not_print};
606             ${Einformixv6als::not_punct} = ${Einformixv6als::not_punct};
607             ${Einformixv6als::not_space} = ${Einformixv6als::not_space};
608             ${Einformixv6als::not_upper} = ${Einformixv6als::not_upper};
609             ${Einformixv6als::not_upper_i} = ${Einformixv6als::not_upper_i};
610             ${Einformixv6als::not_word} = ${Einformixv6als::not_word};
611             ${Einformixv6als::not_xdigit} = ${Einformixv6als::not_xdigit};
612             ${Einformixv6als::eb} = ${Einformixv6als::eb};
613             ${Einformixv6als::eB} = ${Einformixv6als::eB};
614              
615             #
616             # INFORMIX V6 ALS split
617             #
618             sub Einformixv6als::split(;$$$) {
619              
620             # P.794 29.2.161. split
621             # in Chapter 29: Functions
622             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
623              
624             # P.951 split
625             # in Chapter 27: Functions
626             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
627              
628 5     0 0 11546 my $pattern = $_[0];
629 0         0 my $string = $_[1];
630 0         0 my $limit = $_[2];
631              
632             # if $pattern is also omitted or is the literal space, " "
633 0 0       0 if (not defined $pattern) {
634 0         0 $pattern = ' ';
635             }
636              
637             # if $string is omitted, the function splits the $_ string
638 0 0       0 if (not defined $string) {
639 0 0       0 if (defined $_) {
640 0         0 $string = $_;
641             }
642             else {
643 0         0 $string = '';
644             }
645             }
646              
647 0         0 my @split = ();
648              
649             # when string is empty
650 0 0       0 if ($string eq '') {
    0          
651              
652             # resulting list value in list context
653 0 0       0 if (wantarray) {
654 0         0 return @split;
655             }
656              
657             # count of substrings in scalar context
658             else {
659 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
660 0         0 @_ = @split;
661 0         0 return scalar @_;
662             }
663             }
664              
665             # split's first argument is more consistently interpreted
666             #
667             # After some changes earlier in v5.17, split's behavior has been simplified:
668             # if the PATTERN argument evaluates to a string containing one space, it is
669             # treated the way that a literal string containing one space once was.
670             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
671              
672             # if $pattern is also omitted or is the literal space, " ", the function splits
673             # on whitespace, /\s+/, after skipping any leading whitespace
674             # (and so on)
675              
676             elsif ($pattern eq ' ') {
677 0 0       0 if (not defined $limit) {
678 0         0 return CORE::split(' ', $string);
679             }
680             else {
681 0         0 return CORE::split(' ', $string, $limit);
682             }
683             }
684              
685 0         0 local $q_char = $q_char;
686 0 0       0 if (CORE::length($string) > 32766) {
687 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
688 0         0 $q_char = qr{.}s;
689             }
690             elsif (defined ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
691 0         0 $q_char = ${Einformixv6als::q_char_SADAHIRO_Tomoyuki_2002_01_17};
692             }
693             }
694              
695             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
696 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
697              
698             # a pattern capable of matching either the null string or something longer than the
699             # null string will split the value of $string into separate characters wherever it
700             # matches the null string between characters
701             # (and so on)
702              
703 0 0       0 if ('' =~ / \A $pattern \z /xms) {
704 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
705 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
706              
707             # P.1024 Appendix W.10 Multibyte Processing
708             # of ISBN 1-56592-224-7 CJKV Information Processing
709             # (and so on)
710              
711             # the //m modifier is assumed when you split on the pattern /^/
712             # (and so on)
713              
714             # V
715 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
716              
717             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
718             # is included in the resulting list, interspersed with the fields that are ordinarily returned
719             # (and so on)
720              
721 0         0 local $@;
722 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
723 0         0 push @split, CORE::eval('$' . $digit);
724             }
725             }
726             }
727              
728             else {
729 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
730              
731             # V
732 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
733 0         0 local $@;
734 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
735 0         0 push @split, CORE::eval('$' . $digit);
736             }
737             }
738             }
739             }
740              
741             elsif ($limit > 0) {
742 0 0       0 if ('' =~ / \A $pattern \z /xms) {
743 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
744 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
745              
746             # V
747 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
748 0         0 local $@;
749 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
750 0         0 push @split, CORE::eval('$' . $digit);
751             }
752             }
753             }
754             }
755             else {
756 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
757 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
758              
759             # V
760 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
761 0         0 local $@;
762 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
763 0         0 push @split, CORE::eval('$' . $digit);
764             }
765             }
766             }
767             }
768             }
769              
770 0 0       0 if (CORE::length($string) > 0) {
771 0         0 push @split, $string;
772             }
773              
774             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
775 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
776 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
777 0         0 pop @split;
778             }
779             }
780              
781             # resulting list value in list context
782 0 0       0 if (wantarray) {
783 0         0 return @split;
784             }
785              
786             # count of substrings in scalar context
787             else {
788 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
789 0         0 @_ = @split;
790 0         0 return scalar @_;
791             }
792             }
793              
794             #
795             # get last subexpression offsets
796             #
797             sub _last_subexpression_offsets {
798 0     0   0 my $pattern = $_[0];
799              
800             # remove comment
801 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
802              
803 0         0 my $modifier = '';
804 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
805 0         0 $modifier = $1;
806 0         0 $modifier =~ s/-[A-Za-z]*//;
807             }
808              
809             # with /x modifier
810 0         0 my @char = ();
811 0 0       0 if ($modifier =~ /x/oxms) {
812 0         0 @char = $pattern =~ /\G((?>
813             [^\x81-\x9F\xE0-\xFD\\\#\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
814             \\ $q_char |
815             \# (?>[^\n]*) $ |
816             \[ (?>(?:[^\x81-\x9F\xE0-\xFD\\\]]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
817             \(\? |
818             $q_char
819             ))/oxmsg;
820             }
821              
822             # without /x modifier
823             else {
824 0         0 @char = $pattern =~ /\G((?>
825             [^\x81-\x9F\xE0-\xFD\\\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
826             \\ $q_char |
827             \[ (?>(?:[^\x81-\x9F\xE0-\xFD\\\]]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
828             \(\? |
829             $q_char
830             ))/oxmsg;
831             }
832              
833 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
834             }
835              
836             #
837             # INFORMIX V6 ALS transliteration (tr///)
838             #
839             sub Einformixv6als::tr($$$$;$) {
840              
841 0     0 0 0 my $bind_operator = $_[1];
842 0         0 my $searchlist = $_[2];
843 0         0 my $replacementlist = $_[3];
844 0   0     0 my $modifier = $_[4] || '';
845              
846 0 0       0 if ($modifier =~ /r/oxms) {
847 0 0       0 if ($bind_operator =~ / !~ /oxms) {
848 0         0 croak "Using !~ with tr///r doesn't make sense";
849             }
850             }
851              
852 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
853 0         0 my @searchlist = _charlist_tr($searchlist);
854 0         0 my @replacementlist = _charlist_tr($replacementlist);
855              
856 0         0 my %tr = ();
857 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
858 0 0       0 if (not exists $tr{$searchlist[$i]}) {
859 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
860 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
861             }
862             elsif ($modifier =~ /d/oxms) {
863 0         0 $tr{$searchlist[$i]} = '';
864             }
865             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
866 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
867             }
868             else {
869 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
870             }
871             }
872             }
873              
874 0         0 my $tr = 0;
875 0         0 my $replaced = '';
876 0 0       0 if ($modifier =~ /c/oxms) {
877 0         0 while (defined(my $char = shift @char)) {
878 0 0       0 if (not exists $tr{$char}) {
879 0 0       0 if (defined $replacementlist[0]) {
880 0         0 $replaced .= $replacementlist[0];
881             }
882 0         0 $tr++;
883 0 0       0 if ($modifier =~ /s/oxms) {
884 0   0     0 while (@char and (not exists $tr{$char[0]})) {
885 0         0 shift @char;
886 0         0 $tr++;
887             }
888             }
889             }
890             else {
891 0         0 $replaced .= $char;
892             }
893             }
894             }
895             else {
896 0         0 while (defined(my $char = shift @char)) {
897 0 0       0 if (exists $tr{$char}) {
898 0         0 $replaced .= $tr{$char};
899 0         0 $tr++;
900 0 0       0 if ($modifier =~ /s/oxms) {
901 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
902 0         0 shift @char;
903 0         0 $tr++;
904             }
905             }
906             }
907             else {
908 0         0 $replaced .= $char;
909             }
910             }
911             }
912              
913 0 0       0 if ($modifier =~ /r/oxms) {
914 0         0 return $replaced;
915             }
916             else {
917 0         0 $_[0] = $replaced;
918 0 0       0 if ($bind_operator =~ / !~ /oxms) {
919 0         0 return not $tr;
920             }
921             else {
922 0         0 return $tr;
923             }
924             }
925             }
926              
927             #
928             # INFORMIX V6 ALS chop
929             #
930             sub Einformixv6als::chop(@) {
931              
932 0     0 0 0 my $chop;
933 0 0       0 if (@_ == 0) {
934 0         0 my @char = /\G (?>$q_char) /oxmsg;
935 0         0 $chop = pop @char;
936 0         0 $_ = join '', @char;
937             }
938             else {
939 0         0 for (@_) {
940 0         0 my @char = /\G (?>$q_char) /oxmsg;
941 0         0 $chop = pop @char;
942 0         0 $_ = join '', @char;
943             }
944             }
945 0         0 return $chop;
946             }
947              
948             #
949             # INFORMIX V6 ALS index by octet
950             #
951             sub Einformixv6als::index($$;$) {
952              
953 0     2304 1 0 my($str,$substr,$position) = @_;
954 2304   50     5089 $position ||= 0;
955 2304         8827 my $pos = 0;
956              
957 2304         3165 while ($pos < CORE::length($str)) {
958 2304 50       5338 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
959 73608 0       113308 if ($pos >= $position) {
960 0         0 return $pos;
961             }
962             }
963 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
964 73608         176710 $pos += CORE::length($1);
965             }
966             else {
967 73608         144122 $pos += 1;
968             }
969             }
970 0         0 return -1;
971             }
972              
973             #
974             # INFORMIX V6 ALS reverse index
975             #
976             sub Einformixv6als::rindex($$;$) {
977              
978 2304     0 0 13890 my($str,$substr,$position) = @_;
979 0   0     0 $position ||= CORE::length($str) - 1;
980 0         0 my $pos = 0;
981 0         0 my $rindex = -1;
982              
983 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
984 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
985 0         0 $rindex = $pos;
986             }
987 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
988 0         0 $pos += CORE::length($1);
989             }
990             else {
991 0         0 $pos += 1;
992             }
993             }
994 0         0 return $rindex;
995             }
996              
997             #
998             # INFORMIX V6 ALS lower case first with parameter
999             #
1000             sub Einformixv6als::lcfirst(@) {
1001 0 0   0 0 0 if (@_) {
1002 0         0 my $s = shift @_;
1003 0 0 0     0 if (@_ and wantarray) {
1004 0         0 return Einformixv6als::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1005             }
1006             else {
1007 0         0 return Einformixv6als::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1008             }
1009             }
1010             else {
1011 0         0 return Einformixv6als::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1012             }
1013             }
1014              
1015             #
1016             # INFORMIX V6 ALS lower case first without parameter
1017             #
1018             sub Einformixv6als::lcfirst_() {
1019 0     0 0 0 return Einformixv6als::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1020             }
1021              
1022             #
1023             # INFORMIX V6 ALS lower case with parameter
1024             #
1025             sub Einformixv6als::lc(@) {
1026 0 0   0 0 0 if (@_) {
1027 0         0 my $s = shift @_;
1028 0 0 0     0 if (@_ and wantarray) {
1029 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1030             }
1031             else {
1032 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1033             }
1034             }
1035             else {
1036 0         0 return Einformixv6als::lc_();
1037             }
1038             }
1039              
1040             #
1041             # INFORMIX V6 ALS lower case without parameter
1042             #
1043             sub Einformixv6als::lc_() {
1044 0     0 0 0 my $s = $_;
1045 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1046             }
1047              
1048             #
1049             # INFORMIX V6 ALS upper case first with parameter
1050             #
1051             sub Einformixv6als::ucfirst(@) {
1052 0 0   0 0 0 if (@_) {
1053 0         0 my $s = shift @_;
1054 0 0 0     0 if (@_ and wantarray) {
1055 0         0 return Einformixv6als::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1056             }
1057             else {
1058 0         0 return Einformixv6als::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1059             }
1060             }
1061             else {
1062 0         0 return Einformixv6als::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1063             }
1064             }
1065              
1066             #
1067             # INFORMIX V6 ALS upper case first without parameter
1068             #
1069             sub Einformixv6als::ucfirst_() {
1070 0     0 0 0 return Einformixv6als::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1071             }
1072              
1073             #
1074             # INFORMIX V6 ALS upper case with parameter
1075             #
1076             sub Einformixv6als::uc(@) {
1077 0 50   3618 0 0 if (@_) {
1078 3618         5151 my $s = shift @_;
1079 3618 50 33     4555 if (@_ and wantarray) {
1080 3618 0       6169 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1081             }
1082             else {
1083 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3618         9836  
1084             }
1085             }
1086             else {
1087 3618         11353 return Einformixv6als::uc_();
1088             }
1089             }
1090              
1091             #
1092             # INFORMIX V6 ALS upper case without parameter
1093             #
1094             sub Einformixv6als::uc_() {
1095 0     0 0 0 my $s = $_;
1096 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1097             }
1098              
1099             #
1100             # INFORMIX V6 ALS fold case with parameter
1101             #
1102             sub Einformixv6als::fc(@) {
1103 0 50   3921 0 0 if (@_) {
1104 3921         5390 my $s = shift @_;
1105 3921 50 33     4641 if (@_ and wantarray) {
1106 3921 0       6537 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1107             }
1108             else {
1109 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3921         9499  
1110             }
1111             }
1112             else {
1113 3921         29806 return Einformixv6als::fc_();
1114             }
1115             }
1116              
1117             #
1118             # INFORMIX V6 ALS fold case without parameter
1119             #
1120             sub Einformixv6als::fc_() {
1121 0     0 0 0 my $s = $_;
1122 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1123             }
1124              
1125             #
1126             # INFORMIX V6 ALS regexp capture
1127             #
1128             {
1129             # 10.3. Creating Persistent Private Variables
1130             # in Chapter 10. Subroutines
1131             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1132              
1133             my $last_s_matched = 0;
1134              
1135             sub Einformixv6als::capture {
1136 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1137 0         0 return $_[0] + 1;
1138             }
1139 0         0 return $_[0];
1140             }
1141              
1142             # INFORMIX V6 ALS mark last regexp matched
1143             sub Einformixv6als::matched() {
1144 0     0 0 0 $last_s_matched = 0;
1145             }
1146              
1147             # INFORMIX V6 ALS mark last s/// matched
1148             sub Einformixv6als::s_matched() {
1149 0     0 0 0 $last_s_matched = 1;
1150             }
1151              
1152             # P.854 31.17. use re
1153             # in Chapter 31. Pragmatic Modules
1154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1155              
1156             # P.1026 re
1157             # in Chapter 29. Pragmatic Modules
1158             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1159              
1160             $Einformixv6als::matched = qr/(?{Einformixv6als::matched})/;
1161             }
1162              
1163             #
1164             # INFORMIX V6 ALS regexp ignore case modifier
1165             #
1166             sub Einformixv6als::ignorecase {
1167              
1168 0     0 0 0 my @string = @_;
1169 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1170              
1171             # ignore case of $scalar or @array
1172 0         0 for my $string (@string) {
1173              
1174             # split regexp
1175 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1176              
1177             # unescape character
1178 0         0 for (my $i=0; $i <= $#char; $i++) {
1179 0 0       0 next if not defined $char[$i];
1180              
1181             # open character class [...]
1182 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1183 0         0 my $left = $i;
1184              
1185             # [] make die "unmatched [] in regexp ...\n"
1186              
1187 0 0       0 if ($char[$i+1] eq ']') {
1188 0         0 $i++;
1189             }
1190              
1191 0         0 while (1) {
1192 0 0       0 if (++$i > $#char) {
1193 0         0 croak "Unmatched [] in regexp";
1194             }
1195 0 0       0 if ($char[$i] eq ']') {
1196 0         0 my $right = $i;
1197 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1198              
1199             # escape character
1200 0         0 for my $char (@charlist) {
1201 0 0       0 if (0) {
    0          
1202             }
1203              
1204             # do not use quotemeta here
1205 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1206 0         0 $char = $1 . '\\' . $2;
1207             }
1208             elsif ($char =~ /\A [.|)] \z/oxms) {
1209 0         0 $char = '\\' . $char;
1210             }
1211             }
1212              
1213             # [...]
1214 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1215              
1216 0         0 $i = $left;
1217 0         0 last;
1218             }
1219             }
1220             }
1221              
1222             # open character class [^...]
1223             elsif ($char[$i] eq '[^') {
1224 0         0 my $left = $i;
1225              
1226             # [^] make die "unmatched [] in regexp ...\n"
1227              
1228 0 0       0 if ($char[$i+1] eq ']') {
1229 0         0 $i++;
1230             }
1231              
1232 0         0 while (1) {
1233 0 0       0 if (++$i > $#char) {
1234 0         0 croak "Unmatched [] in regexp";
1235             }
1236 0 0       0 if ($char[$i] eq ']') {
1237 0         0 my $right = $i;
1238 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1239              
1240             # escape character
1241 0         0 for my $char (@charlist) {
1242 0 0       0 if (0) {
    0          
1243             }
1244              
1245             # do not use quotemeta here
1246 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1247 0         0 $char = $1 . '\\' . $2;
1248             }
1249             elsif ($char =~ /\A [.|)] \z/oxms) {
1250 0         0 $char = '\\' . $char;
1251             }
1252             }
1253              
1254             # [^...]
1255 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1256              
1257 0         0 $i = $left;
1258 0         0 last;
1259             }
1260             }
1261             }
1262              
1263             # rewrite classic character class or escape character
1264             elsif (my $char = classic_character_class($char[$i])) {
1265 0         0 $char[$i] = $char;
1266             }
1267              
1268             # with /i modifier
1269             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1270 0         0 my $uc = Einformixv6als::uc($char[$i]);
1271 0         0 my $fc = Einformixv6als::fc($char[$i]);
1272 0 0       0 if ($uc ne $fc) {
1273 0 0       0 if (CORE::length($fc) == 1) {
1274 0         0 $char[$i] = '[' . $uc . $fc . ']';
1275             }
1276             else {
1277 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1278             }
1279             }
1280             }
1281             }
1282              
1283             # characterize
1284 0         0 for (my $i=0; $i <= $#char; $i++) {
1285 0 0       0 next if not defined $char[$i];
1286              
1287 0 0 0     0 if (0) {
    0          
1288             }
1289              
1290             # escape last octet of multiple-octet
1291 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1292 0         0 $char[$i] = $1 . '\\' . $2;
1293             }
1294              
1295             # quote character before ? + * {
1296             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1297 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1298 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1299             }
1300             }
1301             }
1302              
1303 0         0 $string = join '', @char;
1304             }
1305              
1306             # make regexp string
1307 0         0 return @string;
1308             }
1309              
1310             #
1311             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1312             #
1313             sub Einformixv6als::classic_character_class {
1314 0     5227 0 0 my($char) = @_;
1315              
1316             return {
1317             '\D' => '${Einformixv6als::eD}',
1318             '\S' => '${Einformixv6als::eS}',
1319             '\W' => '${Einformixv6als::eW}',
1320             '\d' => '[0-9]',
1321              
1322             # Before Perl 5.6, \s only matched the five whitespace characters
1323             # tab, newline, form-feed, carriage return, and the space character
1324             # itself, which, taken together, is the character class [\t\n\f\r ].
1325              
1326             # Vertical tabs are now whitespace
1327             # \s in a regex now matches a vertical tab in all circumstances.
1328             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1329             # \t \n \v \f \r space
1330             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1331             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1332             '\s' => '\s',
1333              
1334             '\w' => '[0-9A-Z_a-z]',
1335             '\C' => '[\x00-\xFF]',
1336             '\X' => 'X',
1337              
1338             # \h \v \H \V
1339              
1340             # P.114 Character Class Shortcuts
1341             # in Chapter 7: In the World of Regular Expressions
1342             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1343              
1344             # P.357 13.2.3 Whitespace
1345             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1346             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1347             #
1348             # 0x00009 CHARACTER TABULATION h s
1349             # 0x0000a LINE FEED (LF) vs
1350             # 0x0000b LINE TABULATION v
1351             # 0x0000c FORM FEED (FF) vs
1352             # 0x0000d CARRIAGE RETURN (CR) vs
1353             # 0x00020 SPACE h s
1354              
1355             # P.196 Table 5-9. Alphanumeric regex metasymbols
1356             # in Chapter 5. Pattern Matching
1357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1358              
1359             # (and so on)
1360              
1361             '\H' => '${Einformixv6als::eH}',
1362             '\V' => '${Einformixv6als::eV}',
1363             '\h' => '[\x09\x20]',
1364             '\v' => '[\x0A\x0B\x0C\x0D]',
1365             '\R' => '${Einformixv6als::eR}',
1366              
1367             # \N
1368             #
1369             # http://perldoc.perl.org/perlre.html
1370             # Character Classes and other Special Escapes
1371             # Any character but \n (experimental). Not affected by /s modifier
1372              
1373             '\N' => '${Einformixv6als::eN}',
1374              
1375             # \b \B
1376              
1377             # P.180 Boundaries: The \b and \B Assertions
1378             # in Chapter 5: Pattern Matching
1379             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1380              
1381             # P.219 Boundaries: The \b and \B Assertions
1382             # in Chapter 5: Pattern Matching
1383             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1384              
1385             # \b really means (?:(?<=\w)(?!\w)|(?
1386             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1387             '\b' => '${Einformixv6als::eb}',
1388              
1389             # \B really means (?:(?<=\w)(?=\w)|(?
1390             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1391             '\B' => '${Einformixv6als::eB}',
1392              
1393 5227   100     7505 }->{$char} || '';
1394             }
1395              
1396             #
1397             # prepare INFORMIX V6 ALS characters per length
1398             #
1399              
1400             # 1 octet characters
1401             my @chars1 = ();
1402             sub chars1 {
1403 5227 0   0 0 169572 if (@chars1) {
1404 0         0 return @chars1;
1405             }
1406 0 0       0 if (exists $range_tr{1}) {
1407 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1408 0         0 while (my @range = splice(@ranges,0,1)) {
1409 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1410 0         0 push @chars1, pack 'C', $oct0;
1411             }
1412             }
1413             }
1414 0         0 return @chars1;
1415             }
1416              
1417             # 2 octets characters
1418             my @chars2 = ();
1419             sub chars2 {
1420 0 0   0 0 0 if (@chars2) {
1421 0         0 return @chars2;
1422             }
1423 0 0       0 if (exists $range_tr{2}) {
1424 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1425 0         0 while (my @range = splice(@ranges,0,2)) {
1426 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1427 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1428 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1429             }
1430             }
1431             }
1432             }
1433 0         0 return @chars2;
1434             }
1435              
1436             # 3 octets characters
1437             my @chars3 = ();
1438             sub chars3 {
1439 0 0   0 0 0 if (@chars3) {
1440 0         0 return @chars3;
1441             }
1442 0 0       0 if (exists $range_tr{3}) {
1443 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1444 0         0 while (my @range = splice(@ranges,0,3)) {
1445 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1446 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1447 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1448 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1449             }
1450             }
1451             }
1452             }
1453             }
1454 0         0 return @chars3;
1455             }
1456              
1457             # 4 octets characters
1458             my @chars4 = ();
1459             sub chars4 {
1460 0 0   0 0 0 if (@chars4) {
1461 0         0 return @chars4;
1462             }
1463 0 0       0 if (exists $range_tr{4}) {
1464 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1465 0         0 while (my @range = splice(@ranges,0,4)) {
1466 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1467 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1468 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1469 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1470 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1471             }
1472             }
1473             }
1474             }
1475             }
1476             }
1477 0         0 return @chars4;
1478             }
1479              
1480             #
1481             # INFORMIX V6 ALS open character list for tr
1482             #
1483             sub _charlist_tr {
1484              
1485 0     0   0 local $_ = shift @_;
1486              
1487             # unescape character
1488 0         0 my @char = ();
1489 0         0 while (not /\G \z/oxmsgc) {
1490 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1491 0         0 push @char, '\-';
1492             }
1493             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1494 0         0 push @char, CORE::chr(oct $1);
1495             }
1496             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1497 0         0 push @char, CORE::chr(hex $1);
1498             }
1499             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1500 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1501             }
1502             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1503             push @char, {
1504             '\0' => "\0",
1505             '\n' => "\n",
1506             '\r' => "\r",
1507             '\t' => "\t",
1508             '\f' => "\f",
1509             '\b' => "\x08", # \b means backspace in character class
1510             '\a' => "\a",
1511             '\e' => "\e",
1512 0         0 }->{$1};
1513             }
1514             elsif (/\G \\ ($q_char) /oxmsgc) {
1515 0         0 push @char, $1;
1516             }
1517             elsif (/\G ($q_char) /oxmsgc) {
1518 0         0 push @char, $1;
1519             }
1520             }
1521              
1522             # join separated multiple-octet
1523 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1524              
1525             # unescape '-'
1526 0         0 my @i = ();
1527 0         0 for my $i (0 .. $#char) {
1528 0 0       0 if ($char[$i] eq '\-') {
    0          
1529 0         0 $char[$i] = '-';
1530             }
1531             elsif ($char[$i] eq '-') {
1532 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1533 0         0 push @i, $i;
1534             }
1535             }
1536             }
1537              
1538             # open character list (reverse for splice)
1539 0         0 for my $i (CORE::reverse @i) {
1540 0         0 my @range = ();
1541              
1542             # range error
1543 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1544 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1545             }
1546              
1547             # range of multiple-octet code
1548 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1549 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1550 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1551             }
1552             elsif (CORE::length($char[$i+1]) == 2) {
1553 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1554 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1555             }
1556             elsif (CORE::length($char[$i+1]) == 3) {
1557 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1558 0         0 push @range, chars2();
1559 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1560             }
1561             elsif (CORE::length($char[$i+1]) == 4) {
1562 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1563 0         0 push @range, chars2();
1564 0         0 push @range, chars3();
1565 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1566             }
1567             else {
1568 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1569             }
1570             }
1571             elsif (CORE::length($char[$i-1]) == 2) {
1572 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1573 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1574             }
1575             elsif (CORE::length($char[$i+1]) == 3) {
1576 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1577 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1578             }
1579             elsif (CORE::length($char[$i+1]) == 4) {
1580 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1581 0         0 push @range, chars3();
1582 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1583             }
1584             else {
1585 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1586             }
1587             }
1588             elsif (CORE::length($char[$i-1]) == 3) {
1589 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1590 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1591             }
1592             elsif (CORE::length($char[$i+1]) == 4) {
1593 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1594 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1595             }
1596             else {
1597 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1598             }
1599             }
1600             elsif (CORE::length($char[$i-1]) == 4) {
1601 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1602 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1603             }
1604             else {
1605 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1606             }
1607             }
1608             else {
1609 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1610             }
1611              
1612 0         0 splice @char, $i-1, 3, @range;
1613             }
1614              
1615 0         0 return @char;
1616             }
1617              
1618             #
1619             # INFORMIX V6 ALS open character class
1620             #
1621             sub _cc {
1622 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1623 604         1216 die __FILE__, ": subroutine cc got no parameter.\n";
1624             }
1625             elsif (scalar(@_) == 1) {
1626 0         0 return sprintf('\x%02X',$_[0]);
1627             }
1628             elsif (scalar(@_) == 2) {
1629 302 50       943 if ($_[0] > $_[1]) {
    50          
    50          
1630 302         692 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1631             }
1632             elsif ($_[0] == $_[1]) {
1633 0         0 return sprintf('\x%02X',$_[0]);
1634             }
1635             elsif (($_[0]+1) == $_[1]) {
1636 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1637             }
1638             else {
1639 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1640             }
1641             }
1642             else {
1643 302         1414 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1644             }
1645             }
1646              
1647             #
1648             # INFORMIX V6 ALS octet range
1649             #
1650             sub _octets {
1651 0     688   0 my $length = shift @_;
1652              
1653 688 100       1101 if ($length == 1) {
    50          
    0          
    0          
1654 688         1464 my($a1) = unpack 'C', $_[0];
1655 426         1098 my($z1) = unpack 'C', $_[1];
1656              
1657 426 50       845 if ($a1 > $z1) {
1658 426         928 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1659             }
1660              
1661 0 50       0 if ($a1 == $z1) {
    100          
1662 426         1051 return sprintf('\x%02X',$a1);
1663             }
1664             elsif (($a1+1) == $z1) {
1665 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1666             }
1667             else {
1668 20         75 return sprintf('\x%02X-\x%02X',$a1,$z1);
1669             }
1670             }
1671             elsif ($length == 2) {
1672 406         2408 my($a1,$a2) = unpack 'CC', $_[0];
1673 262         563 my($z1,$z2) = unpack 'CC', $_[1];
1674 262         459 my($A1,$A2) = unpack 'CC', $_[2];
1675 262         398 my($Z1,$Z2) = unpack 'CC', $_[3];
1676              
1677 262 100       382 if ($a1 == $z1) {
    50          
1678             return (
1679             # 11111111 222222222222
1680             # A A Z
1681 262         443 _cc($a1) . _cc($a2,$z2), # a2-z2
1682             );
1683             }
1684             elsif (($a1+1) == $z1) {
1685             return (
1686             # 11111111111 222222222222
1687             # A Z A Z
1688 222         345 _cc($a1) . _cc($a2,$Z2), # a2-
1689             _cc( $z1) . _cc($A2,$z2), # -z2
1690             );
1691             }
1692             else {
1693             return (
1694             # 1111111111111111 222222222222
1695             # A Z A Z
1696 40         61 _cc($a1) . _cc($a2,$Z2), # a2-
1697             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1698             _cc( $z1) . _cc($A2,$z2), # -z2
1699             );
1700             }
1701             }
1702             elsif ($length == 3) {
1703 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1704 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1705 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1706 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1707              
1708 0 0       0 if ($a1 == $z1) {
    0          
1709 0 0       0 if ($a2 == $z2) {
    0          
1710             return (
1711             # 11111111 22222222 333333333333
1712             # A A A Z
1713 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1714             );
1715             }
1716             elsif (($a2+1) == $z2) {
1717             return (
1718             # 11111111 22222222222 333333333333
1719             # A A Z A Z
1720 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1721             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1722             );
1723             }
1724             else {
1725             return (
1726             # 11111111 2222222222222222 333333333333
1727             # A A Z A Z
1728 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1729             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1730             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1731             );
1732             }
1733             }
1734             elsif (($a1+1) == $z1) {
1735             return (
1736             # 11111111111 22222222222222 333333333333
1737             # A Z A Z A Z
1738 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1739             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1740             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1741             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1742             );
1743             }
1744             else {
1745             return (
1746             # 1111111111111111 22222222222222 333333333333
1747             # A Z A Z A Z
1748 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1749             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1750             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1751             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1752             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1753             );
1754             }
1755             }
1756             elsif ($length == 4) {
1757 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1758 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1759 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1760 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1761              
1762 0 0       0 if ($a1 == $z1) {
    0          
1763 0 0       0 if ($a2 == $z2) {
    0          
1764 0 0       0 if ($a3 == $z3) {
    0          
1765             return (
1766             # 11111111 22222222 33333333 444444444444
1767             # A A A A Z
1768 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1769             );
1770             }
1771             elsif (($a3+1) == $z3) {
1772             return (
1773             # 11111111 22222222 33333333333 444444444444
1774             # A A A Z A Z
1775 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1776             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1777             );
1778             }
1779             else {
1780             return (
1781             # 11111111 22222222 3333333333333333 444444444444
1782             # A A A Z A Z
1783 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1784             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1785             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1786             );
1787             }
1788             }
1789             elsif (($a2+1) == $z2) {
1790             return (
1791             # 11111111 22222222222 33333333333333 444444444444
1792             # A A Z A Z A Z
1793 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1794             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1795             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1796             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1797             );
1798             }
1799             else {
1800             return (
1801             # 11111111 2222222222222222 33333333333333 444444444444
1802             # A A Z A Z A Z
1803 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1804             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1805             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1806             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1807             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1808             );
1809             }
1810             }
1811             elsif (($a1+1) == $z1) {
1812             return (
1813             # 11111111111 22222222222222 33333333333333 444444444444
1814             # A Z A Z A Z A Z
1815 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1816             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1817             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1818             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1819             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1820             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1821             );
1822             }
1823             else {
1824             return (
1825             # 1111111111111111 22222222222222 33333333333333 444444444444
1826             # A Z A Z A Z A Z
1827 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1828             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1829             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1830             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1831             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1832             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1833             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1834             );
1835             }
1836             }
1837             else {
1838 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1839             }
1840             }
1841              
1842             #
1843             # INFORMIX V6 ALS range regexp
1844             #
1845             sub _range_regexp {
1846 0     517   0 my($length,$first,$last) = @_;
1847              
1848 517         1120 my @range_regexp = ();
1849 517 50       772 if (not exists $range_tr{$length}) {
1850 517         1277 return @range_regexp;
1851             }
1852              
1853 0         0 my @ranges = @{ $range_tr{$length} };
  517         726  
1854 517         1205 while (my @range = splice(@ranges,0,$length)) {
1855 517         1587 my $min = '';
1856 1682         2433 my $max = '';
1857 1682         1903 for (my $i=0; $i < $length; $i++) {
1858 1682         2776 $min .= pack 'C', $range[$i][0];
1859 2206         4222 $max .= pack 'C', $range[$i][-1];
1860             }
1861              
1862             # min___max
1863             # FIRST_____________LAST
1864             # (nothing)
1865              
1866 2206 50 66     4163 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1867             }
1868              
1869             # **********
1870             # min_________max
1871             # FIRST_____________LAST
1872             # **********
1873              
1874             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1875 1682         13521 push @range_regexp, _octets($length,$first,$max,$min,$max);
1876             }
1877              
1878             # **********************
1879             # min________________max
1880             # FIRST_____________LAST
1881             # **********************
1882              
1883             elsif (($min eq $first) and ($max eq $last)) {
1884 20         54 push @range_regexp, _octets($length,$first,$last,$min,$max);
1885             }
1886              
1887             # *********
1888             # min___max
1889             # FIRST_____________LAST
1890             # *********
1891              
1892             elsif (($first le $min) and ($max le $last)) {
1893 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1894             }
1895              
1896             # **********************
1897             # min__________________________max
1898             # FIRST_____________LAST
1899             # **********************
1900              
1901             elsif (($min le $first) and ($last le $max)) {
1902 40         68 push @range_regexp, _octets($length,$first,$last,$min,$max);
1903             }
1904              
1905             # *********
1906             # min________max
1907             # FIRST_____________LAST
1908             # *********
1909              
1910             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1911 588         1353 push @range_regexp, _octets($length,$min,$last,$min,$max);
1912             }
1913              
1914             # min___max
1915             # FIRST_____________LAST
1916             # (nothing)
1917              
1918             elsif ($last lt $min) {
1919             }
1920              
1921             else {
1922 40         63 die __FILE__, ": subroutine _range_regexp panic.\n";
1923             }
1924             }
1925              
1926 0         0 return @range_regexp;
1927             }
1928              
1929             #
1930             # INFORMIX V6 ALS open character list for qr and not qr
1931             #
1932             sub _charlist {
1933              
1934 517     758   1312 my $modifier = pop @_;
1935 758         1248 my @char = @_;
1936              
1937 758 100       1698 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1938              
1939             # unescape character
1940 758         1824 for (my $i=0; $i <= $#char; $i++) {
1941              
1942             # escape - to ...
1943 758 100 100     2492 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1944 2648 100 100     19032 if ((0 < $i) and ($i < $#char)) {
1945 522         1921 $char[$i] = '...';
1946             }
1947             }
1948              
1949             # octal escape sequence
1950             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1951 497         1057 $char[$i] = octchr($1);
1952             }
1953              
1954             # hexadecimal escape sequence
1955             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1956 0         0 $char[$i] = hexchr($1);
1957             }
1958              
1959             # \b{...} --> b\{...}
1960             # \B{...} --> B\{...}
1961             # \N{CHARNAME} --> N\{CHARNAME}
1962             # \p{PROPERTY} --> p\{PROPERTY}
1963             # \P{PROPERTY} --> P\{PROPERTY}
1964             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
1965 0         0 $char[$i] = $1 . '\\' . $2;
1966             }
1967              
1968             # \p, \P, \X --> p, P, X
1969             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1970 0         0 $char[$i] = $1;
1971             }
1972              
1973             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1974 0         0 $char[$i] = CORE::chr oct $1;
1975             }
1976             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1977 0         0 $char[$i] = CORE::chr hex $1;
1978             }
1979             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1980 206         790 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1981             }
1982             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1983             $char[$i] = {
1984             '\0' => "\0",
1985             '\n' => "\n",
1986             '\r' => "\r",
1987             '\t' => "\t",
1988             '\f' => "\f",
1989             '\b' => "\x08", # \b means backspace in character class
1990             '\a' => "\a",
1991             '\e' => "\e",
1992             '\d' => '[0-9]',
1993              
1994             # Vertical tabs are now whitespace
1995             # \s in a regex now matches a vertical tab in all circumstances.
1996             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1997             # \t \n \v \f \r space
1998             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1999             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
2000             '\s' => '\s',
2001              
2002             '\w' => '[0-9A-Z_a-z]',
2003             '\D' => '${Einformixv6als::eD}',
2004             '\S' => '${Einformixv6als::eS}',
2005             '\W' => '${Einformixv6als::eW}',
2006              
2007             '\H' => '${Einformixv6als::eH}',
2008             '\V' => '${Einformixv6als::eV}',
2009             '\h' => '[\x09\x20]',
2010             '\v' => '[\x0A\x0B\x0C\x0D]',
2011             '\R' => '${Einformixv6als::eR}',
2012              
2013 0         0 }->{$1};
2014             }
2015              
2016             # POSIX-style character classes
2017             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2018             $char[$i] = {
2019              
2020             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2021             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2022             '[:^lower:]' => '${Einformixv6als::not_lower_i}',
2023             '[:^upper:]' => '${Einformixv6als::not_upper_i}',
2024              
2025 33         489 }->{$1};
2026             }
2027             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2028             $char[$i] = {
2029              
2030             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2031             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2032             '[:ascii:]' => '[\x00-\x7F]',
2033             '[:blank:]' => '[\x09\x20]',
2034             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2035             '[:digit:]' => '[\x30-\x39]',
2036             '[:graph:]' => '[\x21-\x7F]',
2037             '[:lower:]' => '[\x61-\x7A]',
2038             '[:print:]' => '[\x20-\x7F]',
2039             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2040              
2041             # P.174 POSIX-Style Character Classes
2042             # in Chapter 5: Pattern Matching
2043             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2044              
2045             # P.311 11.2.4 Character Classes and other Special Escapes
2046             # in Chapter 11: perlre: Perl regular expressions
2047             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2048              
2049             # P.210 POSIX-Style Character Classes
2050             # in Chapter 5: Pattern Matching
2051             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2052              
2053             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2054              
2055             '[:upper:]' => '[\x41-\x5A]',
2056             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2057             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2058             '[:^alnum:]' => '${Einformixv6als::not_alnum}',
2059             '[:^alpha:]' => '${Einformixv6als::not_alpha}',
2060             '[:^ascii:]' => '${Einformixv6als::not_ascii}',
2061             '[:^blank:]' => '${Einformixv6als::not_blank}',
2062             '[:^cntrl:]' => '${Einformixv6als::not_cntrl}',
2063             '[:^digit:]' => '${Einformixv6als::not_digit}',
2064             '[:^graph:]' => '${Einformixv6als::not_graph}',
2065             '[:^lower:]' => '${Einformixv6als::not_lower}',
2066             '[:^print:]' => '${Einformixv6als::not_print}',
2067             '[:^punct:]' => '${Einformixv6als::not_punct}',
2068             '[:^space:]' => '${Einformixv6als::not_space}',
2069             '[:^upper:]' => '${Einformixv6als::not_upper}',
2070             '[:^word:]' => '${Einformixv6als::not_word}',
2071             '[:^xdigit:]' => '${Einformixv6als::not_xdigit}',
2072              
2073 8         159 }->{$1};
2074             }
2075             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2076 70         1917 $char[$i] = $1;
2077             }
2078             }
2079              
2080             # open character list
2081 7         33 my @singleoctet = ();
2082 758         1285 my @multipleoctet = ();
2083 758         1021 for (my $i=0; $i <= $#char; ) {
2084              
2085             # escaped -
2086 758 100 100     1759 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2087 2151         8873 $i += 1;
2088 497         737 next;
2089             }
2090              
2091             # make range regexp
2092             elsif ($char[$i] eq '...') {
2093              
2094             # range error
2095 497 50       959 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2096 497         1814 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2097             }
2098             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2099 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2100 477         1074 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2101             }
2102             }
2103              
2104             # make range regexp per length
2105 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2106 497         1384 my @regexp = ();
2107              
2108             # is first and last
2109 517 100 100     709 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2110 517         2015 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2111             }
2112              
2113             # is first
2114             elsif ($length == CORE::length($char[$i-1])) {
2115 477         1304 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2116             }
2117              
2118             # is inside in first and last
2119             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2120 20         68 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2121             }
2122              
2123             # is last
2124             elsif ($length == CORE::length($char[$i+1])) {
2125 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2126             }
2127              
2128             else {
2129 20         96 die __FILE__, ": subroutine make_regexp panic.\n";
2130             }
2131              
2132 0 100       0 if ($length == 1) {
2133 517         1027 push @singleoctet, @regexp;
2134             }
2135             else {
2136 386         924 push @multipleoctet, @regexp;
2137             }
2138             }
2139              
2140 131         292 $i += 2;
2141             }
2142              
2143             # with /i modifier
2144             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2145 497 100       1161 if ($modifier =~ /i/oxms) {
2146 764         1499 my $uc = Einformixv6als::uc($char[$i]);
2147 192         308 my $fc = Einformixv6als::fc($char[$i]);
2148 192 50       312 if ($uc ne $fc) {
2149 192 50       317 if (CORE::length($fc) == 1) {
2150 192         270 push @singleoctet, $uc, $fc;
2151             }
2152             else {
2153 192         341 push @singleoctet, $uc;
2154 0         0 push @multipleoctet, $fc;
2155             }
2156             }
2157             else {
2158 0         0 push @singleoctet, $char[$i];
2159             }
2160             }
2161             else {
2162 0         0 push @singleoctet, $char[$i];
2163             }
2164 572         913 $i += 1;
2165             }
2166              
2167             # single character of single octet code
2168             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2169 764         1549 push @singleoctet, "\t", "\x20";
2170 0         0 $i += 1;
2171             }
2172             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2173 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2174 0         0 $i += 1;
2175             }
2176             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2177 0         0 push @singleoctet, $char[$i];
2178 2         6 $i += 1;
2179             }
2180              
2181             # single character of multiple-octet code
2182             else {
2183 2         5 push @multipleoctet, $char[$i];
2184 391         716 $i += 1;
2185             }
2186             }
2187              
2188             # quote metachar
2189 391         696 for (@singleoctet) {
2190 758 50       1609 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2191 1384         6199 $_ = '-';
2192             }
2193             elsif (/\A \n \z/oxms) {
2194 0         0 $_ = '\n';
2195             }
2196             elsif (/\A \r \z/oxms) {
2197 8         16 $_ = '\r';
2198             }
2199             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2200 8         17 $_ = sprintf('\x%02X', CORE::ord $1);
2201             }
2202             elsif (/\A [\x00-\xFF] \z/oxms) {
2203 1         5 $_ = quotemeta $_;
2204             }
2205             }
2206 939         1664 for (@multipleoctet) {
2207 758 100       1529 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2208 693         1892 $_ = $1 . quotemeta $2;
2209             }
2210             }
2211              
2212             # return character list
2213 307         833 return \@singleoctet, \@multipleoctet;
2214             }
2215              
2216             #
2217             # INFORMIX V6 ALS octal escape sequence
2218             #
2219             sub octchr {
2220 758     5 0 2750 my($octdigit) = @_;
2221              
2222 5         15 my @binary = ();
2223 5         7 for my $octal (split(//,$octdigit)) {
2224             push @binary, {
2225             '0' => '000',
2226             '1' => '001',
2227             '2' => '010',
2228             '3' => '011',
2229             '4' => '100',
2230             '5' => '101',
2231             '6' => '110',
2232             '7' => '111',
2233 5         23 }->{$octal};
2234             }
2235 50         180 my $binary = join '', @binary;
2236              
2237             my $octchr = {
2238             # 1234567
2239             1 => pack('B*', "0000000$binary"),
2240             2 => pack('B*', "000000$binary"),
2241             3 => pack('B*', "00000$binary"),
2242             4 => pack('B*', "0000$binary"),
2243             5 => pack('B*', "000$binary"),
2244             6 => pack('B*', "00$binary"),
2245             7 => pack('B*', "0$binary"),
2246             0 => pack('B*', "$binary"),
2247              
2248 5         16 }->{CORE::length($binary) % 8};
2249              
2250 5         59 return $octchr;
2251             }
2252              
2253             #
2254             # INFORMIX V6 ALS hexadecimal escape sequence
2255             #
2256             sub hexchr {
2257 5     5 0 20 my($hexdigit) = @_;
2258              
2259             my $hexchr = {
2260             1 => pack('H*', "0$hexdigit"),
2261             0 => pack('H*', "$hexdigit"),
2262              
2263 5         16 }->{CORE::length($_[0]) % 2};
2264              
2265 5         45 return $hexchr;
2266             }
2267              
2268             #
2269             # INFORMIX V6 ALS open character list for qr
2270             #
2271             sub charlist_qr {
2272              
2273 5     519 0 16 my $modifier = pop @_;
2274 519         1339 my @char = @_;
2275              
2276 519         1484 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2277 519         1701 my @singleoctet = @$singleoctet;
2278 519         1118 my @multipleoctet = @$multipleoctet;
2279              
2280             # return character list
2281 519 100       964 if (scalar(@singleoctet) >= 1) {
2282              
2283             # with /i modifier
2284 519 100       1193 if ($modifier =~ m/i/oxms) {
2285 384         985 my %singleoctet_ignorecase = ();
2286 107         154 for (@singleoctet) {
2287 107   100     194 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2288 277         899 for my $ord (hex($1) .. hex($2)) {
2289 90         300 my $char = CORE::chr($ord);
2290 1371         1937 my $uc = Einformixv6als::uc($char);
2291 1371         2049 my $fc = Einformixv6als::fc($char);
2292 1371 100       1982 if ($uc eq $fc) {
2293 1371         2041 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2294             }
2295             else {
2296 782 50       1692 if (CORE::length($fc) == 1) {
2297 589         814 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2298 589         1114 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2299             }
2300             else {
2301 589         1429 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2302 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2303             }
2304             }
2305             }
2306             }
2307 0 100       0 if ($_ ne '') {
2308 277         462 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2309             }
2310             }
2311 192         444 my $i = 0;
2312 107         142 my @singleoctet_ignorecase = ();
2313 107         143 for my $ord (0 .. 255) {
2314 107 100       311 if (exists $singleoctet_ignorecase{$ord}) {
2315 27392         33346 push @{$singleoctet_ignorecase[$i]}, $ord;
  1902         2095  
2316             }
2317             else {
2318 1902         3184 $i++;
2319             }
2320             }
2321 25490         27000 @singleoctet = ();
2322 107         181 for my $range (@singleoctet_ignorecase) {
2323 107 100       270 if (ref $range) {
2324 11087 50       19438 if (scalar(@{$range}) == 1) {
  219 100       232  
2325 219         604 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2326             }
2327 0         0 elsif (scalar(@{$range}) == 2) {
2328 219         318 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  5         8  
  5         6  
2329             }
2330             else {
2331 5         90 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  214         245  
  214         254  
2332             }
2333             }
2334             }
2335             }
2336              
2337 214         1199 my $not_anchor = '';
2338 384         945 $not_anchor = '(?![\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE])';
2339              
2340 384         709 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2341             }
2342 384 100       1499 if (scalar(@multipleoctet) >= 2) {
2343 519         1242 return '(?:' . join('|', @multipleoctet) . ')';
2344             }
2345             else {
2346 131         784 return $multipleoctet[0];
2347             }
2348             }
2349              
2350             #
2351             # INFORMIX V6 ALS open character list for not qr
2352             #
2353             sub charlist_not_qr {
2354              
2355 388     239 0 1752 my $modifier = pop @_;
2356 239         419 my @char = @_;
2357              
2358 239         551 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2359 239         505 my @singleoctet = @$singleoctet;
2360 239         468 my @multipleoctet = @$multipleoctet;
2361              
2362             # with /i modifier
2363 239 100       393 if ($modifier =~ m/i/oxms) {
2364 239         516 my %singleoctet_ignorecase = ();
2365 128         193 for (@singleoctet) {
2366 128   100     168 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2367 277         906 for my $ord (hex($1) .. hex($2)) {
2368 90         293 my $char = CORE::chr($ord);
2369 1371         1858 my $uc = Einformixv6als::uc($char);
2370 1371         1802 my $fc = Einformixv6als::fc($char);
2371 1371 100       1986 if ($uc eq $fc) {
2372 1371         2009 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2373             }
2374             else {
2375 782 50       1734 if (CORE::length($fc) == 1) {
2376 589         737 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2377 589         1212 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2378             }
2379             else {
2380 589         1345 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2381 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2382             }
2383             }
2384             }
2385             }
2386 0 100       0 if ($_ ne '') {
2387 277         490 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2388             }
2389             }
2390 192         427 my $i = 0;
2391 128         169 my @singleoctet_ignorecase = ();
2392 128         163 for my $ord (0 .. 255) {
2393 128 100       208 if (exists $singleoctet_ignorecase{$ord}) {
2394 32768         40337 push @{$singleoctet_ignorecase[$i]}, $ord;
  1902         1841  
2395             }
2396             else {
2397 1902         2937 $i++;
2398             }
2399             }
2400 30866         32551 @singleoctet = ();
2401 128         192 for my $range (@singleoctet_ignorecase) {
2402 128 100       271 if (ref $range) {
2403 11087 50       19335 if (scalar(@{$range}) == 1) {
  219 100       225  
2404 219         338 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2405             }
2406 0         0 elsif (scalar(@{$range}) == 2) {
2407 219         378 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  5         14  
  5         8  
2408             }
2409             else {
2410 5         90 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  214         264  
  214         256  
2411             }
2412             }
2413             }
2414             }
2415              
2416             # return character list
2417 214 100       967 if (scalar(@multipleoctet) >= 1) {
2418 239 100       544 if (scalar(@singleoctet) >= 1) {
2419              
2420             # any character other than multiple-octet and single octet character class
2421 114         314 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\x9F\xE0-\xFD' . join('', @singleoctet) . ']|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])';
2422             }
2423             else {
2424              
2425             # any character other than multiple-octet character class
2426 70         473 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2427             }
2428             }
2429             else {
2430 44 50       337 if (scalar(@singleoctet) >= 1) {
2431              
2432             # any character other than single octet character class
2433 125         210 return '(?:[^\x81-\x9F\xE0-\xFD' . join('', @singleoctet) . ']|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])';
2434             }
2435             else {
2436              
2437             # any character
2438 125         703 return "(?:$your_char)";
2439             }
2440             }
2441             }
2442              
2443             #
2444             # open file in read mode
2445             #
2446             sub _open_r {
2447 0     768   0 my(undef,$file) = @_;
2448 389     389   7285 use Fcntl qw(O_RDONLY);
  389         993  
  389         63351  
2449 768         2362 return CORE::sysopen($_[0], $file, &O_RDONLY);
2450             }
2451              
2452             #
2453             # open file in append mode
2454             #
2455             sub _open_a {
2456 768     384   32181 my(undef,$file) = @_;
2457 389     389   2783 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         5836  
  389         5624550  
2458 384         1277 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2459             }
2460              
2461             #
2462             # safe system
2463             #
2464             sub _systemx {
2465              
2466             # P.707 29.2.33. exec
2467             # in Chapter 29: Functions
2468             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2469             #
2470             # Be aware that in older releases of Perl, exec (and system) did not flush
2471             # your output buffer, so you needed to enable command buffering by setting $|
2472             # on one or more filehandles to avoid lost output in the case of exec, or
2473             # misordererd output in the case of system. This situation was largely remedied
2474             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2475              
2476             # P.855 exec
2477             # in Chapter 27: Functions
2478             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2479             #
2480             # In very old release of Perl (before v5.6), exec (and system) did not flush
2481             # your output buffer, so you needed to enable command buffering by setting $|
2482             # on one or more filehandles to avoid lost output with exec or misordered
2483             # output with system.
2484              
2485 384     384   58087 $| = 1;
2486              
2487             # P.565 23.1.2. Cleaning Up Your Environment
2488             # in Chapter 23: Security
2489             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2490              
2491             # P.656 Cleaning Up Your Environment
2492             # in Chapter 20: Security
2493             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2494              
2495             # local $ENV{'PATH'} = '.';
2496 384         1486 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2497              
2498             # P.707 29.2.33. exec
2499             # in Chapter 29: Functions
2500             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2501             #
2502             # As we mentioned earlier, exec treats a discrete list of arguments as an
2503             # indication that it should bypass shell processing. However, there is one
2504             # place where you might still get tripped up. The exec call (and system, too)
2505             # will not distinguish between a single scalar argument and an array containing
2506             # only one element.
2507             #
2508             # @args = ("echo surprise"); # just one element in list
2509             # exec @args # still subject to shell escapes
2510             # or die "exec: $!"; # because @args == 1
2511             #
2512             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2513             # first argument as the pathname, which forces the rest of the arguments to be
2514             # interpreted as a list, even if there is only one of them:
2515             #
2516             # exec { $args[0] } @args # safe even with one-argument list
2517             # or die "can't exec @args: $!";
2518              
2519             # P.855 exec
2520             # in Chapter 27: Functions
2521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2522             #
2523             # As we mentioned earlier, exec treats a discrete list of arguments as a
2524             # directive to bypass shell processing. However, there is one place where
2525             # you might still get tripped up. The exec call (and system, too) cannot
2526             # distinguish between a single scalar argument and an array containing
2527             # only one element.
2528             #
2529             # @args = ("echo surprise"); # just one element in list
2530             # exec @args # still subject to shell escapes
2531             # || die "exec: $!"; # because @args == 1
2532             #
2533             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2534             # argument as the pathname, which forces the rest of the arguments to be
2535             # interpreted as a list, even if there is only one of them:
2536             #
2537             # exec { $args[0] } @args # safe even with one-argument list
2538             # || die "can't exec @args: $!";
2539              
2540 384         3448 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         945  
2541             }
2542              
2543             #
2544             # INFORMIX V6 ALS order to character (with parameter)
2545             #
2546             sub Einformixv6als::chr(;$) {
2547              
2548 384 0   0 0 52086016 my $c = @_ ? $_[0] : $_;
2549              
2550 0 0       0 if ($c == 0x00) {
2551 0         0 return "\x00";
2552             }
2553             else {
2554 0         0 my @chr = ();
2555 0         0 while ($c > 0) {
2556 0         0 unshift @chr, ($c % 0x100);
2557 0         0 $c = int($c / 0x100);
2558             }
2559 0         0 return pack 'C*', @chr;
2560             }
2561             }
2562              
2563             #
2564             # INFORMIX V6 ALS order to character (without parameter)
2565             #
2566             sub Einformixv6als::chr_() {
2567              
2568 0     0 0 0 my $c = $_;
2569              
2570 0 0       0 if ($c == 0x00) {
2571 0         0 return "\x00";
2572             }
2573             else {
2574 0         0 my @chr = ();
2575 0         0 while ($c > 0) {
2576 0         0 unshift @chr, ($c % 0x100);
2577 0         0 $c = int($c / 0x100);
2578             }
2579 0         0 return pack 'C*', @chr;
2580             }
2581             }
2582              
2583             #
2584             # INFORMIX V6 ALS stacked file test expr
2585             #
2586             sub Einformixv6als::filetest {
2587              
2588 0     0 0 0 my $file = pop @_;
2589 0         0 my $filetest = substr(pop @_, 1);
2590              
2591 0 0       0 unless (CORE::eval qq{Einformixv6als::$filetest(\$file)}) {
2592 0         0 return '';
2593             }
2594 0         0 for my $filetest (CORE::reverse @_) {
2595 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2596 0         0 return '';
2597             }
2598             }
2599 0         0 return 1;
2600             }
2601              
2602             #
2603             # INFORMIX V6 ALS file test -r expr
2604             #
2605             sub Einformixv6als::r(;*@) {
2606              
2607 0 0   0 0 0 local $_ = shift if @_;
2608 0 0 0     0 croak 'Too many arguments for -r (Einformixv6als::r)' if @_ and not wantarray;
2609              
2610 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2611 0 0       0 return wantarray ? (-r _,@_) : -r _;
2612             }
2613              
2614             # P.908 32.39. Symbol
2615             # in Chapter 32: Standard Modules
2616             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2617              
2618             # P.326 Prototypes
2619             # in Chapter 7: Subroutines
2620             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2621              
2622             # (and so on)
2623              
2624             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2625 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2626             }
2627             elsif (-e $_) {
2628 0 0       0 return wantarray ? (-r _,@_) : -r _;
2629             }
2630             elsif (_MSWin32_5Cended_path($_)) {
2631 0 0       0 if (-d "$_/.") {
2632 0 0       0 return wantarray ? (-r _,@_) : -r _;
2633             }
2634             else {
2635              
2636             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Einformixv6als::*()
2637             # on Windows opens the file for the path which has 5c at end.
2638             # (and so on)
2639              
2640 0         0 my $fh = gensym();
2641 0 0       0 if (_open_r($fh, $_)) {
2642 0         0 my $r = -r $fh;
2643 0         0 close $fh;
2644 0 0       0 return wantarray ? ($r,@_) : $r;
2645             }
2646             }
2647             }
2648 0 0       0 return wantarray ? (undef,@_) : undef;
2649             }
2650              
2651             #
2652             # INFORMIX V6 ALS file test -w expr
2653             #
2654             sub Einformixv6als::w(;*@) {
2655              
2656 0 0   0 0 0 local $_ = shift if @_;
2657 0 0 0     0 croak 'Too many arguments for -w (Einformixv6als::w)' if @_ and not wantarray;
2658              
2659 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2660 0 0       0 return wantarray ? (-w _,@_) : -w _;
2661             }
2662             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2663 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2664             }
2665             elsif (-e $_) {
2666 0 0       0 return wantarray ? (-w _,@_) : -w _;
2667             }
2668             elsif (_MSWin32_5Cended_path($_)) {
2669 0 0       0 if (-d "$_/.") {
2670 0 0       0 return wantarray ? (-w _,@_) : -w _;
2671             }
2672             else {
2673 0         0 my $fh = gensym();
2674 0 0       0 if (_open_a($fh, $_)) {
2675 0         0 my $w = -w $fh;
2676 0         0 close $fh;
2677 0 0       0 return wantarray ? ($w,@_) : $w;
2678             }
2679             }
2680             }
2681 0 0       0 return wantarray ? (undef,@_) : undef;
2682             }
2683              
2684             #
2685             # INFORMIX V6 ALS file test -x expr
2686             #
2687             sub Einformixv6als::x(;*@) {
2688              
2689 0 0   0 0 0 local $_ = shift if @_;
2690 0 0 0     0 croak 'Too many arguments for -x (Einformixv6als::x)' if @_ and not wantarray;
2691              
2692 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2693 0 0       0 return wantarray ? (-x _,@_) : -x _;
2694             }
2695             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2696 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2697             }
2698             elsif (-e $_) {
2699 0 0       0 return wantarray ? (-x _,@_) : -x _;
2700             }
2701             elsif (_MSWin32_5Cended_path($_)) {
2702 0 0       0 if (-d "$_/.") {
2703 0 0       0 return wantarray ? (-x _,@_) : -x _;
2704             }
2705             else {
2706 0         0 my $fh = gensym();
2707 0 0       0 if (_open_r($fh, $_)) {
2708 0         0 my $dummy_for_underline_cache = -x $fh;
2709 0         0 close $fh;
2710             }
2711              
2712             # filename is not .COM .EXE .BAT .CMD
2713 0 0       0 return wantarray ? ('',@_) : '';
2714             }
2715             }
2716 0 0       0 return wantarray ? (undef,@_) : undef;
2717             }
2718              
2719             #
2720             # INFORMIX V6 ALS file test -o expr
2721             #
2722             sub Einformixv6als::o(;*@) {
2723              
2724 0 0   0 0 0 local $_ = shift if @_;
2725 0 0 0     0 croak 'Too many arguments for -o (Einformixv6als::o)' if @_ and not wantarray;
2726              
2727 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2728 0 0       0 return wantarray ? (-o _,@_) : -o _;
2729             }
2730             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2731 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2732             }
2733             elsif (-e $_) {
2734 0 0       0 return wantarray ? (-o _,@_) : -o _;
2735             }
2736             elsif (_MSWin32_5Cended_path($_)) {
2737 0 0       0 if (-d "$_/.") {
2738 0 0       0 return wantarray ? (-o _,@_) : -o _;
2739             }
2740             else {
2741 0         0 my $fh = gensym();
2742 0 0       0 if (_open_r($fh, $_)) {
2743 0         0 my $o = -o $fh;
2744 0         0 close $fh;
2745 0 0       0 return wantarray ? ($o,@_) : $o;
2746             }
2747             }
2748             }
2749 0 0       0 return wantarray ? (undef,@_) : undef;
2750             }
2751              
2752             #
2753             # INFORMIX V6 ALS file test -R expr
2754             #
2755             sub Einformixv6als::R(;*@) {
2756              
2757 0 0   0 0 0 local $_ = shift if @_;
2758 0 0 0     0 croak 'Too many arguments for -R (Einformixv6als::R)' if @_ and not wantarray;
2759              
2760 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2761 0 0       0 return wantarray ? (-R _,@_) : -R _;
2762             }
2763             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2764 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2765             }
2766             elsif (-e $_) {
2767 0 0       0 return wantarray ? (-R _,@_) : -R _;
2768             }
2769             elsif (_MSWin32_5Cended_path($_)) {
2770 0 0       0 if (-d "$_/.") {
2771 0 0       0 return wantarray ? (-R _,@_) : -R _;
2772             }
2773             else {
2774 0         0 my $fh = gensym();
2775 0 0       0 if (_open_r($fh, $_)) {
2776 0         0 my $R = -R $fh;
2777 0         0 close $fh;
2778 0 0       0 return wantarray ? ($R,@_) : $R;
2779             }
2780             }
2781             }
2782 0 0       0 return wantarray ? (undef,@_) : undef;
2783             }
2784              
2785             #
2786             # INFORMIX V6 ALS file test -W expr
2787             #
2788             sub Einformixv6als::W(;*@) {
2789              
2790 0 0   0 0 0 local $_ = shift if @_;
2791 0 0 0     0 croak 'Too many arguments for -W (Einformixv6als::W)' if @_ and not wantarray;
2792              
2793 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2794 0 0       0 return wantarray ? (-W _,@_) : -W _;
2795             }
2796             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2797 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2798             }
2799             elsif (-e $_) {
2800 0 0       0 return wantarray ? (-W _,@_) : -W _;
2801             }
2802             elsif (_MSWin32_5Cended_path($_)) {
2803 0 0       0 if (-d "$_/.") {
2804 0 0       0 return wantarray ? (-W _,@_) : -W _;
2805             }
2806             else {
2807 0         0 my $fh = gensym();
2808 0 0       0 if (_open_a($fh, $_)) {
2809 0         0 my $W = -W $fh;
2810 0         0 close $fh;
2811 0 0       0 return wantarray ? ($W,@_) : $W;
2812             }
2813             }
2814             }
2815 0 0       0 return wantarray ? (undef,@_) : undef;
2816             }
2817              
2818             #
2819             # INFORMIX V6 ALS file test -X expr
2820             #
2821             sub Einformixv6als::X(;*@) {
2822              
2823 0 0   0 1 0 local $_ = shift if @_;
2824 0 0 0     0 croak 'Too many arguments for -X (Einformixv6als::X)' if @_ and not wantarray;
2825              
2826 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2827 0 0       0 return wantarray ? (-X _,@_) : -X _;
2828             }
2829             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2830 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2831             }
2832             elsif (-e $_) {
2833 0 0       0 return wantarray ? (-X _,@_) : -X _;
2834             }
2835             elsif (_MSWin32_5Cended_path($_)) {
2836 0 0       0 if (-d "$_/.") {
2837 0 0       0 return wantarray ? (-X _,@_) : -X _;
2838             }
2839             else {
2840 0         0 my $fh = gensym();
2841 0 0       0 if (_open_r($fh, $_)) {
2842 0         0 my $dummy_for_underline_cache = -X $fh;
2843 0         0 close $fh;
2844             }
2845              
2846             # filename is not .COM .EXE .BAT .CMD
2847 0 0       0 return wantarray ? ('',@_) : '';
2848             }
2849             }
2850 0 0       0 return wantarray ? (undef,@_) : undef;
2851             }
2852              
2853             #
2854             # INFORMIX V6 ALS file test -O expr
2855             #
2856             sub Einformixv6als::O(;*@) {
2857              
2858 0 0   0 0 0 local $_ = shift if @_;
2859 0 0 0     0 croak 'Too many arguments for -O (Einformixv6als::O)' if @_ and not wantarray;
2860              
2861 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2862 0 0       0 return wantarray ? (-O _,@_) : -O _;
2863             }
2864             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2865 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2866             }
2867             elsif (-e $_) {
2868 0 0       0 return wantarray ? (-O _,@_) : -O _;
2869             }
2870             elsif (_MSWin32_5Cended_path($_)) {
2871 0 0       0 if (-d "$_/.") {
2872 0 0       0 return wantarray ? (-O _,@_) : -O _;
2873             }
2874             else {
2875 0         0 my $fh = gensym();
2876 0 0       0 if (_open_r($fh, $_)) {
2877 0         0 my $O = -O $fh;
2878 0         0 close $fh;
2879 0 0       0 return wantarray ? ($O,@_) : $O;
2880             }
2881             }
2882             }
2883 0 0       0 return wantarray ? (undef,@_) : undef;
2884             }
2885              
2886             #
2887             # INFORMIX V6 ALS file test -e expr
2888             #
2889             sub Einformixv6als::e(;*@) {
2890              
2891 0 50   768 0 0 local $_ = shift if @_;
2892 768 50 33     3084 croak 'Too many arguments for -e (Einformixv6als::e)' if @_ and not wantarray;
2893              
2894 768         3151 local $^W = 0;
2895              
2896 768         2668 my $fh = qualify_to_ref $_;
2897 768 50       2074 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2898 768 0       3283 return wantarray ? (-e _,@_) : -e _;
2899             }
2900              
2901             # return false if directory handle
2902             elsif (defined Einformixv6als::telldir($fh)) {
2903 0 0       0 return wantarray ? ('',@_) : '';
2904             }
2905              
2906             # return true if file handle
2907             elsif (defined fileno $fh) {
2908 0 0       0 return wantarray ? (1,@_) : 1;
2909             }
2910              
2911             elsif (-e $_) {
2912 0 0       0 return wantarray ? (1,@_) : 1;
2913             }
2914             elsif (_MSWin32_5Cended_path($_)) {
2915 0 0       0 if (-d "$_/.") {
2916 0 0       0 return wantarray ? (1,@_) : 1;
2917             }
2918             else {
2919 0         0 my $fh = gensym();
2920 0 0       0 if (_open_r($fh, $_)) {
2921 0         0 my $e = -e $fh;
2922 0         0 close $fh;
2923 0 0       0 return wantarray ? ($e,@_) : $e;
2924             }
2925             }
2926             }
2927 0 50       0 return wantarray ? (undef,@_) : undef;
2928             }
2929              
2930             #
2931             # INFORMIX V6 ALS file test -z expr
2932             #
2933             sub Einformixv6als::z(;*@) {
2934              
2935 768 0   0 0 4354 local $_ = shift if @_;
2936 0 0 0     0 croak 'Too many arguments for -z (Einformixv6als::z)' if @_ and not wantarray;
2937              
2938 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2939 0 0       0 return wantarray ? (-z _,@_) : -z _;
2940             }
2941             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2942 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2943             }
2944             elsif (-e $_) {
2945 0 0       0 return wantarray ? (-z _,@_) : -z _;
2946             }
2947             elsif (_MSWin32_5Cended_path($_)) {
2948 0 0       0 if (-d "$_/.") {
2949 0 0       0 return wantarray ? (-z _,@_) : -z _;
2950             }
2951             else {
2952 0         0 my $fh = gensym();
2953 0 0       0 if (_open_r($fh, $_)) {
2954 0         0 my $z = -z $fh;
2955 0         0 close $fh;
2956 0 0       0 return wantarray ? ($z,@_) : $z;
2957             }
2958             }
2959             }
2960 0 0       0 return wantarray ? (undef,@_) : undef;
2961             }
2962              
2963             #
2964             # INFORMIX V6 ALS file test -s expr
2965             #
2966             sub Einformixv6als::s(;*@) {
2967              
2968 0 0   0 0 0 local $_ = shift if @_;
2969 0 0 0     0 croak 'Too many arguments for -s (Einformixv6als::s)' if @_ and not wantarray;
2970              
2971 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2972 0 0       0 return wantarray ? (-s _,@_) : -s _;
2973             }
2974             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2975 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2976             }
2977             elsif (-e $_) {
2978 0 0       0 return wantarray ? (-s _,@_) : -s _;
2979             }
2980             elsif (_MSWin32_5Cended_path($_)) {
2981 0 0       0 if (-d "$_/.") {
2982 0 0       0 return wantarray ? (-s _,@_) : -s _;
2983             }
2984             else {
2985 0         0 my $fh = gensym();
2986 0 0       0 if (_open_r($fh, $_)) {
2987 0         0 my $s = -s $fh;
2988 0         0 close $fh;
2989 0 0       0 return wantarray ? ($s,@_) : $s;
2990             }
2991             }
2992             }
2993 0 0       0 return wantarray ? (undef,@_) : undef;
2994             }
2995              
2996             #
2997             # INFORMIX V6 ALS file test -f expr
2998             #
2999             sub Einformixv6als::f(;*@) {
3000              
3001 0 0   0 0 0 local $_ = shift if @_;
3002 0 0 0     0 croak 'Too many arguments for -f (Einformixv6als::f)' if @_ and not wantarray;
3003              
3004 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3005 0 0       0 return wantarray ? (-f _,@_) : -f _;
3006             }
3007             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3008 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
3009             }
3010             elsif (-e $_) {
3011 0 0       0 return wantarray ? (-f _,@_) : -f _;
3012             }
3013             elsif (_MSWin32_5Cended_path($_)) {
3014 0 0       0 if (-d "$_/.") {
3015 0 0       0 return wantarray ? ('',@_) : '';
3016             }
3017             else {
3018 0         0 my $fh = gensym();
3019 0 0       0 if (_open_r($fh, $_)) {
3020 0         0 my $f = -f $fh;
3021 0         0 close $fh;
3022 0 0       0 return wantarray ? ($f,@_) : $f;
3023             }
3024             }
3025             }
3026 0 0       0 return wantarray ? (undef,@_) : undef;
3027             }
3028              
3029             #
3030             # INFORMIX V6 ALS file test -d expr
3031             #
3032             sub Einformixv6als::d(;*@) {
3033              
3034 0 0   0 0 0 local $_ = shift if @_;
3035 0 0 0     0 croak 'Too many arguments for -d (Einformixv6als::d)' if @_ and not wantarray;
3036              
3037 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3038 0 0       0 return wantarray ? (-d _,@_) : -d _;
3039             }
3040              
3041             # return false if file handle or directory handle
3042             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3043 0 0       0 return wantarray ? ('',@_) : '';
3044             }
3045             elsif (-e $_) {
3046 0 0       0 return wantarray ? (-d _,@_) : -d _;
3047             }
3048             elsif (_MSWin32_5Cended_path($_)) {
3049 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3050             }
3051 0 0       0 return wantarray ? (undef,@_) : undef;
3052             }
3053              
3054             #
3055             # INFORMIX V6 ALS file test -l expr
3056             #
3057             sub Einformixv6als::l(;*@) {
3058              
3059 0 0   0 0 0 local $_ = shift if @_;
3060 0 0 0     0 croak 'Too many arguments for -l (Einformixv6als::l)' if @_ and not wantarray;
3061              
3062 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3063 0 0       0 return wantarray ? (-l _,@_) : -l _;
3064             }
3065             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3066 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3067             }
3068             elsif (-e $_) {
3069 0 0       0 return wantarray ? (-l _,@_) : -l _;
3070             }
3071             elsif (_MSWin32_5Cended_path($_)) {
3072 0 0       0 if (-d "$_/.") {
3073 0 0       0 return wantarray ? (-l _,@_) : -l _;
3074             }
3075             else {
3076 0         0 my $fh = gensym();
3077 0 0       0 if (_open_r($fh, $_)) {
3078 0         0 my $l = -l $fh;
3079 0         0 close $fh;
3080 0 0       0 return wantarray ? ($l,@_) : $l;
3081             }
3082             }
3083             }
3084 0 0       0 return wantarray ? (undef,@_) : undef;
3085             }
3086              
3087             #
3088             # INFORMIX V6 ALS file test -p expr
3089             #
3090             sub Einformixv6als::p(;*@) {
3091              
3092 0 0   0 0 0 local $_ = shift if @_;
3093 0 0 0     0 croak 'Too many arguments for -p (Einformixv6als::p)' if @_ and not wantarray;
3094              
3095 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3096 0 0       0 return wantarray ? (-p _,@_) : -p _;
3097             }
3098             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3099 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3100             }
3101             elsif (-e $_) {
3102 0 0       0 return wantarray ? (-p _,@_) : -p _;
3103             }
3104             elsif (_MSWin32_5Cended_path($_)) {
3105 0 0       0 if (-d "$_/.") {
3106 0 0       0 return wantarray ? (-p _,@_) : -p _;
3107             }
3108             else {
3109 0         0 my $fh = gensym();
3110 0 0       0 if (_open_r($fh, $_)) {
3111 0         0 my $p = -p $fh;
3112 0         0 close $fh;
3113 0 0       0 return wantarray ? ($p,@_) : $p;
3114             }
3115             }
3116             }
3117 0 0       0 return wantarray ? (undef,@_) : undef;
3118             }
3119              
3120             #
3121             # INFORMIX V6 ALS file test -S expr
3122             #
3123             sub Einformixv6als::S(;*@) {
3124              
3125 0 0   0 0 0 local $_ = shift if @_;
3126 0 0 0     0 croak 'Too many arguments for -S (Einformixv6als::S)' if @_ and not wantarray;
3127              
3128 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3129 0 0       0 return wantarray ? (-S _,@_) : -S _;
3130             }
3131             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3132 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3133             }
3134             elsif (-e $_) {
3135 0 0       0 return wantarray ? (-S _,@_) : -S _;
3136             }
3137             elsif (_MSWin32_5Cended_path($_)) {
3138 0 0       0 if (-d "$_/.") {
3139 0 0       0 return wantarray ? (-S _,@_) : -S _;
3140             }
3141             else {
3142 0         0 my $fh = gensym();
3143 0 0       0 if (_open_r($fh, $_)) {
3144 0         0 my $S = -S $fh;
3145 0         0 close $fh;
3146 0 0       0 return wantarray ? ($S,@_) : $S;
3147             }
3148             }
3149             }
3150 0 0       0 return wantarray ? (undef,@_) : undef;
3151             }
3152              
3153             #
3154             # INFORMIX V6 ALS file test -b expr
3155             #
3156             sub Einformixv6als::b(;*@) {
3157              
3158 0 0   0 0 0 local $_ = shift if @_;
3159 0 0 0     0 croak 'Too many arguments for -b (Einformixv6als::b)' if @_ and not wantarray;
3160              
3161 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3162 0 0       0 return wantarray ? (-b _,@_) : -b _;
3163             }
3164             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3165 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3166             }
3167             elsif (-e $_) {
3168 0 0       0 return wantarray ? (-b _,@_) : -b _;
3169             }
3170             elsif (_MSWin32_5Cended_path($_)) {
3171 0 0       0 if (-d "$_/.") {
3172 0 0       0 return wantarray ? (-b _,@_) : -b _;
3173             }
3174             else {
3175 0         0 my $fh = gensym();
3176 0 0       0 if (_open_r($fh, $_)) {
3177 0         0 my $b = -b $fh;
3178 0         0 close $fh;
3179 0 0       0 return wantarray ? ($b,@_) : $b;
3180             }
3181             }
3182             }
3183 0 0       0 return wantarray ? (undef,@_) : undef;
3184             }
3185              
3186             #
3187             # INFORMIX V6 ALS file test -c expr
3188             #
3189             sub Einformixv6als::c(;*@) {
3190              
3191 0 0   0 0 0 local $_ = shift if @_;
3192 0 0 0     0 croak 'Too many arguments for -c (Einformixv6als::c)' if @_ and not wantarray;
3193              
3194 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3195 0 0       0 return wantarray ? (-c _,@_) : -c _;
3196             }
3197             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3198 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3199             }
3200             elsif (-e $_) {
3201 0 0       0 return wantarray ? (-c _,@_) : -c _;
3202             }
3203             elsif (_MSWin32_5Cended_path($_)) {
3204 0 0       0 if (-d "$_/.") {
3205 0 0       0 return wantarray ? (-c _,@_) : -c _;
3206             }
3207             else {
3208 0         0 my $fh = gensym();
3209 0 0       0 if (_open_r($fh, $_)) {
3210 0         0 my $c = -c $fh;
3211 0         0 close $fh;
3212 0 0       0 return wantarray ? ($c,@_) : $c;
3213             }
3214             }
3215             }
3216 0 0       0 return wantarray ? (undef,@_) : undef;
3217             }
3218              
3219             #
3220             # INFORMIX V6 ALS file test -u expr
3221             #
3222             sub Einformixv6als::u(;*@) {
3223              
3224 0 0   0 0 0 local $_ = shift if @_;
3225 0 0 0     0 croak 'Too many arguments for -u (Einformixv6als::u)' if @_ and not wantarray;
3226              
3227 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3228 0 0       0 return wantarray ? (-u _,@_) : -u _;
3229             }
3230             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3231 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3232             }
3233             elsif (-e $_) {
3234 0 0       0 return wantarray ? (-u _,@_) : -u _;
3235             }
3236             elsif (_MSWin32_5Cended_path($_)) {
3237 0 0       0 if (-d "$_/.") {
3238 0 0       0 return wantarray ? (-u _,@_) : -u _;
3239             }
3240             else {
3241 0         0 my $fh = gensym();
3242 0 0       0 if (_open_r($fh, $_)) {
3243 0         0 my $u = -u $fh;
3244 0         0 close $fh;
3245 0 0       0 return wantarray ? ($u,@_) : $u;
3246             }
3247             }
3248             }
3249 0 0       0 return wantarray ? (undef,@_) : undef;
3250             }
3251              
3252             #
3253             # INFORMIX V6 ALS file test -g expr
3254             #
3255             sub Einformixv6als::g(;*@) {
3256              
3257 0 0   0 0 0 local $_ = shift if @_;
3258 0 0 0     0 croak 'Too many arguments for -g (Einformixv6als::g)' if @_ and not wantarray;
3259              
3260 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3261 0 0       0 return wantarray ? (-g _,@_) : -g _;
3262             }
3263             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3264 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3265             }
3266             elsif (-e $_) {
3267 0 0       0 return wantarray ? (-g _,@_) : -g _;
3268             }
3269             elsif (_MSWin32_5Cended_path($_)) {
3270 0 0       0 if (-d "$_/.") {
3271 0 0       0 return wantarray ? (-g _,@_) : -g _;
3272             }
3273             else {
3274 0         0 my $fh = gensym();
3275 0 0       0 if (_open_r($fh, $_)) {
3276 0         0 my $g = -g $fh;
3277 0         0 close $fh;
3278 0 0       0 return wantarray ? ($g,@_) : $g;
3279             }
3280             }
3281             }
3282 0 0       0 return wantarray ? (undef,@_) : undef;
3283             }
3284              
3285             #
3286             # INFORMIX V6 ALS file test -k expr
3287             #
3288             sub Einformixv6als::k(;*@) {
3289              
3290 0 0   0 0 0 local $_ = shift if @_;
3291 0 0 0     0 croak 'Too many arguments for -k (Einformixv6als::k)' if @_ and not wantarray;
3292              
3293 0 0       0 if ($_ eq '_') {
    0          
    0          
3294 0 0       0 return wantarray ? ('',@_) : '';
3295             }
3296             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3297 0 0       0 return wantarray ? ('',@_) : '';
3298             }
3299             elsif ($] =~ /^5\.008/oxms) {
3300 0 0       0 return wantarray ? ('',@_) : '';
3301             }
3302 0 0       0 return wantarray ? ($_,@_) : $_;
3303             }
3304              
3305             #
3306             # INFORMIX V6 ALS file test -T expr
3307             #
3308             sub Einformixv6als::T(;*@) {
3309              
3310 0 0   0 0 0 local $_ = shift if @_;
3311              
3312             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3313             # croak 'Too many arguments for -T (Einformixv6als::T)';
3314             # Must be used by parentheses like:
3315             # croak('Too many arguments for -T (Einformixv6als::T)');
3316              
3317 0 0 0     0 if (@_ and not wantarray) {
3318 0         0 croak('Too many arguments for -T (Einformixv6als::T)');
3319             }
3320              
3321 0         0 my $T = 1;
3322              
3323 0         0 my $fh = qualify_to_ref $_;
3324 0 0       0 if (defined fileno $fh) {
3325              
3326 0 0       0 if (defined Einformixv6als::telldir($fh)) {
3327 0 0       0 return wantarray ? (undef,@_) : undef;
3328             }
3329              
3330             # P.813 29.2.176. tell
3331             # in Chapter 29: Functions
3332             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3333              
3334             # P.970 tell
3335             # in Chapter 27: Functions
3336             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3337              
3338             # (and so on)
3339              
3340 0         0 my $systell = sysseek $fh, 0, 1;
3341              
3342 0 0       0 if (sysread $fh, my $block, 512) {
3343              
3344             # P.163 Binary file check in Little Perl Parlor 16
3345             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3346             # (and so on)
3347              
3348 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3349 0         0 $T = '';
3350             }
3351             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3352 0         0 $T = '';
3353             }
3354             }
3355              
3356             # 0 byte or eof
3357             else {
3358 0         0 $T = 1;
3359             }
3360              
3361 0         0 my $dummy_for_underline_cache = -T $fh;
3362 0         0 sysseek $fh, $systell, 0;
3363             }
3364             else {
3365 0 0 0     0 if (-d $_ or -d "$_/.") {
3366 0 0       0 return wantarray ? (undef,@_) : undef;
3367             }
3368              
3369 0         0 $fh = gensym();
3370 0 0       0 if (_open_r($fh, $_)) {
3371             }
3372             else {
3373 0 0       0 return wantarray ? (undef,@_) : undef;
3374             }
3375 0 0       0 if (sysread $fh, my $block, 512) {
3376 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3377 0         0 $T = '';
3378             }
3379             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3380 0         0 $T = '';
3381             }
3382             }
3383              
3384             # 0 byte or eof
3385             else {
3386 0         0 $T = 1;
3387             }
3388 0         0 my $dummy_for_underline_cache = -T $fh;
3389 0         0 close $fh;
3390             }
3391              
3392 0 0       0 return wantarray ? ($T,@_) : $T;
3393             }
3394              
3395             #
3396             # INFORMIX V6 ALS file test -B expr
3397             #
3398             sub Einformixv6als::B(;*@) {
3399              
3400 0 0   0 0 0 local $_ = shift if @_;
3401 0 0 0     0 croak 'Too many arguments for -B (Einformixv6als::B)' if @_ and not wantarray;
3402 0         0 my $B = '';
3403              
3404 0         0 my $fh = qualify_to_ref $_;
3405 0 0       0 if (defined fileno $fh) {
3406              
3407 0 0       0 if (defined Einformixv6als::telldir($fh)) {
3408 0 0       0 return wantarray ? (undef,@_) : undef;
3409             }
3410              
3411 0         0 my $systell = sysseek $fh, 0, 1;
3412              
3413 0 0       0 if (sysread $fh, my $block, 512) {
3414 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3415 0         0 $B = 1;
3416             }
3417             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3418 0         0 $B = 1;
3419             }
3420             }
3421              
3422             # 0 byte or eof
3423             else {
3424 0         0 $B = 1;
3425             }
3426              
3427 0         0 my $dummy_for_underline_cache = -B $fh;
3428 0         0 sysseek $fh, $systell, 0;
3429             }
3430             else {
3431 0 0 0     0 if (-d $_ or -d "$_/.") {
3432 0 0       0 return wantarray ? (undef,@_) : undef;
3433             }
3434              
3435 0         0 $fh = gensym();
3436 0 0       0 if (_open_r($fh, $_)) {
3437             }
3438             else {
3439 0 0       0 return wantarray ? (undef,@_) : undef;
3440             }
3441 0 0       0 if (sysread $fh, my $block, 512) {
3442 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3443 0         0 $B = 1;
3444             }
3445             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3446 0         0 $B = 1;
3447             }
3448             }
3449              
3450             # 0 byte or eof
3451             else {
3452 0         0 $B = 1;
3453             }
3454 0         0 my $dummy_for_underline_cache = -B $fh;
3455 0         0 close $fh;
3456             }
3457              
3458 0 0       0 return wantarray ? ($B,@_) : $B;
3459             }
3460              
3461             #
3462             # INFORMIX V6 ALS file test -M expr
3463             #
3464             sub Einformixv6als::M(;*@) {
3465              
3466 0 0   0 0 0 local $_ = shift if @_;
3467 0 0 0     0 croak 'Too many arguments for -M (Einformixv6als::M)' if @_ and not wantarray;
3468              
3469 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3470 0 0       0 return wantarray ? (-M _,@_) : -M _;
3471             }
3472             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3473 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3474             }
3475             elsif (-e $_) {
3476 0 0       0 return wantarray ? (-M _,@_) : -M _;
3477             }
3478             elsif (_MSWin32_5Cended_path($_)) {
3479 0 0       0 if (-d "$_/.") {
3480 0 0       0 return wantarray ? (-M _,@_) : -M _;
3481             }
3482             else {
3483 0         0 my $fh = gensym();
3484 0 0       0 if (_open_r($fh, $_)) {
3485 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3486 0         0 close $fh;
3487 0         0 my $M = ($^T - $mtime) / (24*60*60);
3488 0 0       0 return wantarray ? ($M,@_) : $M;
3489             }
3490             }
3491             }
3492 0 0       0 return wantarray ? (undef,@_) : undef;
3493             }
3494              
3495             #
3496             # INFORMIX V6 ALS file test -A expr
3497             #
3498             sub Einformixv6als::A(;*@) {
3499              
3500 0 0   0 0 0 local $_ = shift if @_;
3501 0 0 0     0 croak 'Too many arguments for -A (Einformixv6als::A)' if @_ and not wantarray;
3502              
3503 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3504 0 0       0 return wantarray ? (-A _,@_) : -A _;
3505             }
3506             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3507 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3508             }
3509             elsif (-e $_) {
3510 0 0       0 return wantarray ? (-A _,@_) : -A _;
3511             }
3512             elsif (_MSWin32_5Cended_path($_)) {
3513 0 0       0 if (-d "$_/.") {
3514 0 0       0 return wantarray ? (-A _,@_) : -A _;
3515             }
3516             else {
3517 0         0 my $fh = gensym();
3518 0 0       0 if (_open_r($fh, $_)) {
3519 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3520 0         0 close $fh;
3521 0         0 my $A = ($^T - $atime) / (24*60*60);
3522 0 0       0 return wantarray ? ($A,@_) : $A;
3523             }
3524             }
3525             }
3526 0 0       0 return wantarray ? (undef,@_) : undef;
3527             }
3528              
3529             #
3530             # INFORMIX V6 ALS file test -C expr
3531             #
3532             sub Einformixv6als::C(;*@) {
3533              
3534 0 0   0 0 0 local $_ = shift if @_;
3535 0 0 0     0 croak 'Too many arguments for -C (Einformixv6als::C)' if @_ and not wantarray;
3536              
3537 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3538 0 0       0 return wantarray ? (-C _,@_) : -C _;
3539             }
3540             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3541 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3542             }
3543             elsif (-e $_) {
3544 0 0       0 return wantarray ? (-C _,@_) : -C _;
3545             }
3546             elsif (_MSWin32_5Cended_path($_)) {
3547 0 0       0 if (-d "$_/.") {
3548 0 0       0 return wantarray ? (-C _,@_) : -C _;
3549             }
3550             else {
3551 0         0 my $fh = gensym();
3552 0 0       0 if (_open_r($fh, $_)) {
3553 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3554 0         0 close $fh;
3555 0         0 my $C = ($^T - $ctime) / (24*60*60);
3556 0 0       0 return wantarray ? ($C,@_) : $C;
3557             }
3558             }
3559             }
3560 0 0       0 return wantarray ? (undef,@_) : undef;
3561             }
3562              
3563             #
3564             # INFORMIX V6 ALS stacked file test $_
3565             #
3566             sub Einformixv6als::filetest_ {
3567              
3568 0     0 0 0 my $filetest = substr(pop @_, 1);
3569              
3570 0 0       0 unless (CORE::eval qq{Einformixv6als::${filetest}_}) {
3571 0         0 return '';
3572             }
3573 0         0 for my $filetest (CORE::reverse @_) {
3574 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3575 0         0 return '';
3576             }
3577             }
3578 0         0 return 1;
3579             }
3580              
3581             #
3582             # INFORMIX V6 ALS file test -r $_
3583             #
3584             sub Einformixv6als::r_() {
3585              
3586 0 0   0 0 0 if (-e $_) {
    0          
3587 0 0       0 return -r _ ? 1 : '';
3588             }
3589             elsif (_MSWin32_5Cended_path($_)) {
3590 0 0       0 if (-d "$_/.") {
3591 0 0       0 return -r _ ? 1 : '';
3592             }
3593             else {
3594 0         0 my $fh = gensym();
3595 0 0       0 if (_open_r($fh, $_)) {
3596 0         0 my $r = -r $fh;
3597 0         0 close $fh;
3598 0 0       0 return $r ? 1 : '';
3599             }
3600             }
3601             }
3602              
3603             # 10.10. Returning Failure
3604             # in Chapter 10. Subroutines
3605             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3606             # (and so on)
3607              
3608             # 2010-01-26 The difference of "return;" and "return undef;"
3609             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3610             #
3611             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3612             # it might be wrong in some cases. If you use this idiom for those functions
3613             # which are expected to return a scalar value, e.g. searching functions, the
3614             # user of those functions will be surprised at what they return in list
3615             # context, an empty list - note that many functions and all the methods
3616             # evaluate their arguments in list context. You'd better to use "return undef;"
3617             # for such scalar functions.
3618             #
3619             # sub search_something {
3620             # my($arg) = @_;
3621             # # search_something...
3622             # if(defined $found){
3623             # return $found;
3624             # }
3625             # return; # XXX: you'd better to "return undef;"
3626             # }
3627             #
3628             # # ...
3629             #
3630             # # you'll get what you want, but ...
3631             # my $something = search_something($source);
3632             #
3633             # # you won't get what you want here.
3634             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3635             # $obj->doit(search_something($source), -option=> $optval);
3636             #
3637             # # you have to use the "scalar" operator in such a case.
3638             # $obj->doit(scalar search_something($source), ...);
3639             #
3640             # *1: it returns an empty list in list context, or returns undef in scalar
3641             # context
3642             #
3643             # (and so on)
3644              
3645 0         0 return undef;
3646             }
3647              
3648             #
3649             # INFORMIX V6 ALS file test -w $_
3650             #
3651             sub Einformixv6als::w_() {
3652              
3653 0 0   0 0 0 if (-e $_) {
    0          
3654 0 0       0 return -w _ ? 1 : '';
3655             }
3656             elsif (_MSWin32_5Cended_path($_)) {
3657 0 0       0 if (-d "$_/.") {
3658 0 0       0 return -w _ ? 1 : '';
3659             }
3660             else {
3661 0         0 my $fh = gensym();
3662 0 0       0 if (_open_a($fh, $_)) {
3663 0         0 my $w = -w $fh;
3664 0         0 close $fh;
3665 0 0       0 return $w ? 1 : '';
3666             }
3667             }
3668             }
3669 0         0 return undef;
3670             }
3671              
3672             #
3673             # INFORMIX V6 ALS file test -x $_
3674             #
3675             sub Einformixv6als::x_() {
3676              
3677 0 0   0 0 0 if (-e $_) {
    0          
3678 0 0       0 return -x _ ? 1 : '';
3679             }
3680             elsif (_MSWin32_5Cended_path($_)) {
3681 0 0       0 if (-d "$_/.") {
3682 0 0       0 return -x _ ? 1 : '';
3683             }
3684             else {
3685 0         0 my $fh = gensym();
3686 0 0       0 if (_open_r($fh, $_)) {
3687 0         0 my $dummy_for_underline_cache = -x $fh;
3688 0         0 close $fh;
3689             }
3690              
3691             # filename is not .COM .EXE .BAT .CMD
3692 0         0 return '';
3693             }
3694             }
3695 0         0 return undef;
3696             }
3697              
3698             #
3699             # INFORMIX V6 ALS file test -o $_
3700             #
3701             sub Einformixv6als::o_() {
3702              
3703 0 0   0 0 0 if (-e $_) {
    0          
3704 0 0       0 return -o _ ? 1 : '';
3705             }
3706             elsif (_MSWin32_5Cended_path($_)) {
3707 0 0       0 if (-d "$_/.") {
3708 0 0       0 return -o _ ? 1 : '';
3709             }
3710             else {
3711 0         0 my $fh = gensym();
3712 0 0       0 if (_open_r($fh, $_)) {
3713 0         0 my $o = -o $fh;
3714 0         0 close $fh;
3715 0 0       0 return $o ? 1 : '';
3716             }
3717             }
3718             }
3719 0         0 return undef;
3720             }
3721              
3722             #
3723             # INFORMIX V6 ALS file test -R $_
3724             #
3725             sub Einformixv6als::R_() {
3726              
3727 0 0   0 0 0 if (-e $_) {
    0          
3728 0 0       0 return -R _ ? 1 : '';
3729             }
3730             elsif (_MSWin32_5Cended_path($_)) {
3731 0 0       0 if (-d "$_/.") {
3732 0 0       0 return -R _ ? 1 : '';
3733             }
3734             else {
3735 0         0 my $fh = gensym();
3736 0 0       0 if (_open_r($fh, $_)) {
3737 0         0 my $R = -R $fh;
3738 0         0 close $fh;
3739 0 0       0 return $R ? 1 : '';
3740             }
3741             }
3742             }
3743 0         0 return undef;
3744             }
3745              
3746             #
3747             # INFORMIX V6 ALS file test -W $_
3748             #
3749             sub Einformixv6als::W_() {
3750              
3751 0 0   0 0 0 if (-e $_) {
    0          
3752 0 0       0 return -W _ ? 1 : '';
3753             }
3754             elsif (_MSWin32_5Cended_path($_)) {
3755 0 0       0 if (-d "$_/.") {
3756 0 0       0 return -W _ ? 1 : '';
3757             }
3758             else {
3759 0         0 my $fh = gensym();
3760 0 0       0 if (_open_a($fh, $_)) {
3761 0         0 my $W = -W $fh;
3762 0         0 close $fh;
3763 0 0       0 return $W ? 1 : '';
3764             }
3765             }
3766             }
3767 0         0 return undef;
3768             }
3769              
3770             #
3771             # INFORMIX V6 ALS file test -X $_
3772             #
3773             sub Einformixv6als::X_() {
3774              
3775 0 0   0 0 0 if (-e $_) {
    0          
3776 0 0       0 return -X _ ? 1 : '';
3777             }
3778             elsif (_MSWin32_5Cended_path($_)) {
3779 0 0       0 if (-d "$_/.") {
3780 0 0       0 return -X _ ? 1 : '';
3781             }
3782             else {
3783 0         0 my $fh = gensym();
3784 0 0       0 if (_open_r($fh, $_)) {
3785 0         0 my $dummy_for_underline_cache = -X $fh;
3786 0         0 close $fh;
3787             }
3788              
3789             # filename is not .COM .EXE .BAT .CMD
3790 0         0 return '';
3791             }
3792             }
3793 0         0 return undef;
3794             }
3795              
3796             #
3797             # INFORMIX V6 ALS file test -O $_
3798             #
3799             sub Einformixv6als::O_() {
3800              
3801 0 0   0 0 0 if (-e $_) {
    0          
3802 0 0       0 return -O _ ? 1 : '';
3803             }
3804             elsif (_MSWin32_5Cended_path($_)) {
3805 0 0       0 if (-d "$_/.") {
3806 0 0       0 return -O _ ? 1 : '';
3807             }
3808             else {
3809 0         0 my $fh = gensym();
3810 0 0       0 if (_open_r($fh, $_)) {
3811 0         0 my $O = -O $fh;
3812 0         0 close $fh;
3813 0 0       0 return $O ? 1 : '';
3814             }
3815             }
3816             }
3817 0         0 return undef;
3818             }
3819              
3820             #
3821             # INFORMIX V6 ALS file test -e $_
3822             #
3823             sub Einformixv6als::e_() {
3824              
3825 0 0   0 0 0 if (-e $_) {
    0          
3826 0         0 return 1;
3827             }
3828             elsif (_MSWin32_5Cended_path($_)) {
3829 0 0       0 if (-d "$_/.") {
3830 0         0 return 1;
3831             }
3832             else {
3833 0         0 my $fh = gensym();
3834 0 0       0 if (_open_r($fh, $_)) {
3835 0         0 my $e = -e $fh;
3836 0         0 close $fh;
3837 0 0       0 return $e ? 1 : '';
3838             }
3839             }
3840             }
3841 0         0 return undef;
3842             }
3843              
3844             #
3845             # INFORMIX V6 ALS file test -z $_
3846             #
3847             sub Einformixv6als::z_() {
3848              
3849 0 0   0 0 0 if (-e $_) {
    0          
3850 0 0       0 return -z _ ? 1 : '';
3851             }
3852             elsif (_MSWin32_5Cended_path($_)) {
3853 0 0       0 if (-d "$_/.") {
3854 0 0       0 return -z _ ? 1 : '';
3855             }
3856             else {
3857 0         0 my $fh = gensym();
3858 0 0       0 if (_open_r($fh, $_)) {
3859 0         0 my $z = -z $fh;
3860 0         0 close $fh;
3861 0 0       0 return $z ? 1 : '';
3862             }
3863             }
3864             }
3865 0         0 return undef;
3866             }
3867              
3868             #
3869             # INFORMIX V6 ALS file test -s $_
3870             #
3871             sub Einformixv6als::s_() {
3872              
3873 0 0   0 0 0 if (-e $_) {
    0          
3874 0         0 return -s _;
3875             }
3876             elsif (_MSWin32_5Cended_path($_)) {
3877 0 0       0 if (-d "$_/.") {
3878 0         0 return -s _;
3879             }
3880             else {
3881 0         0 my $fh = gensym();
3882 0 0       0 if (_open_r($fh, $_)) {
3883 0         0 my $s = -s $fh;
3884 0         0 close $fh;
3885 0         0 return $s;
3886             }
3887             }
3888             }
3889 0         0 return undef;
3890             }
3891              
3892             #
3893             # INFORMIX V6 ALS file test -f $_
3894             #
3895             sub Einformixv6als::f_() {
3896              
3897 0 0   0 0 0 if (-e $_) {
    0          
3898 0 0       0 return -f _ ? 1 : '';
3899             }
3900             elsif (_MSWin32_5Cended_path($_)) {
3901 0 0       0 if (-d "$_/.") {
3902 0         0 return '';
3903             }
3904             else {
3905 0         0 my $fh = gensym();
3906 0 0       0 if (_open_r($fh, $_)) {
3907 0         0 my $f = -f $fh;
3908 0         0 close $fh;
3909 0 0       0 return $f ? 1 : '';
3910             }
3911             }
3912             }
3913 0         0 return undef;
3914             }
3915              
3916             #
3917             # INFORMIX V6 ALS file test -d $_
3918             #
3919             sub Einformixv6als::d_() {
3920              
3921 0 0   0 0 0 if (-e $_) {
    0          
3922 0 0       0 return -d _ ? 1 : '';
3923             }
3924             elsif (_MSWin32_5Cended_path($_)) {
3925 0 0       0 return -d "$_/." ? 1 : '';
3926             }
3927 0         0 return undef;
3928             }
3929              
3930             #
3931             # INFORMIX V6 ALS file test -l $_
3932             #
3933             sub Einformixv6als::l_() {
3934              
3935 0 0   0 0 0 if (-e $_) {
    0          
3936 0 0       0 return -l _ ? 1 : '';
3937             }
3938             elsif (_MSWin32_5Cended_path($_)) {
3939 0 0       0 if (-d "$_/.") {
3940 0 0       0 return -l _ ? 1 : '';
3941             }
3942             else {
3943 0         0 my $fh = gensym();
3944 0 0       0 if (_open_r($fh, $_)) {
3945 0         0 my $l = -l $fh;
3946 0         0 close $fh;
3947 0 0       0 return $l ? 1 : '';
3948             }
3949             }
3950             }
3951 0         0 return undef;
3952             }
3953              
3954             #
3955             # INFORMIX V6 ALS file test -p $_
3956             #
3957             sub Einformixv6als::p_() {
3958              
3959 0 0   0 0 0 if (-e $_) {
    0          
3960 0 0       0 return -p _ ? 1 : '';
3961             }
3962             elsif (_MSWin32_5Cended_path($_)) {
3963 0 0       0 if (-d "$_/.") {
3964 0 0       0 return -p _ ? 1 : '';
3965             }
3966             else {
3967 0         0 my $fh = gensym();
3968 0 0       0 if (_open_r($fh, $_)) {
3969 0         0 my $p = -p $fh;
3970 0         0 close $fh;
3971 0 0       0 return $p ? 1 : '';
3972             }
3973             }
3974             }
3975 0         0 return undef;
3976             }
3977              
3978             #
3979             # INFORMIX V6 ALS file test -S $_
3980             #
3981             sub Einformixv6als::S_() {
3982              
3983 0 0   0 0 0 if (-e $_) {
    0          
3984 0 0       0 return -S _ ? 1 : '';
3985             }
3986             elsif (_MSWin32_5Cended_path($_)) {
3987 0 0       0 if (-d "$_/.") {
3988 0 0       0 return -S _ ? 1 : '';
3989             }
3990             else {
3991 0         0 my $fh = gensym();
3992 0 0       0 if (_open_r($fh, $_)) {
3993 0         0 my $S = -S $fh;
3994 0         0 close $fh;
3995 0 0       0 return $S ? 1 : '';
3996             }
3997             }
3998             }
3999 0         0 return undef;
4000             }
4001              
4002             #
4003             # INFORMIX V6 ALS file test -b $_
4004             #
4005             sub Einformixv6als::b_() {
4006              
4007 0 0   0 0 0 if (-e $_) {
    0          
4008 0 0       0 return -b _ ? 1 : '';
4009             }
4010             elsif (_MSWin32_5Cended_path($_)) {
4011 0 0       0 if (-d "$_/.") {
4012 0 0       0 return -b _ ? 1 : '';
4013             }
4014             else {
4015 0         0 my $fh = gensym();
4016 0 0       0 if (_open_r($fh, $_)) {
4017 0         0 my $b = -b $fh;
4018 0         0 close $fh;
4019 0 0       0 return $b ? 1 : '';
4020             }
4021             }
4022             }
4023 0         0 return undef;
4024             }
4025              
4026             #
4027             # INFORMIX V6 ALS file test -c $_
4028             #
4029             sub Einformixv6als::c_() {
4030              
4031 0 0   0 0 0 if (-e $_) {
    0          
4032 0 0       0 return -c _ ? 1 : '';
4033             }
4034             elsif (_MSWin32_5Cended_path($_)) {
4035 0 0       0 if (-d "$_/.") {
4036 0 0       0 return -c _ ? 1 : '';
4037             }
4038             else {
4039 0         0 my $fh = gensym();
4040 0 0       0 if (_open_r($fh, $_)) {
4041 0         0 my $c = -c $fh;
4042 0         0 close $fh;
4043 0 0       0 return $c ? 1 : '';
4044             }
4045             }
4046             }
4047 0         0 return undef;
4048             }
4049              
4050             #
4051             # INFORMIX V6 ALS file test -u $_
4052             #
4053             sub Einformixv6als::u_() {
4054              
4055 0 0   0 0 0 if (-e $_) {
    0          
4056 0 0       0 return -u _ ? 1 : '';
4057             }
4058             elsif (_MSWin32_5Cended_path($_)) {
4059 0 0       0 if (-d "$_/.") {
4060 0 0       0 return -u _ ? 1 : '';
4061             }
4062             else {
4063 0         0 my $fh = gensym();
4064 0 0       0 if (_open_r($fh, $_)) {
4065 0         0 my $u = -u $fh;
4066 0         0 close $fh;
4067 0 0       0 return $u ? 1 : '';
4068             }
4069             }
4070             }
4071 0         0 return undef;
4072             }
4073              
4074             #
4075             # INFORMIX V6 ALS file test -g $_
4076             #
4077             sub Einformixv6als::g_() {
4078              
4079 0 0   0 0 0 if (-e $_) {
    0          
4080 0 0       0 return -g _ ? 1 : '';
4081             }
4082             elsif (_MSWin32_5Cended_path($_)) {
4083 0 0       0 if (-d "$_/.") {
4084 0 0       0 return -g _ ? 1 : '';
4085             }
4086             else {
4087 0         0 my $fh = gensym();
4088 0 0       0 if (_open_r($fh, $_)) {
4089 0         0 my $g = -g $fh;
4090 0         0 close $fh;
4091 0 0       0 return $g ? 1 : '';
4092             }
4093             }
4094             }
4095 0         0 return undef;
4096             }
4097              
4098             #
4099             # INFORMIX V6 ALS file test -k $_
4100             #
4101             sub Einformixv6als::k_() {
4102              
4103 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4104 0 0       0 return wantarray ? ('',@_) : '';
4105             }
4106 0 0       0 return wantarray ? ($_,@_) : $_;
4107             }
4108              
4109             #
4110             # INFORMIX V6 ALS file test -T $_
4111             #
4112             sub Einformixv6als::T_() {
4113              
4114 0     0 0 0 my $T = 1;
4115              
4116 0 0 0     0 if (-d $_ or -d "$_/.") {
4117 0         0 return undef;
4118             }
4119 0         0 my $fh = gensym();
4120 0 0       0 if (_open_r($fh, $_)) {
4121             }
4122             else {
4123 0         0 return undef;
4124             }
4125              
4126 0 0       0 if (sysread $fh, my $block, 512) {
4127 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4128 0         0 $T = '';
4129             }
4130             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4131 0         0 $T = '';
4132             }
4133             }
4134              
4135             # 0 byte or eof
4136             else {
4137 0         0 $T = 1;
4138             }
4139 0         0 my $dummy_for_underline_cache = -T $fh;
4140 0         0 close $fh;
4141              
4142 0         0 return $T;
4143             }
4144              
4145             #
4146             # INFORMIX V6 ALS file test -B $_
4147             #
4148             sub Einformixv6als::B_() {
4149              
4150 0     0 0 0 my $B = '';
4151              
4152 0 0 0     0 if (-d $_ or -d "$_/.") {
4153 0         0 return undef;
4154             }
4155 0         0 my $fh = gensym();
4156 0 0       0 if (_open_r($fh, $_)) {
4157             }
4158             else {
4159 0         0 return undef;
4160             }
4161              
4162 0 0       0 if (sysread $fh, my $block, 512) {
4163 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4164 0         0 $B = 1;
4165             }
4166             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4167 0         0 $B = 1;
4168             }
4169             }
4170              
4171             # 0 byte or eof
4172             else {
4173 0         0 $B = 1;
4174             }
4175 0         0 my $dummy_for_underline_cache = -B $fh;
4176 0         0 close $fh;
4177              
4178 0         0 return $B;
4179             }
4180              
4181             #
4182             # INFORMIX V6 ALS file test -M $_
4183             #
4184             sub Einformixv6als::M_() {
4185              
4186 0 0   0 0 0 if (-e $_) {
    0          
4187 0         0 return -M _;
4188             }
4189             elsif (_MSWin32_5Cended_path($_)) {
4190 0 0       0 if (-d "$_/.") {
4191 0         0 return -M _;
4192             }
4193             else {
4194 0         0 my $fh = gensym();
4195 0 0       0 if (_open_r($fh, $_)) {
4196 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4197 0         0 close $fh;
4198 0         0 my $M = ($^T - $mtime) / (24*60*60);
4199 0         0 return $M;
4200             }
4201             }
4202             }
4203 0         0 return undef;
4204             }
4205              
4206             #
4207             # INFORMIX V6 ALS file test -A $_
4208             #
4209             sub Einformixv6als::A_() {
4210              
4211 0 0   0 0 0 if (-e $_) {
    0          
4212 0         0 return -A _;
4213             }
4214             elsif (_MSWin32_5Cended_path($_)) {
4215 0 0       0 if (-d "$_/.") {
4216 0         0 return -A _;
4217             }
4218             else {
4219 0         0 my $fh = gensym();
4220 0 0       0 if (_open_r($fh, $_)) {
4221 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4222 0         0 close $fh;
4223 0         0 my $A = ($^T - $atime) / (24*60*60);
4224 0         0 return $A;
4225             }
4226             }
4227             }
4228 0         0 return undef;
4229             }
4230              
4231             #
4232             # INFORMIX V6 ALS file test -C $_
4233             #
4234             sub Einformixv6als::C_() {
4235              
4236 0 0   0 0 0 if (-e $_) {
    0          
4237 0         0 return -C _;
4238             }
4239             elsif (_MSWin32_5Cended_path($_)) {
4240 0 0       0 if (-d "$_/.") {
4241 0         0 return -C _;
4242             }
4243             else {
4244 0         0 my $fh = gensym();
4245 0 0       0 if (_open_r($fh, $_)) {
4246 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4247 0         0 close $fh;
4248 0         0 my $C = ($^T - $ctime) / (24*60*60);
4249 0         0 return $C;
4250             }
4251             }
4252             }
4253 0         0 return undef;
4254             }
4255              
4256             #
4257             # INFORMIX V6 ALS path globbing (with parameter)
4258             #
4259             sub Einformixv6als::glob($) {
4260              
4261 0 0   0 0 0 if (wantarray) {
4262 0         0 my @glob = _DOS_like_glob(@_);
4263 0         0 for my $glob (@glob) {
4264 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4265             }
4266 0         0 return @glob;
4267             }
4268             else {
4269 0         0 my $glob = _DOS_like_glob(@_);
4270 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4271 0         0 return $glob;
4272             }
4273             }
4274              
4275             #
4276             # INFORMIX V6 ALS path globbing (without parameter)
4277             #
4278             sub Einformixv6als::glob_() {
4279              
4280 0 0   0 0 0 if (wantarray) {
4281 0         0 my @glob = _DOS_like_glob();
4282 0         0 for my $glob (@glob) {
4283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4284             }
4285 0         0 return @glob;
4286             }
4287             else {
4288 0         0 my $glob = _DOS_like_glob();
4289 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4290 0         0 return $glob;
4291             }
4292             }
4293              
4294             #
4295             # INFORMIX V6 ALS path globbing via File::DosGlob 1.10
4296             #
4297             # Often I confuse "_dosglob" and "_doglob".
4298             # So, I renamed "_dosglob" to "_DOS_like_glob".
4299             #
4300             my %iter;
4301             my %entries;
4302             sub _DOS_like_glob {
4303              
4304             # context (keyed by second cxix argument provided by core)
4305 0     0   0 my($expr,$cxix) = @_;
4306              
4307             # glob without args defaults to $_
4308 0 0       0 $expr = $_ if not defined $expr;
4309              
4310             # represents the current user's home directory
4311             #
4312             # 7.3. Expanding Tildes in Filenames
4313             # in Chapter 7. File Access
4314             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4315             #
4316             # and File::HomeDir, File::HomeDir::Windows module
4317              
4318             # DOS-like system
4319 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4320 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4321             { my_home_MSWin32() }oxmse;
4322             }
4323              
4324             # UNIX-like system
4325 0 0 0     0 else {
  0         0  
4326             $expr =~ s{ \A ~ ( (?:[^\x81-\x9F\xE0-\xFD/]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF])* ) }
4327             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4328             }
4329 0 0       0  
4330 0 0       0 # assume global context if not provided one
4331             $cxix = '_G_' if not defined $cxix;
4332             $iter{$cxix} = 0 if not exists $iter{$cxix};
4333 0 0       0  
4334 0         0 # if we're just beginning, do it all first
4335             if ($iter{$cxix} == 0) {
4336             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4337             }
4338 0 0       0  
4339 0         0 # chuck it all out, quick or slow
4340 0         0 if (wantarray) {
  0         0  
4341             delete $iter{$cxix};
4342             return @{delete $entries{$cxix}};
4343 0 0       0 }
  0         0  
4344 0         0 else {
  0         0  
4345             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4346             return shift @{$entries{$cxix}};
4347             }
4348 0         0 else {
4349 0         0 # return undef for EOL
4350 0         0 delete $iter{$cxix};
4351             delete $entries{$cxix};
4352             return undef;
4353             }
4354             }
4355             }
4356              
4357             #
4358             # INFORMIX V6 ALS path globbing subroutine
4359             #
4360 0     0   0 sub _do_glob {
4361 0         0  
4362 0         0 my($cond,@expr) = @_;
4363             my @glob = ();
4364             my $fix_drive_relative_paths = 0;
4365 0         0  
4366 0 0       0 OUTER:
4367 0 0       0 for my $expr (@expr) {
4368             next OUTER if not defined $expr;
4369 0         0 next OUTER if $expr eq '';
4370 0         0  
4371 0         0 my @matched = ();
4372 0         0 my @globdir = ();
4373 0         0 my $head = '.';
4374             my $pathsep = '/';
4375             my $tail;
4376 0 0       0  
4377 0         0 # if argument is within quotes strip em and do no globbing
4378 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4379 0 0       0 $expr = $1;
4380 0         0 if ($cond eq 'd') {
4381             if (Einformixv6als::d $expr) {
4382             push @glob, $expr;
4383             }
4384 0 0       0 }
4385 0         0 else {
4386             if (Einformixv6als::e $expr) {
4387             push @glob, $expr;
4388 0         0 }
4389             }
4390             next OUTER;
4391             }
4392              
4393 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4394 0 0       0 # to h:./*.pm to expand correctly
4395 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4396             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) {
4397             $fix_drive_relative_paths = 1;
4398             }
4399 0 0       0 }
4400 0 0       0  
4401 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4402 0         0 if ($tail eq '') {
4403             push @glob, $expr;
4404 0 0       0 next OUTER;
4405 0 0       0 }
4406 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4407 0         0 if (@globdir = _do_glob('d', $head)) {
4408             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4409             next OUTER;
4410 0 0 0     0 }
4411 0         0 }
4412             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4413 0         0 $head .= $pathsep;
4414             }
4415             $expr = $tail;
4416             }
4417 0 0       0  
4418 0 0       0 # If file component has no wildcards, we can avoid opendir
4419 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4420             if ($head eq '.') {
4421 0 0 0     0 $head = '';
4422 0         0 }
4423             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4424 0         0 $head .= $pathsep;
4425 0 0       0 }
4426 0 0       0 $head .= $expr;
4427 0         0 if ($cond eq 'd') {
4428             if (Einformixv6als::d $head) {
4429             push @glob, $head;
4430             }
4431 0 0       0 }
4432 0         0 else {
4433             if (Einformixv6als::e $head) {
4434             push @glob, $head;
4435 0         0 }
4436             }
4437 0 0       0 next OUTER;
4438 0         0 }
4439 0         0 Einformixv6als::opendir(*DIR, $head) or next OUTER;
4440             my @leaf = readdir DIR;
4441 0 0       0 closedir DIR;
4442 0         0  
4443             if ($head eq '.') {
4444 0 0 0     0 $head = '';
4445 0         0 }
4446             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4447             $head .= $pathsep;
4448 0         0 }
4449 0         0  
4450 0         0 my $pattern = '';
4451             while ($expr =~ / \G ($q_char) /oxgc) {
4452             my $char = $1;
4453              
4454             # 6.9. Matching Shell Globs as Regular Expressions
4455             # in Chapter 6. Pattern Matching
4456             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4457 0 0       0 # (and so on)
    0          
    0          
4458 0         0  
4459             if ($char eq '*') {
4460             $pattern .= "(?:$your_char)*",
4461 0         0 }
4462             elsif ($char eq '?') {
4463             $pattern .= "(?:$your_char)?", # DOS style
4464             # $pattern .= "(?:$your_char)", # UNIX style
4465 0         0 }
4466             elsif ((my $fc = Einformixv6als::fc($char)) ne $char) {
4467             $pattern .= $fc;
4468 0         0 }
4469             else {
4470             $pattern .= quotemeta $char;
4471 0     0   0 }
  0         0  
4472             }
4473             my $matchsub = sub { Einformixv6als::fc($_[0]) =~ /\A $pattern \z/xms };
4474              
4475             # if ($@) {
4476             # print STDERR "$0: $@\n";
4477             # next OUTER;
4478             # }
4479 0         0  
4480 0 0 0     0 INNER:
4481 0         0 for my $leaf (@leaf) {
4482             if ($leaf eq '.' or $leaf eq '..') {
4483 0 0 0     0 next INNER;
4484 0         0 }
4485             if ($cond eq 'd' and not Einformixv6als::d "$head$leaf") {
4486             next INNER;
4487 0 0       0 }
4488 0         0  
4489 0         0 if (&$matchsub($leaf)) {
4490             push @matched, "$head$leaf";
4491             next INNER;
4492             }
4493              
4494             # [DOS compatibility special case]
4495 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4496              
4497             if (Einformixv6als::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4498             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4499 0 0       0 Einformixv6als::index($pattern,'\\.') != -1 # pattern has a dot.
4500 0         0 ) {
4501 0         0 if (&$matchsub("$leaf.")) {
4502             push @matched, "$head$leaf";
4503             next INNER;
4504             }
4505 0 0       0 }
4506 0         0 }
4507             if (@matched) {
4508             push @glob, @matched;
4509 0 0       0 }
4510 0         0 }
4511 0         0 if ($fix_drive_relative_paths) {
4512             for my $glob (@glob) {
4513             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4514 0         0 }
4515             }
4516             return @glob;
4517             }
4518              
4519             #
4520             # INFORMIX V6 ALS parse line
4521             #
4522 0     0   0 sub _parse_line {
4523              
4524 0         0 my($line) = @_;
4525 0         0  
4526 0         0 $line .= ' ';
4527             my @piece = ();
4528             while ($line =~ /
4529             " ( (?>(?: [^\x81-\x9F\xE0-\xFD"] |[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4530             ( (?>(?: [^\x81-\x9F\xE0-\xFD"\s]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4531 0 0       0 /oxmsg
4532             ) {
4533 0         0 push @piece, defined($1) ? $1 : $2;
4534             }
4535             return @piece;
4536             }
4537              
4538             #
4539             # INFORMIX V6 ALS parse path
4540             #
4541 0     0   0 sub _parse_path {
4542              
4543 0         0 my($path,$pathsep) = @_;
4544 0         0  
4545 0         0 $path .= '/';
4546             my @subpath = ();
4547             while ($path =~ /
4548             ((?: [^\x81-\x9F\xE0-\xFD\/\\]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] )+?) [\/\\]
4549 0         0 /oxmsg
4550             ) {
4551             push @subpath, $1;
4552 0         0 }
4553 0         0  
4554 0         0 my $tail = pop @subpath;
4555             my $head = join $pathsep, @subpath;
4556             return $head, $tail;
4557             }
4558              
4559             #
4560             # via File::HomeDir::Windows 1.00
4561             #
4562             sub my_home_MSWin32 {
4563              
4564             # A lot of unix people and unix-derived tools rely on
4565 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4566 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4567             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4568             return $ENV{'HOME'};
4569             }
4570              
4571 0         0 # Do we have a user profile?
4572             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4573             return $ENV{'USERPROFILE'};
4574             }
4575              
4576 0         0 # Some Windows use something like $ENV{'HOME'}
4577             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4578             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4579 0         0 }
4580              
4581             return undef;
4582             }
4583              
4584             #
4585             # via File::HomeDir::Unix 1.00
4586 0     0 0 0 #
4587             sub my_home {
4588 0 0 0     0 my $home;
    0 0        
4589 0         0  
4590             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4591             $home = $ENV{'HOME'};
4592             }
4593              
4594             # This is from the original code, but I'm guessing
4595 0         0 # it means "login directory" and exists on some Unixes.
4596             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4597             $home = $ENV{'LOGDIR'};
4598             }
4599              
4600             ### More-desperate methods
4601              
4602 0         0 # Light desperation on any (Unixish) platform
4603             else {
4604             $home = CORE::eval q{ (getpwuid($<))[7] };
4605             }
4606              
4607 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4608 0         0 # For example, "nobody"-like users might use /nonexistant
4609             if (defined $home and ! Einformixv6als::d($home)) {
4610 0         0 $home = undef;
4611             }
4612             return $home;
4613             }
4614              
4615             #
4616             # INFORMIX V6 ALS file lstat (with parameter)
4617             #
4618 0 0   0 0 0 sub Einformixv6als::lstat(*) {
4619              
4620 0 0       0 local $_ = shift if @_;
    0          
4621 0         0  
4622             if (-e $_) {
4623             return CORE::lstat _;
4624             }
4625             elsif (_MSWin32_5Cended_path($_)) {
4626              
4627             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Einformixv6als::lstat()
4628             # on Windows opens the file for the path which has 5c at end.
4629 0         0 # (and so on)
4630 0 0       0  
4631 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4632 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4633 0         0 if (wantarray) {
4634 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4635             close MUST_BE_BAREWORD_AT_HERE;
4636             return @stat;
4637 0         0 }
4638 0         0 else {
4639 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4640             close MUST_BE_BAREWORD_AT_HERE;
4641             return $stat;
4642             }
4643 0 0       0 }
4644             }
4645             return wantarray ? () : undef;
4646             }
4647              
4648             #
4649             # INFORMIX V6 ALS file lstat (without parameter)
4650             #
4651 0 0   0 0 0 sub Einformixv6als::lstat_() {
    0          
4652 0         0  
4653             if (-e $_) {
4654             return CORE::lstat _;
4655 0         0 }
4656 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4657 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4658 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4659 0         0 if (wantarray) {
4660 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4661             close MUST_BE_BAREWORD_AT_HERE;
4662             return @stat;
4663 0         0 }
4664 0         0 else {
4665 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4666             close MUST_BE_BAREWORD_AT_HERE;
4667             return $stat;
4668             }
4669 0 0       0 }
4670             }
4671             return wantarray ? () : undef;
4672             }
4673              
4674             #
4675             # INFORMIX V6 ALS path opendir
4676             #
4677 0     0 0 0 sub Einformixv6als::opendir(*$) {
4678 0 0       0  
    0          
4679 0         0 my $dh = qualify_to_ref $_[0];
4680             if (CORE::opendir $dh, $_[1]) {
4681             return 1;
4682 0 0       0 }
4683 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4684             if (CORE::opendir $dh, "$_[1]/.") {
4685             return 1;
4686 0         0 }
4687             }
4688             return undef;
4689             }
4690              
4691             #
4692             # INFORMIX V6 ALS file stat (with parameter)
4693             #
4694 0 50   384 0 0 sub Einformixv6als::stat(*) {
4695              
4696 384         18631 local $_ = shift if @_;
4697 384 50       2413  
    50          
    0          
4698 384         12611 my $fh = qualify_to_ref $_;
4699             if (defined fileno $fh) {
4700             return CORE::stat $fh;
4701 0         0 }
4702             elsif (-e $_) {
4703             return CORE::stat _;
4704             }
4705             elsif (_MSWin32_5Cended_path($_)) {
4706              
4707             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Einformixv6als::stat()
4708             # on Windows opens the file for the path which has 5c at end.
4709 384         3040 # (and so on)
4710 0 0       0  
4711 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4712 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4713 0         0 if (wantarray) {
4714 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4715             close MUST_BE_BAREWORD_AT_HERE;
4716             return @stat;
4717 0         0 }
4718 0         0 else {
4719 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4720             close MUST_BE_BAREWORD_AT_HERE;
4721             return $stat;
4722             }
4723 0 0       0 }
4724             }
4725             return wantarray ? () : undef;
4726             }
4727              
4728             #
4729             # INFORMIX V6 ALS file stat (without parameter)
4730             #
4731 0     0 0 0 sub Einformixv6als::stat_() {
4732 0 0       0  
    0          
    0          
4733 0         0 my $fh = qualify_to_ref $_;
4734             if (defined fileno $fh) {
4735             return CORE::stat $fh;
4736 0         0 }
4737             elsif (-e $_) {
4738             return CORE::stat _;
4739 0         0 }
4740 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4741 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4742 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4743 0         0 if (wantarray) {
4744 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4745             close MUST_BE_BAREWORD_AT_HERE;
4746             return @stat;
4747 0         0 }
4748 0         0 else {
4749 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4750             close MUST_BE_BAREWORD_AT_HERE;
4751             return $stat;
4752             }
4753 0 0       0 }
4754             }
4755             return wantarray ? () : undef;
4756             }
4757              
4758             #
4759             # INFORMIX V6 ALS path unlink
4760             #
4761 0 0   0 0 0 sub Einformixv6als::unlink(@) {
4762              
4763 0         0 local @_ = ($_) unless @_;
4764 0         0  
4765 0 0       0 my $unlink = 0;
    0          
    0          
4766 0         0 for (@_) {
4767             if (CORE::unlink) {
4768             $unlink++;
4769             }
4770             elsif (Einformixv6als::d($_)) {
4771 0         0 }
4772 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4773 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4774 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4775             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4776 0         0 $file = qq{"$file"};
4777 0 0       0 }
4778 0         0 my $fh = gensym();
4779             if (_open_r($fh, $_)) {
4780             close $fh;
4781 0 0 0     0  
    0          
4782 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4783             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4784             CORE::system 'DEL', '/F', $file, '2>NUL';
4785             }
4786              
4787 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4788             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4789             CORE::system 'DEL', '/F', $file, '2>NUL';
4790             }
4791              
4792             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4793 0         0 # command.com can not "2>NUL"
4794 0         0 else {
4795             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4796             CORE::system 'DEL', $file;
4797 0 0       0 }
4798 0         0  
4799             if (_open_r($fh, $_)) {
4800             close $fh;
4801 0         0 }
4802             else {
4803             $unlink++;
4804             }
4805             }
4806 0         0 }
4807             }
4808             return $unlink;
4809             }
4810              
4811             #
4812             # INFORMIX V6 ALS chdir
4813             #
4814 0 0   0 0 0 sub Einformixv6als::chdir(;$) {
4815 0         0  
4816             if (@_ == 0) {
4817             return CORE::chdir;
4818 0         0 }
4819              
4820 0 0       0 my($dir) = @_;
4821 0 0       0  
4822 0         0 if (_MSWin32_5Cended_path($dir)) {
4823             if (not Einformixv6als::d $dir) {
4824             return 0;
4825 0 0 0     0 }
    0          
4826 0         0  
4827             if ($] =~ /^5\.005/oxms) {
4828             return CORE::chdir $dir;
4829 0         0 }
4830 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4831             local $@;
4832             my $chdir = CORE::eval q{
4833             CORE::require 'jacode.pl';
4834              
4835             # P.676 ${^WIDE_SYSTEM_CALLS}
4836             # in Chapter 28: Special Names
4837             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4838              
4839             # P.790 ${^WIDE_SYSTEM_CALLS}
4840             # in Chapter 25: Special Names
4841             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4842              
4843             local ${^WIDE_SYSTEM_CALLS} = 1;
4844 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4845 0         0 };
4846             if (not $@) {
4847             return $chdir;
4848             }
4849             }
4850              
4851             # old idea (Win32 module required)
4852             elsif (0) {
4853             local $@;
4854             my $shortdir = '';
4855             my $chdir = CORE::eval q{
4856             use Win32;
4857             $shortdir = Win32::GetShortPathName($dir);
4858             if ($shortdir ne $dir) {
4859             return CORE::chdir $shortdir;
4860             }
4861             else {
4862             return 0;
4863             }
4864             };
4865             if ($@) {
4866             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4867             while ($char[-1] eq "\x5C") {
4868             pop @char;
4869             }
4870             $dir = join '', @char;
4871             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4872             }
4873             elsif ($shortdir eq $dir) {
4874             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4875             while ($char[-1] eq "\x5C") {
4876             pop @char;
4877             }
4878             $dir = join '', @char;
4879             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4880             }
4881             return $chdir;
4882             }
4883 0         0  
4884             # rejected idea ...
4885             elsif (0) {
4886              
4887             # MSDN SetCurrentDirectory function
4888             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4889             #
4890             # Data Execution Prevention (DEP)
4891             # http://vlaurie.com/computers2/Articles/dep.htm
4892             #
4893             # Learning x86 assembler with Perl -- Shibuya.pm#11
4894             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4895             #
4896             # Introduction to Win32::API programming in Perl
4897             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4898             #
4899             # DynaLoader - Dynamically load C libraries into Perl code
4900             # http://perldoc.perl.org/DynaLoader.html
4901             #
4902             # Basic knowledge of DynaLoader
4903             # http://blog.64p.org/entry/20090313/1236934042
4904              
4905             if (($] =~ /^5\.006/oxms) and
4906             ($^O eq 'MSWin32') and
4907             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4908             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4909             ) {
4910             my $x86 = join('',
4911              
4912             # PUSH Iv
4913             "\x68", pack('P', "$dir\\\0"),
4914              
4915             # MOV eAX, Iv
4916             "\xb8", pack('L',
4917             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4918             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4919             'SetCurrentDirectoryA'
4920             )
4921             ),
4922              
4923             # CALL eAX
4924             "\xff\xd0",
4925              
4926             # RETN
4927             "\xc3",
4928             );
4929             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4930             _SetCurrentDirectoryA();
4931             chomp(my $chdir = qx{chdir});
4932             if (Einformixv6als::fc($chdir) eq Einformixv6als::fc($dir)) {
4933             return 1;
4934             }
4935             else {
4936             return 0;
4937             }
4938             }
4939             }
4940              
4941             # COMMAND.COM's unhelpful tips:
4942             # Displays a list of files and subdirectories in a directory.
4943             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4944             #
4945             # Syntax:
4946             #
4947             # DIR [drive:] [path] [filename] [/Switches]
4948             #
4949             # /Z Long file names are not displayed in the file listing
4950             #
4951             # Limitations
4952             # The undocumented /Z switch (no long names) would appear to
4953             # have been not fully developed and has a couple of problems:
4954             #
4955             # 1. It will only work if:
4956             # There is no path specified (ie. for the current directory in
4957             # the current drive)
4958             # The path is specified as the root directory of any drive
4959             # (eg. C:\, D:\, etc.)
4960             # The path is specified as the current directory of any drive
4961             # by using the drive letter only (eg. C:, D:, etc.)
4962             # The path is specified as the parent directory using the ..
4963             # notation (eg. DIR .. /Z)
4964             # Any other syntax results in a "File Not Found" error message.
4965             #
4966             # 2. The /Z switch is compatable with the /S switch to show
4967             # subdirectories (as long as the above rules are followed) and
4968             # all the files are shown with short names only. The
4969             # subdirectories are also shown with short names only. However,
4970             # the header for each subdirectory after the first level gives
4971             # the subdirectory's long name.
4972             #
4973             # 3. The /Z switch is also compatable with the /B switch to give
4974             # a simple list of files with short names only. When used with
4975             # the /S switch as well, all files are listed with their full
4976             # paths. The file names themselves are all in short form, and
4977             # the path of those files in the current directory are in short
4978             # form, but the paths of any files in subdirectories are in
4979 0         0 # long filename form.
4980 0         0  
4981 0         0 my $shortdir = '';
4982 0         0 my $i = 0;
4983 0         0 my @subdir = ();
4984 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4985 0         0 my $char = $1;
4986 0         0 if (($char eq '\\') or ($char eq '/')) {
4987 0         0 $i++;
4988             $subdir[$i] = $char;
4989             $i++;
4990 0         0 }
4991             else {
4992             $subdir[$i] .= $char;
4993 0 0 0     0 }
4994 0         0 }
4995             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4996             pop @subdir;
4997             }
4998              
4999             # P.504 PERL5SHELL (Microsoft ports only)
5000             # in Chapter 19: The Command-Line Interface
5001             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5002              
5003             # P.597 PERL5SHELL (Microsoft ports only)
5004             # in Chapter 17: The Command-Line Interface
5005             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5006              
5007 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
5008 0         0 # cmd.exe on Windows NT, Windows 2000
5009 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
5010 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5011             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5012             if (Einformixv6als::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Einformixv6als::fc($subdir[-1])) {
5013 0         0  
5014 0         0 # short file name (8dot3name) here-----vv
5015 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5016 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5017             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5018             last;
5019             }
5020             }
5021             }
5022              
5023             # an idea (not so portable, only Windows 2000 or later)
5024             elsif (0) {
5025             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5026             }
5027              
5028 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5029 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5030 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5031             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5032             if (Einformixv6als::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Einformixv6als::fc($subdir[-1])) {
5033 0         0  
5034 0         0 # short file name (8dot3name) here-----vv
5035 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5036 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5037             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5038             last;
5039             }
5040             }
5041             }
5042              
5043 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5044 0         0 else {
  0         0  
5045 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5046             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5047             if (Einformixv6als::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Einformixv6als::fc($subdir[-1])) {
5048 0         0  
5049 0         0 # short file name (8dot3name) here-----v
5050 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5051 0         0 CORE::substr($shortleafdir,8,1) = '.';
5052 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5053             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5054             last;
5055             }
5056             }
5057 0 0       0 }
    0          
5058 0         0  
5059             if ($shortdir eq '') {
5060             return 0;
5061 0         0 }
5062             elsif (Einformixv6als::fc($shortdir) eq Einformixv6als::fc($dir)) {
5063 0         0 return 0;
5064             }
5065             return CORE::chdir $shortdir;
5066 0         0 }
5067             else {
5068             return CORE::chdir $dir;
5069             }
5070             }
5071              
5072             #
5073             # INFORMIX V6 ALS chr(0x5C) ended path on MSWin32
5074             #
5075 0 50 33 768   0 sub _MSWin32_5Cended_path {
5076 768 50       5328  
5077 768         5723 if ((@_ >= 1) and ($_[0] ne '')) {
5078 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5079 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5080             if ($char[-1] =~ / \x5C \z/oxms) {
5081             return 1;
5082             }
5083 0         0 }
5084             }
5085             return undef;
5086             }
5087              
5088             #
5089             # do INFORMIX V6 ALS file
5090             #
5091 768     0 0 2875 sub Einformixv6als::do($) {
5092              
5093 0         0 my($filename) = @_;
5094              
5095             my $realfilename;
5096             my $result;
5097 0         0 ITER_DO:
  0         0  
5098 0 0       0 {
5099 0         0 for my $prefix (@INC) {
5100             if ($^O eq 'MacOS') {
5101             $realfilename = "$prefix$filename";
5102 0         0 }
5103             else {
5104             $realfilename = "$prefix/$filename";
5105 0 0       0 }
5106              
5107 0         0 if (Einformixv6als::f($realfilename)) {
5108              
5109 0 0       0 my $script = '';
5110 0         0  
5111 0         0 if (Einformixv6als::e("$realfilename.e")) {
5112 0         0 my $e_mtime = (Einformixv6als::stat("$realfilename.e"))[9];
5113 0 0 0     0 my $mtime = (Einformixv6als::stat($realfilename))[9];
5114 0         0 my $module_mtime = (Einformixv6als::stat(__FILE__))[9];
5115             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5116             Einformixv6als::unlink "$realfilename.e";
5117             }
5118 0 0       0 }
5119 0         0  
5120 0 0       0 if (Einformixv6als::e("$realfilename.e")) {
5121 0 0       0 my $fh = gensym();
    0          
5122 0         0 if (_open_r($fh, "$realfilename.e")) {
5123             if ($^O eq 'MacOS') {
5124             CORE::eval q{
5125             CORE::require Mac::Files;
5126             Mac::Files::FSpSetFLock("$realfilename.e");
5127             };
5128             }
5129             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5130              
5131             # P.419 File Locking
5132             # in Chapter 16: Interprocess Communication
5133             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5134              
5135             # P.524 File Locking
5136             # in Chapter 15: Interprocess Communication
5137             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5138              
5139 0         0 # (and so on)
5140 0 0       0  
5141 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5142             if ($@) {
5143             carp "Can't immediately read-lock the file: $realfilename.e";
5144             }
5145 0         0 }
5146             else {
5147 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5148 0         0 }
5149 0 0       0 local $/ = undef; # slurp mode
5150 0         0 $script = <$fh>;
5151             if ($^O eq 'MacOS') {
5152             CORE::eval q{
5153             CORE::require Mac::Files;
5154             Mac::Files::FSpRstFLock("$realfilename.e");
5155 0         0 };
5156             }
5157             close $fh;
5158             }
5159 0         0 }
5160 0 0       0 else {
5161 0 0       0 my $fh = gensym();
    0          
5162 0         0 if (_open_r($fh, $realfilename)) {
5163             if ($^O eq 'MacOS') {
5164             CORE::eval q{
5165             CORE::require Mac::Files;
5166             Mac::Files::FSpSetFLock($realfilename);
5167             };
5168 0         0 }
5169 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5170 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5171             if ($@) {
5172             carp "Can't immediately read-lock the file: $realfilename";
5173             }
5174 0         0 }
5175             else {
5176 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5177 0         0 }
5178 0 0       0 local $/ = undef; # slurp mode
5179 0         0 $script = <$fh>;
5180             if ($^O eq 'MacOS') {
5181             CORE::eval q{
5182             CORE::require Mac::Files;
5183             Mac::Files::FSpRstFLock($realfilename);
5184 0         0 };
5185             }
5186             close $fh;
5187 0 0       0 }
5188 0         0  
5189 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
5190 0         0 CORE::require INFORMIXV6ALS;
5191 0 0       0 $script = INFORMIXV6ALS::escape_script($script);
5192 0 0       0 my $fh = gensym();
    0          
5193 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5194             if ($^O eq 'MacOS') {
5195             CORE::eval q{
5196             CORE::require Mac::Files;
5197             Mac::Files::FSpSetFLock("$realfilename.e");
5198             };
5199 0         0 }
5200 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5201 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5202             if ($@) {
5203             carp "Can't immediately write-lock the file: $realfilename.e";
5204             }
5205 0         0 }
5206             else {
5207 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5208 0 0       0 }
5209 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5210 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5211 0         0 print {$fh} $script;
5212             if ($^O eq 'MacOS') {
5213             CORE::eval q{
5214             CORE::require Mac::Files;
5215             Mac::Files::FSpRstFLock("$realfilename.e");
5216 0         0 };
5217             }
5218             close $fh;
5219             }
5220             }
5221 389     389   16535  
  389         2553  
  389         370024  
  0         0  
5222 0         0 {
5223             no strict;
5224 0         0 $result = scalar CORE::eval $script;
5225             }
5226             last ITER_DO;
5227             }
5228             }
5229 0 0       0 }
    0          
5230 0         0  
5231 0         0 if ($@) {
5232             $INC{$filename} = undef;
5233             return undef;
5234 0         0 }
5235             elsif (not $result) {
5236             return undef;
5237 0         0 }
5238 0         0 else {
5239             $INC{$filename} = $realfilename;
5240             return $result;
5241             }
5242             }
5243              
5244             #
5245             # require INFORMIX V6 ALS file
5246             #
5247              
5248             # require
5249             # in Chapter 3: Functions
5250             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5251             #
5252             # sub require {
5253             # my($filename) = @_;
5254             # return 1 if $INC{$filename};
5255             # my($realfilename, $result);
5256             # ITER: {
5257             # foreach $prefix (@INC) {
5258             # $realfilename = "$prefix/$filename";
5259             # if (-f $realfilename) {
5260             # $result = CORE::eval `cat $realfilename`;
5261             # last ITER;
5262             # }
5263             # }
5264             # die "Can't find $filename in \@INC";
5265             # }
5266             # die $@ if $@;
5267             # die "$filename did not return true value" unless $result;
5268             # $INC{$filename} = $realfilename;
5269             # return $result;
5270             # }
5271              
5272             # require
5273             # in Chapter 9: perlfunc: Perl builtin functions
5274             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5275             #
5276             # sub require {
5277             # my($filename) = @_;
5278             # if (exists $INC{$filename}) {
5279             # return 1 if $INC{$filename};
5280             # die "Compilation failed in require";
5281             # }
5282             # my($realfilename, $result);
5283             # ITER: {
5284             # foreach $prefix (@INC) {
5285             # $realfilename = "$prefix/$filename";
5286             # if (-f $realfilename) {
5287             # $INC{$filename} = $realfilename;
5288             # $result = do $realfilename;
5289             # last ITER;
5290             # }
5291             # }
5292             # die "Can't find $filename in \@INC";
5293             # }
5294             # if ($@) {
5295             # $INC{$filename} = undef;
5296             # die $@;
5297             # }
5298             # elsif (!$result) {
5299             # delete $INC{$filename};
5300             # die "$filename did not return true value";
5301             # }
5302             # else {
5303             # return $result;
5304             # }
5305             # }
5306              
5307 0 0   0 0 0 sub Einformixv6als::require(;$) {
5308              
5309 0 0       0 local $_ = shift if @_;
5310 0 0       0  
5311 0         0 if (exists $INC{$_}) {
5312             return 1 if $INC{$_};
5313             croak "Compilation failed in require: $_";
5314             }
5315              
5316             # jcode.pl
5317             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5318              
5319             # jacode.pl
5320 0 0       0 # http://search.cpan.org/dist/jacode/
5321 0         0  
5322             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5323             return CORE::require($_);
5324 0         0 }
5325              
5326             my $realfilename;
5327             my $result;
5328 0         0 ITER_REQUIRE:
  0         0  
5329 0 0       0 {
5330 0         0 for my $prefix (@INC) {
5331             if ($^O eq 'MacOS') {
5332             $realfilename = "$prefix$_";
5333 0         0 }
5334             else {
5335             $realfilename = "$prefix/$_";
5336 0 0       0 }
5337 0         0  
5338             if (Einformixv6als::f($realfilename)) {
5339 0         0 $INC{$_} = $realfilename;
5340              
5341 0 0       0 my $script = '';
5342 0         0  
5343 0         0 if (Einformixv6als::e("$realfilename.e")) {
5344 0         0 my $e_mtime = (Einformixv6als::stat("$realfilename.e"))[9];
5345 0 0 0     0 my $mtime = (Einformixv6als::stat($realfilename))[9];
5346 0         0 my $module_mtime = (Einformixv6als::stat(__FILE__))[9];
5347             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5348             Einformixv6als::unlink "$realfilename.e";
5349             }
5350 0 0       0 }
5351 0         0  
5352 0 0       0 if (Einformixv6als::e("$realfilename.e")) {
5353 0 0       0 my $fh = gensym();
    0          
5354 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5355             if ($^O eq 'MacOS') {
5356             CORE::eval q{
5357             CORE::require Mac::Files;
5358             Mac::Files::FSpSetFLock("$realfilename.e");
5359             };
5360 0         0 }
5361 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5362 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5363             if ($@) {
5364             carp "Can't immediately read-lock the file: $realfilename.e";
5365             }
5366 0         0 }
5367             else {
5368 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5369 0         0 }
5370 0 0       0 local $/ = undef; # slurp mode
5371 0         0 $script = <$fh>;
5372             if ($^O eq 'MacOS') {
5373             CORE::eval q{
5374             CORE::require Mac::Files;
5375             Mac::Files::FSpRstFLock("$realfilename.e");
5376 0 0       0 };
5377             }
5378             close($fh) or croak "Can't close file: $realfilename";
5379 0         0 }
5380 0 0       0 else {
5381 0 0       0 my $fh = gensym();
    0          
5382 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5383             if ($^O eq 'MacOS') {
5384             CORE::eval q{
5385             CORE::require Mac::Files;
5386             Mac::Files::FSpSetFLock($realfilename);
5387             };
5388 0         0 }
5389 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5390 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5391             if ($@) {
5392             carp "Can't immediately read-lock the file: $realfilename";
5393             }
5394 0         0 }
5395             else {
5396 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5397 0         0 }
5398 0 0       0 local $/ = undef; # slurp mode
5399 0         0 $script = <$fh>;
5400             if ($^O eq 'MacOS') {
5401             CORE::eval q{
5402             CORE::require Mac::Files;
5403             Mac::Files::FSpRstFLock($realfilename);
5404 0 0       0 };
5405             }
5406 0 0       0 close($fh) or croak "Can't close file: $realfilename";
5407 0         0  
5408 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
5409 0         0 CORE::require INFORMIXV6ALS;
5410 0 0       0 $script = INFORMIXV6ALS::escape_script($script);
5411 0 0       0 my $fh = gensym();
    0          
5412 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5413             if ($^O eq 'MacOS') {
5414             CORE::eval q{
5415             CORE::require Mac::Files;
5416             Mac::Files::FSpSetFLock("$realfilename.e");
5417             };
5418 0         0 }
5419 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5420 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5421             if ($@) {
5422             carp "Can't immediately write-lock the file: $realfilename.e";
5423             }
5424 0         0 }
5425             else {
5426 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5427 0 0       0 }
5428 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5429 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5430 0         0 print {$fh} $script;
5431             if ($^O eq 'MacOS') {
5432             CORE::eval q{
5433             CORE::require Mac::Files;
5434             Mac::Files::FSpRstFLock("$realfilename.e");
5435 0 0       0 };
5436             }
5437             close($fh) or croak "Can't close file: $realfilename";
5438             }
5439             }
5440 389     389   3098  
  389         3716  
  389         380396  
  0         0  
5441 0         0 {
5442             no strict;
5443 0         0 $result = scalar CORE::eval $script;
5444             }
5445             last ITER_REQUIRE;
5446 0         0 }
5447             }
5448             croak "Can't find $_ in \@INC";
5449 0 0       0 }
    0          
5450 0         0  
5451 0         0 if ($@) {
5452             $INC{$_} = undef;
5453             croak $@;
5454 0         0 }
5455 0         0 elsif (not $result) {
5456             delete $INC{$_};
5457             croak "$_ did not return true value";
5458 0         0 }
5459             else {
5460             return $result;
5461             }
5462             }
5463              
5464             #
5465             # INFORMIX V6 ALS telldir avoid warning
5466             #
5467 0     768 0 0 sub Einformixv6als::telldir(*) {
5468              
5469 768         2320 local $^W = 0;
5470              
5471             return CORE::telldir $_[0];
5472             }
5473              
5474             #
5475             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5476 768 0   0 0 29165 #
5477 0 0 0     0 sub Einformixv6als::PREMATCH {
5478 0         0 if (defined($&)) {
5479             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5480             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5481 0         0 }
5482             else {
5483             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5484             }
5485 0         0 }
5486             else {
5487 0         0 return '';
5488             }
5489             return $`;
5490             }
5491              
5492             #
5493             # ${^MATCH}, $MATCH, $& the string that matched
5494 0 0   0 0 0 #
5495 0 0       0 sub Einformixv6als::MATCH {
5496 0         0 if (defined($&)) {
5497             if (defined($1)) {
5498             return $1;
5499 0         0 }
5500             else {
5501             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5502             }
5503 0         0 }
5504             else {
5505 0         0 return '';
5506             }
5507             return $&;
5508             }
5509              
5510             #
5511             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5512 0     0 0 0 #
5513             sub Einformixv6als::POSTMATCH {
5514             return $';
5515             }
5516              
5517             #
5518             # INFORMIX V6 ALS character to order (with parameter)
5519             #
5520 0 0   0 1 0 sub INFORMIXV6ALS::ord(;$) {
5521              
5522 0 0       0 local $_ = shift if @_;
5523 0         0  
5524 0         0 if (/\A ($q_char) /oxms) {
5525 0         0 my @ord = unpack 'C*', $1;
5526 0         0 my $ord = 0;
5527             while (my $o = shift @ord) {
5528 0         0 $ord = $ord * 0x100 + $o;
5529             }
5530             return $ord;
5531 0         0 }
5532             else {
5533             return CORE::ord $_;
5534             }
5535             }
5536              
5537             #
5538             # INFORMIX V6 ALS character to order (without parameter)
5539             #
5540 0 0   0 0 0 sub INFORMIXV6ALS::ord_() {
5541 0         0  
5542 0         0 if (/\A ($q_char) /oxms) {
5543 0         0 my @ord = unpack 'C*', $1;
5544 0         0 my $ord = 0;
5545             while (my $o = shift @ord) {
5546 0         0 $ord = $ord * 0x100 + $o;
5547             }
5548             return $ord;
5549 0         0 }
5550             else {
5551             return CORE::ord $_;
5552             }
5553             }
5554              
5555             #
5556             # INFORMIX V6 ALS reverse
5557             #
5558 0 0   0 0 0 sub INFORMIXV6ALS::reverse(@) {
5559 0         0  
5560             if (wantarray) {
5561             return CORE::reverse @_;
5562             }
5563             else {
5564              
5565             # One of us once cornered Larry in an elevator and asked him what
5566             # problem he was solving with this, but he looked as far off into
5567             # the distance as he could in an elevator and said, "It seemed like
5568 0         0 # a good idea at the time."
5569              
5570             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5571             }
5572             }
5573              
5574             #
5575             # INFORMIX V6 ALS getc (with parameter, without parameter)
5576             #
5577 0     0 0 0 sub INFORMIXV6ALS::getc(;*@) {
5578 0 0       0  
5579 0 0 0     0 my($package) = caller;
5580             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5581 0         0 croak 'Too many arguments for INFORMIXV6ALS::getc' if @_ and not wantarray;
  0         0  
5582 0         0  
5583 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5584 0         0 my $getc = '';
5585 0 0       0 for my $length ($length[0] .. $length[-1]) {
5586 0 0       0 $getc .= CORE::getc($fh);
5587 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5588             if ($getc =~ /\A ${Einformixv6als::dot_s} \z/oxms) {
5589             return wantarray ? ($getc,@_) : $getc;
5590             }
5591 0 0       0 }
5592             }
5593             return wantarray ? ($getc,@_) : $getc;
5594             }
5595              
5596             #
5597             # INFORMIX V6 ALS length by character
5598             #
5599 0 0   0 1 0 sub INFORMIXV6ALS::length(;$) {
5600              
5601 0         0 local $_ = shift if @_;
5602 0         0  
5603             local @_ = /\G ($q_char) /oxmsg;
5604             return scalar @_;
5605             }
5606              
5607             #
5608             # INFORMIX V6 ALS substr by character
5609             #
5610             BEGIN {
5611              
5612             # P.232 The lvalue Attribute
5613             # in Chapter 6: Subroutines
5614             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5615              
5616             # P.336 The lvalue Attribute
5617             # in Chapter 7: Subroutines
5618             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5619              
5620             # P.144 8.4 Lvalue subroutines
5621             # in Chapter 8: perlsub: Perl subroutines
5622 389 50 0 389 1 259842 # 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  
5623              
5624             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5625             # vv----------------------*******
5626             sub INFORMIXV6ALS::substr($$;$$) %s {
5627              
5628             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5629              
5630             # If the substring is beyond either end of the string, substr() returns the undefined
5631             # value and produces a warning. When used as an lvalue, specifying a substring that
5632             # is entirely outside the string raises an exception.
5633             # http://perldoc.perl.org/functions/substr.html
5634              
5635             # A return with no argument returns the scalar value undef in scalar context,
5636             # an empty list () in list context, and (naturally) nothing at all in void
5637             # context.
5638              
5639             my $offset = $_[1];
5640             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5641             return;
5642             }
5643              
5644             # substr($string,$offset,$length,$replacement)
5645             if (@_ == 4) {
5646             my(undef,undef,$length,$replacement) = @_;
5647             my $substr = join '', splice(@char, $offset, $length, $replacement);
5648             $_[0] = join '', @char;
5649              
5650             # return $substr; this doesn't work, don't say "return"
5651             $substr;
5652             }
5653              
5654             # substr($string,$offset,$length)
5655             elsif (@_ == 3) {
5656             my(undef,undef,$length) = @_;
5657             my $octet_offset = 0;
5658             my $octet_length = 0;
5659             if ($offset == 0) {
5660             $octet_offset = 0;
5661             }
5662             elsif ($offset > 0) {
5663             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5664             }
5665             else {
5666             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5667             }
5668             if ($length == 0) {
5669             $octet_length = 0;
5670             }
5671             elsif ($length > 0) {
5672             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5673             }
5674             else {
5675             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5676             }
5677             CORE::substr($_[0], $octet_offset, $octet_length);
5678             }
5679              
5680             # substr($string,$offset)
5681             else {
5682             my $octet_offset = 0;
5683             if ($offset == 0) {
5684             $octet_offset = 0;
5685             }
5686             elsif ($offset > 0) {
5687             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5688             }
5689             else {
5690             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5691             }
5692             CORE::substr($_[0], $octet_offset);
5693             }
5694             }
5695             END
5696             }
5697              
5698             #
5699             # INFORMIX V6 ALS index by character
5700             #
5701 0     0 1 0 sub INFORMIXV6ALS::index($$;$) {
5702 0 0       0  
5703 0         0 my $index;
5704             if (@_ == 3) {
5705             $index = Einformixv6als::index($_[0], $_[1], CORE::length(INFORMIXV6ALS::substr($_[0], 0, $_[2])));
5706 0         0 }
5707             else {
5708             $index = Einformixv6als::index($_[0], $_[1]);
5709 0 0       0 }
5710 0         0  
5711             if ($index == -1) {
5712             return -1;
5713 0         0 }
5714             else {
5715             return INFORMIXV6ALS::length(CORE::substr $_[0], 0, $index);
5716             }
5717             }
5718              
5719             #
5720             # INFORMIX V6 ALS rindex by character
5721             #
5722 0     0 1 0 sub INFORMIXV6ALS::rindex($$;$) {
5723 0 0       0  
5724 0         0 my $rindex;
5725             if (@_ == 3) {
5726             $rindex = Einformixv6als::rindex($_[0], $_[1], CORE::length(INFORMIXV6ALS::substr($_[0], 0, $_[2])));
5727 0         0 }
5728             else {
5729             $rindex = Einformixv6als::rindex($_[0], $_[1]);
5730 0 0       0 }
5731 0         0  
5732             if ($rindex == -1) {
5733             return -1;
5734 0         0 }
5735             else {
5736             return INFORMIXV6ALS::length(CORE::substr $_[0], 0, $rindex);
5737             }
5738             }
5739              
5740 389     389   3068 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         2500  
  389         54733  
5741             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5742             use vars qw($slash); $slash = 'm//';
5743              
5744             # ord() to ord() or INFORMIXV6ALS::ord()
5745             my $function_ord = 'ord';
5746              
5747             # ord to ord or INFORMIXV6ALS::ord_
5748             my $function_ord_ = 'ord';
5749              
5750             # reverse to reverse or INFORMIXV6ALS::reverse
5751             my $function_reverse = 'reverse';
5752              
5753             # getc to getc or INFORMIXV6ALS::getc
5754             my $function_getc = 'getc';
5755              
5756             # P.1023 Appendix W.9 Multibyte Anchoring
5757             # of ISBN 1-56592-224-7 CJKV Information Processing
5758              
5759             my $anchor = '';
5760 389     389   3938 $anchor = q{${Einformixv6als::anchor}};
  389     0   2460  
  389         22952155  
5761              
5762             use vars qw($nest);
5763              
5764             # regexp of nested parens in qqXX
5765              
5766             # P.340 Matching Nested Constructs with Embedded Code
5767             # in Chapter 7: Perl
5768             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5769              
5770             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5771             [^\x81-\x9F\xE0-\xFD\\()] |
5772             \( (?{$nest++}) |
5773             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5774             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5775             \\ [^\x81-\x9F\xE0-\xFDc] |
5776             \\c[\x40-\x5F] |
5777             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5778             [\x00-\xFF]
5779             }xms;
5780              
5781             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5782             [^\x81-\x9F\xE0-\xFD\\{}] |
5783             \{ (?{$nest++}) |
5784             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5785             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5786             \\ [^\x81-\x9F\xE0-\xFDc] |
5787             \\c[\x40-\x5F] |
5788             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5789             [\x00-\xFF]
5790             }xms;
5791              
5792             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5793             [^\x81-\x9F\xE0-\xFD\\\[\]] |
5794             \[ (?{$nest++}) |
5795             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5796             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5797             \\ [^\x81-\x9F\xE0-\xFDc] |
5798             \\c[\x40-\x5F] |
5799             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5800             [\x00-\xFF]
5801             }xms;
5802              
5803             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5804             [^\x81-\x9F\xE0-\xFD\\<>] |
5805             \< (?{$nest++}) |
5806             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5807             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5808             \\ [^\x81-\x9F\xE0-\xFDc] |
5809             \\c[\x40-\x5F] |
5810             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5811             [\x00-\xFF]
5812             }xms;
5813              
5814             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5815             (?: ::)? (?:
5816             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5817             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5818             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5819             ))
5820             }xms;
5821              
5822             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5823             (?: ::)? (?:
5824             (?>[0-9]+) |
5825             [^\x81-\x9F\xE0-\xFDa-zA-Z_0-9\[\]] |
5826             ^[A-Z] |
5827             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5828             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5829             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5830             ))
5831             }xms;
5832              
5833             my $qq_substr = qr{(?> Char::substr | INFORMIXV6ALS::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5834             }xms;
5835              
5836             # regexp of nested parens in qXX
5837             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5838             [^\x81-\x9F\xE0-\xFD()] |
5839             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5840             \( (?{$nest++}) |
5841             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5842             [\x00-\xFF]
5843             }xms;
5844              
5845             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5846             [^\x81-\x9F\xE0-\xFD\{\}] |
5847             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5848             \{ (?{$nest++}) |
5849             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5850             [\x00-\xFF]
5851             }xms;
5852              
5853             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5854             [^\x81-\x9F\xE0-\xFD\[\]] |
5855             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5856             \[ (?{$nest++}) |
5857             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5858             [\x00-\xFF]
5859             }xms;
5860              
5861             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5862             [^\x81-\x9F\xE0-\xFD<>] |
5863             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
5864             \< (?{$nest++}) |
5865             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5866             [\x00-\xFF]
5867             }xms;
5868              
5869             my $matched = '';
5870             my $s_matched = '';
5871             $matched = q{$Einformixv6als::matched};
5872             $s_matched = q{ Einformixv6als::s_matched();};
5873              
5874             my $tr_variable = ''; # variable of tr///
5875             my $sub_variable = ''; # variable of s///
5876             my $bind_operator = ''; # =~ or !~
5877              
5878             my @heredoc = (); # here document
5879             my @heredoc_delimiter = ();
5880             my $here_script = ''; # here script
5881              
5882             #
5883             # escape INFORMIX V6 ALS script
5884 0 50   384 0 0 #
5885             sub INFORMIXV6ALS::escape(;$) {
5886             local($_) = $_[0] if @_;
5887              
5888             # P.359 The Study Function
5889             # in Chapter 7: Perl
5890 384         2294 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5891              
5892             study $_; # Yes, I studied study yesterday.
5893              
5894             # while all script
5895              
5896             # 6.14. Matching from Where the Last Pattern Left Off
5897             # in Chapter 6. Pattern Matching
5898             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5899             # (and so on)
5900              
5901             # one member of Tag-team
5902             #
5903             # P.128 Start of match (or end of previous match): \G
5904             # P.130 Advanced Use of \G with Perl
5905             # in Chapter 3: Overview of Regular Expression Features and Flavors
5906             # P.255 Use leading anchors
5907             # P.256 Expose ^ and \G at the front expressions
5908             # in Chapter 6: Crafting an Efficient Expression
5909             # P.315 "Tag-team" matching with /gc
5910             # in Chapter 7: Perl
5911 384         803 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5912 384         729  
5913 384         1550 my $e_script = '';
5914             while (not /\G \z/oxgc) { # member
5915             $e_script .= INFORMIXV6ALS::escape_token();
5916 187822         319696 }
5917              
5918             return $e_script;
5919             }
5920              
5921             #
5922             # escape INFORMIX V6 ALS token of script
5923             #
5924             sub INFORMIXV6ALS::escape_token {
5925              
5926 384     187822 0 6104 # \n output here document
5927              
5928             my $ignore_modules = join('|', qw(
5929             utf8
5930             bytes
5931             charnames
5932             I18N::Japanese
5933             I18N::Collate
5934             I18N::JExt
5935             File::DosGlob
5936             Wild
5937             Wildcard
5938             Japanese
5939             ));
5940              
5941             # another member of Tag-team
5942             #
5943             # P.315 "Tag-team" matching with /gc
5944             # in Chapter 7: Perl
5945 187822 100 100     249928 # 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          
5946 187822         14636918  
5947 31404 100       41334 if (/\G ( \n ) /oxgc) { # another member (and so on)
5948 31404         58009 my $heredoc = '';
5949             if (scalar(@heredoc_delimiter) >= 1) {
5950 197         266 $slash = 'm//';
5951 197         412  
5952             $heredoc = join '', @heredoc;
5953             @heredoc = ();
5954 197         352  
5955 197         371 # skip here document
5956             for my $heredoc_delimiter (@heredoc_delimiter) {
5957 205         1290 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5958             }
5959 197         371 @heredoc_delimiter = ();
5960              
5961 197         289 $here_script = '';
5962             }
5963             return "\n" . $heredoc;
5964             }
5965 31404         93433  
5966             # ignore space, comment
5967             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5968              
5969             # if (, elsif (, unless (, while (, until (, given (, and when (
5970              
5971             # given, when
5972              
5973             # P.225 The given Statement
5974             # in Chapter 15: Smart Matching and given-when
5975             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5976              
5977             # P.133 The given Statement
5978             # in Chapter 4: Statements and Declarations
5979             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5980 42620         131962  
5981 3773         5887 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5982             $slash = 'm//';
5983             return $1;
5984             }
5985              
5986             # scalar variable ($scalar = ...) =~ tr///;
5987             # scalar variable ($scalar = ...) =~ s///;
5988              
5989             # state
5990              
5991             # P.68 Persistent, Private Variables
5992             # in Chapter 4: Subroutines
5993             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5994              
5995             # P.160 Persistent Lexically Scoped Variables: state
5996             # in Chapter 4: Statements and Declarations
5997             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5998              
5999             # (and so on)
6000 3773         11620  
6001             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
6002 170 50       492 my $e_string = e_string($1);
    50          
6003 170         7293  
6004 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6005 0         0 $tr_variable = $e_string . e_string($1);
6006 0         0 $bind_operator = $2;
6007             $slash = 'm//';
6008             return '';
6009 0         0 }
6010 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6011 0         0 $sub_variable = $e_string . e_string($1);
6012 0         0 $bind_operator = $2;
6013             $slash = 'm//';
6014             return '';
6015 0         0 }
6016 170         382 else {
6017             $slash = 'div';
6018             return $e_string;
6019             }
6020             }
6021              
6022 170         681 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
6023 4         11 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6024             $slash = 'div';
6025             return q{Einformixv6als::PREMATCH()};
6026             }
6027              
6028 4         12 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
6029 28         55 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6030             $slash = 'div';
6031             return q{Einformixv6als::MATCH()};
6032             }
6033              
6034 28         121 # $', ${'} --> $', ${'}
6035 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6036             $slash = 'div';
6037             return $1;
6038             }
6039              
6040 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
6041 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6042             $slash = 'div';
6043             return q{Einformixv6als::POSTMATCH()};
6044             }
6045              
6046             # scalar variable $scalar =~ tr///;
6047             # scalar variable $scalar =~ s///;
6048             # substr() =~ tr///;
6049 3         9 # substr() =~ s///;
6050             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6051 2878 100       6645 my $scalar = e_string($1);
    100          
6052 2878         16517  
6053 9         17 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6054 9         14 $tr_variable = $scalar;
6055 9         15 $bind_operator = $1;
6056             $slash = 'm//';
6057             return '';
6058 9         27 }
6059 253         489 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6060 253         470 $sub_variable = $scalar;
6061 253         354 $bind_operator = $1;
6062             $slash = 'm//';
6063             return '';
6064 253         702 }
6065 2616         4136 else {
6066             $slash = 'div';
6067             return $scalar;
6068             }
6069             }
6070              
6071 2616         7578 # end of statement
6072             elsif (/\G ( [,;] ) /oxgc) {
6073             $slash = 'm//';
6074 12209         19359  
6075             # clear tr/// variable
6076             $tr_variable = '';
6077 12209         15539  
6078             # clear s/// variable
6079 12209         15162 $sub_variable = '';
6080              
6081 12209         14720 $bind_operator = '';
6082              
6083             return $1;
6084             }
6085              
6086 12209         43499 # bareword
6087             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6088             return $1;
6089             }
6090              
6091 0         0 # $0 --> $0
6092 2         4 elsif (/\G ( \$ 0 ) /oxmsgc) {
6093             $slash = 'div';
6094             return $1;
6095 2         9 }
6096 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6097             $slash = 'div';
6098             return $1;
6099             }
6100              
6101 0         0 # $$ --> $$
6102 1         3 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6103             $slash = 'div';
6104             return $1;
6105             }
6106              
6107             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6108 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
6109 219         365 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6110             $slash = 'div';
6111             return e_capture($1);
6112 219         537 }
6113 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6114             $slash = 'div';
6115             return e_capture($1);
6116             }
6117              
6118 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6119 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6120             $slash = 'div';
6121             return e_capture($1.'->'.$2);
6122             }
6123              
6124 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6125 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6126             $slash = 'div';
6127             return e_capture($1.'->'.$2);
6128             }
6129              
6130 0         0 # $$foo
6131 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6132             $slash = 'div';
6133             return e_capture($1);
6134             }
6135              
6136 0         0 # ${ foo }
6137 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6138             $slash = 'div';
6139             return '${' . $1 . '}';
6140             }
6141              
6142 0         0 # ${ ... }
6143 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6144             $slash = 'div';
6145             return e_capture($1);
6146             }
6147              
6148             # variable or function
6149 0         0 # $ @ % & * $ #
6150 605         981 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) {
6151             $slash = 'div';
6152             return $1;
6153             }
6154             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6155 605         1908 # $ @ # \ ' " / ? ( ) [ ] < >
6156 103         418 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6157             $slash = 'div';
6158             return $1;
6159             }
6160              
6161 103         372 # while ()
6162             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6163             return $1;
6164             }
6165              
6166             # while () --- glob
6167              
6168             # avoid "Error: Runtime exception" of perl version 5.005_03
6169 0         0  
6170             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) {
6171             return 'while ($_ = Einformixv6als::glob("' . $1 . '"))';
6172             }
6173              
6174 0         0 # while (glob)
6175             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6176             return 'while ($_ = Einformixv6als::glob_)';
6177             }
6178              
6179 0         0 # while (glob(WILDCARD))
6180             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6181             return 'while ($_ = Einformixv6als::glob';
6182             }
6183 0         0  
  482         1145  
6184             # doit if, doit unless, doit while, doit until, doit for, doit when
6185             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6186 482         2040  
  19         33  
6187 19         63 # subroutines of package Einformixv6als
  0         0  
6188 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         19  
6189 13         37 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6190 0         0 elsif (/\G \b INFORMIXV6ALS::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         184  
6191 114         338 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
6192 2         9 elsif (/\G \b INFORMIXV6ALS::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval INFORMIXV6ALS::escape'; }
  2         6  
6193 2         7 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
6194 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::chop'; }
  0         0  
6195 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         4  
6196 2         6 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         3  
6197 2         6 elsif (/\G \b INFORMIXV6ALS::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'INFORMIXV6ALS::index'; }
  2         5  
6198 2         7 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::index'; }
  0         0  
6199 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         4  
6200 2         6 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         3  
6201 2         7 elsif (/\G \b INFORMIXV6ALS::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'INFORMIXV6ALS::rindex'; }
  1         3  
6202 1         4 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::rindex'; }
  0         0  
6203 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lc'; }
  0         0  
6204 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lcfirst'; }
  0         0  
6205 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::uc'; }
  3         6  
6206             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::ucfirst'; }
6207             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::fc'; }
6208              
6209             # stacked file test operators
6210              
6211             # P.179 File Test Operators
6212             # in Chapter 12: File Tests
6213             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6214              
6215             # P.106 Named Unary and File Test Operators
6216             # in Chapter 3: Unary and Binary Operators
6217             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6218              
6219             # (and so on)
6220 3         8  
  0         0  
6221 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6222 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6223 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  
6224 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  
6225 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  
6226 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         4  
6227             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6228             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) . ")"; }
6229 1         5  
  5         14  
6230 5         20 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6231 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6232 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  
6233 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  
6234 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  
6235 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  
6236             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6237             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) . ")"; }
6238 1         5  
  0         0  
6239 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6240 0         0 { $slash = 'm//'; return "Einformixv6als::filetest(qw($1),$2)"; }
  0         0  
6241 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1),$2)"; }
  0         0  
6242             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest qw($1),"; }
6243 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest(qw($1),$2)"; }
  0         0  
6244 0         0  
  0         0  
6245 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6246 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6247 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6248 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6249 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         4  
6250             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6251 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         195  
6252 103         300  
  0         0  
6253 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6254 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6255 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6256 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6257 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         5  
6258             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6259             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6260 2         15  
  6         16  
6261 6         34 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6262 0         0 { $slash = 'm//'; return "Einformixv6als::$1($2)"; }
  0         0  
6263 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1($2)"; }
  50         90  
6264 50         255 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1"; }
  2         6  
6265 2         9 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Einformixv6als::$1(::"."$2)"; }
  1         3  
6266 1         5 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         11  
6267             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lstat'; }
6268             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::stat'; }
6269 3         12  
  0         0  
6270 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6271 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6272 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6273 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6274 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6275 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6276             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6277 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  
6278 0         0  
  0         0  
6279 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6280 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6281 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6282 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6283 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6284             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6285             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6286 0         0  
  0         0  
6287 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6288 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6289 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6290             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6291 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
6292 2         8  
  2         5  
6293 2         7 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         92  
6294 36         156 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
6295 2         9 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::chr'; }
  2         6  
6296 2         9 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         23  
6297 8         36 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6298 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Einformixv6als::glob'; }
  0         0  
6299 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lc_'; }
  0         0  
6300 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lcfirst_'; }
  0         0  
6301 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::uc_'; }
  0         0  
6302 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::ucfirst_'; }
  0         0  
6303 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::fc_'; }
  0         0  
6304             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::lstat_'; }
6305 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::stat_'; }
  0         0  
6306             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6307 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Einformixv6als::filetest_(qw($1))"; }
  0         0  
6308             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6309 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Einformixv6als::${1}_"; }
  0         0  
6310              
6311 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6312 0         0  
  0         0  
6313 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6314 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6315 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::chr_'; }
  2         7  
6316 2         8 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6317 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         11  
6318 4         18 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::glob_'; }
  8         21  
6319 8         35 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         7  
6320 2         13 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6321 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Einformixv6als::opendir$1*"; }
  87         248  
6322             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Einformixv6als::opendir$1*"; }
6323             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Einformixv6als::unlink'; }
6324              
6325 87         394 # chdir
6326             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6327 3         7 $slash = 'm//';
6328              
6329 3         5 my $e = 'Einformixv6als::chdir';
6330 3         12  
6331             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6332             $e .= $1;
6333             }
6334 3 50       12  
  3 100       258  
    50          
    50          
    50          
    0          
6335             # end of chdir
6336             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6337 0         0  
6338             # chdir scalar value
6339             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6340              
6341 1 0       4 # chdir qq//
  0         0  
6342             elsif (/\G \b (qq) \b /oxgc) {
6343 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6344 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6345 0         0 while (not /\G \z/oxgc) {
6346 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6347 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6348 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6349 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6350 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6351             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6352 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6353             }
6354             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6355             }
6356             }
6357              
6358 0 0       0 # chdir q//
  0         0  
6359             elsif (/\G \b (q) \b /oxgc) {
6360 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6361 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6362 0         0 while (not /\G \z/oxgc) {
6363 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6364 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6365 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6366 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6367 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6368             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6369 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6370             }
6371             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6372             }
6373             }
6374              
6375 0         0 # chdir ''
6376 2         6 elsif (/\G (\') /oxgc) {
6377 2 50       6 my $q_string = '';
  13 50       67  
    100          
    50          
6378 0         0 while (not /\G \z/oxgc) {
6379 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6380 2         6 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6381             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6382 11         31 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6383             }
6384             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6385             }
6386              
6387 0         0 # chdir ""
6388 0         0 elsif (/\G (\") /oxgc) {
6389 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6390 0         0 while (not /\G \z/oxgc) {
6391 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6392 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6393             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6394 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6395             }
6396             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6397             }
6398             }
6399              
6400 0         0 # split
6401             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6402 404         912 $slash = 'm//';
6403 404         670  
6404 404         1477 my $e = '';
6405             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6406             $e .= $1;
6407             }
6408 401 100       1576  
  404 100       18833  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6409             # end of split
6410             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Einformixv6als::split' . $e; }
6411 3         15  
6412             # split scalar value
6413             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Einformixv6als::split' . $e . e_string($1); }
6414 1         5  
6415 0         0 # split literal space
6416 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Einformixv6als::split' . $e . qq {qq$1 $2}; }
6417 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6418 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6419 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6420 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6421 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; }
6422 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Einformixv6als::split' . $e . qq {q$1 $2}; }
6423 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6424 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6425 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6426 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6427 13         74 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Einformixv6als::split' . $e . qq {$1q$2 $3}; }
6428             elsif (/\G ' [ ] ' /oxgc) { return 'Einformixv6als::split' . $e . qq {' '}; }
6429             elsif (/\G " [ ] " /oxgc) { return 'Einformixv6als::split' . $e . qq {" "}; }
6430              
6431 2 0       10 # split qq//
  0         0  
6432             elsif (/\G \b (qq) \b /oxgc) {
6433 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6434 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6435 0         0 while (not /\G \z/oxgc) {
6436 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6437 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6438 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6439 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6440 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6441             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6442 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6443             }
6444             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6445             }
6446             }
6447              
6448 0 50       0 # split qr//
  124         926  
6449             elsif (/\G \b (qr) \b /oxgc) {
6450 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6451 124 50       350 else {
  124 50       6263  
    50          
    50          
    50          
    100          
    50          
    50          
6452 0         0 while (not /\G \z/oxgc) {
6453 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6454 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6455 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6456 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6457 56         275 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6458 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6459             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6460 68         311 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6461             }
6462             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6463             }
6464             }
6465              
6466 0 0       0 # split q//
  0         0  
6467             elsif (/\G \b (q) \b /oxgc) {
6468 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6469 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6470 0         0 while (not /\G \z/oxgc) {
6471 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6472 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6473 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6474 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6475 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6476             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6477 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6478             }
6479             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6480             }
6481             }
6482              
6483 0 50       0 # split m//
  136         1020  
6484             elsif (/\G \b (m) \b /oxgc) {
6485 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6486 136 50       449 else {
  136 50       7293  
    50          
    50          
    50          
    100          
    50          
    50          
6487 0         0 while (not /\G \z/oxgc) {
6488 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6489 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6490 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6491 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6492 56         264 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6493 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6494             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6495 80         370 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6496             }
6497             die __FILE__, ": Search pattern not terminated\n";
6498             }
6499             }
6500              
6501 0         0 # split ''
6502 0         0 elsif (/\G (\') /oxgc) {
6503 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6504 0         0 while (not /\G \z/oxgc) {
6505 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6506 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6507             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6508 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6509             }
6510             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6511             }
6512              
6513 0         0 # split ""
6514 0         0 elsif (/\G (\") /oxgc) {
6515 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6516 0         0 while (not /\G \z/oxgc) {
6517 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6518 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6519             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6520 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6521             }
6522             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6523             }
6524              
6525 0         0 # split //
6526 125         428 elsif (/\G (\/) /oxgc) {
6527 125 50       343 my $regexp = '';
  558 50       2805  
    100          
    50          
6528 0         0 while (not /\G \z/oxgc) {
6529 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6530 125         521 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6531             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6532 433         1010 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6533             }
6534             die __FILE__, ": Search pattern not terminated\n";
6535             }
6536             }
6537              
6538             # tr/// or y///
6539              
6540             # about [cdsrbB]* (/B modifier)
6541             #
6542             # P.559 appendix C
6543             # of ISBN 4-89052-384-7 Programming perl
6544             # (Japanese title is: Perl puroguramingu)
6545 0         0  
6546             elsif (/\G \b ( tr | y ) \b /oxgc) {
6547             my $ope = $1;
6548 11 50       34  
6549 11         185 # $1 $2 $3 $4 $5 $6
6550 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6551             my @tr = ($tr_variable,$2);
6552             return e_tr(@tr,'',$4,$6);
6553 0         0 }
6554 11         17 else {
6555 11 50       33 my $e = '';
  11 50       866  
    50          
    50          
    50          
    50          
6556             while (not /\G \z/oxgc) {
6557 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6558 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6559 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6560 0         0 while (not /\G \z/oxgc) {
6561 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6562 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6563 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6564 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6565             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6566 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6567             }
6568             die __FILE__, ": Transliteration replacement not terminated\n";
6569 0         0 }
6570 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6571 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6572 0         0 while (not /\G \z/oxgc) {
6573 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6574 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6575 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6576 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6577             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6578 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6579             }
6580             die __FILE__, ": Transliteration replacement not terminated\n";
6581 0         0 }
6582 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6583 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6584 0         0 while (not /\G \z/oxgc) {
6585 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6586 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6587 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6588 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6589             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6590 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6591             }
6592             die __FILE__, ": Transliteration replacement not terminated\n";
6593 0         0 }
6594 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6595 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6596 0         0 while (not /\G \z/oxgc) {
6597 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6598 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6599 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6600 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6601             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6602 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6603             }
6604             die __FILE__, ": Transliteration replacement not terminated\n";
6605             }
6606 0         0 # $1 $2 $3 $4 $5 $6
6607 11         47 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6608             my @tr = ($tr_variable,$2);
6609             return e_tr(@tr,'',$4,$6);
6610 11         34 }
6611             }
6612             die __FILE__, ": Transliteration pattern not terminated\n";
6613             }
6614             }
6615              
6616 0         0 # qq//
6617             elsif (/\G \b (qq) \b /oxgc) {
6618             my $ope = $1;
6619 5897 100       16388  
6620 5897         11593 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6621 40         54 if (/\G (\#) /oxgc) { # qq# #
6622 40 100       103 my $qq_string = '';
  1948 50       6344  
    100          
    50          
6623 80         165 while (not /\G \z/oxgc) {
6624 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6625 40         117 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6626             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6627 1828         3576 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6628             }
6629             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6630             }
6631 0         0  
6632 5857         8177 else {
6633 5857 50       14814 my $e = '';
  5857 50       32471  
    100          
    50          
    100          
    50          
6634             while (not /\G \z/oxgc) {
6635             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6636              
6637 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6638 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6639 0         0 my $qq_string = '';
6640 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6641 0         0 while (not /\G \z/oxgc) {
6642 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6643             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6644 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6645 0         0 elsif (/\G (\)) /oxgc) {
6646             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6647 0         0 else { $qq_string .= $1; }
6648             }
6649 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6650             }
6651             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6652             }
6653              
6654 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6655 5775         8071 elsif (/\G (\{) /oxgc) { # qq { }
6656 5775         8729 my $qq_string = '';
6657 5775 100       11810 local $nest = 1;
  246465 50       822532  
    100          
    100          
    50          
6658 720         1492 while (not /\G \z/oxgc) {
6659 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         2121  
6660             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6661 1384 100       2448 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         11626  
6662 5775         12524 elsif (/\G (\}) /oxgc) {
6663             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6664 1384         2778 else { $qq_string .= $1; }
6665             }
6666 237202         500941 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6667             }
6668             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6669             }
6670              
6671 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6672 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6673 0         0 my $qq_string = '';
6674 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6675 0         0 while (not /\G \z/oxgc) {
6676 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6677             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6678 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6679 0         0 elsif (/\G (\]) /oxgc) {
6680             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6681 0         0 else { $qq_string .= $1; }
6682             }
6683 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6684             }
6685             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6686             }
6687              
6688 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6689 62         111 elsif (/\G (\<) /oxgc) { # qq < >
6690 62         114 my $qq_string = '';
6691 62 100       238 local $nest = 1;
  2040 50       9891  
    100          
    100          
    50          
6692 22         67 while (not /\G \z/oxgc) {
6693 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         5  
6694             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6695 2 100       7 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         181  
6696 62         226 elsif (/\G (\>) /oxgc) {
6697             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6698 2         5 else { $qq_string .= $1; }
6699             }
6700 1952         4227 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6701             }
6702             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6703             }
6704              
6705 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6706 20         32 elsif (/\G (\S) /oxgc) { # qq * *
6707 20         27 my $delimiter = $1;
6708 20 50       39 my $qq_string = '';
  840 50       2445  
    100          
    50          
6709 0         0 while (not /\G \z/oxgc) {
6710 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6711 20         44 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6712             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6713 820         1582 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6714             }
6715             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6716 0         0 }
6717             }
6718             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6719             }
6720             }
6721              
6722 0         0 # qr//
6723 184 50       520 elsif (/\G \b (qr) \b /oxgc) {
6724 184         799 my $ope = $1;
6725             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6726             return e_qr($ope,$1,$3,$2,$4);
6727 0         0 }
6728 184         278 else {
6729 184 50       479 my $e = '';
  184 50       4910  
    100          
    50          
    50          
    100          
    50          
    50          
6730 0         0 while (not /\G \z/oxgc) {
6731 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6732 1         4 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6733 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6734 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6735 76         213 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6736 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6737             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6738 107         330 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6739             }
6740             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6741             }
6742             }
6743              
6744 0         0 # qw//
6745 34 50       107 elsif (/\G \b (qw) \b /oxgc) {
6746 34         112 my $ope = $1;
6747             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6748             return e_qw($ope,$1,$3,$2);
6749 0         0 }
6750 34         66 else {
6751 34 50       115 my $e = '';
  34 50       206  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6752             while (not /\G \z/oxgc) {
6753 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6754 34         123  
6755             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6756 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6757 0         0  
6758             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6759 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6760 0         0  
6761             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6762 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6763 0         0  
6764             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6765 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6766 0         0  
6767             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6768 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6769             }
6770             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6771             }
6772             }
6773              
6774 0         0 # qx//
6775 3 50       10 elsif (/\G \b (qx) \b /oxgc) {
6776 3         77 my $ope = $1;
6777             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6778             return e_qq($ope,$1,$3,$2);
6779 0         0 }
6780 3         9 else {
6781 3 50       12 my $e = '';
  3 50       434  
    100          
    50          
    50          
    50          
    50          
6782 0         0 while (not /\G \z/oxgc) {
6783 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6784 2         8 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6785 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6786 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6787 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6788             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6789 1         5 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6790             }
6791             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6792             }
6793             }
6794              
6795 0         0 # q//
6796             elsif (/\G \b (q) \b /oxgc) {
6797             my $ope = $1;
6798              
6799             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6800              
6801             # avoid "Error: Runtime exception" of perl version 5.005_03
6802 606 50       2300 # (and so on)
6803 606         1896  
6804 0         0 if (/\G (\#) /oxgc) { # q# #
6805 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6806 0         0 while (not /\G \z/oxgc) {
6807 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6808 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6809             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6810 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6811             }
6812             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6813             }
6814 0         0  
6815 606         1204 else {
6816 606 50       2280 my $e = '';
  606 100       3819  
    100          
    50          
    100          
    50          
6817             while (not /\G \z/oxgc) {
6818             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6819              
6820 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6821 1         2 elsif (/\G (\() /oxgc) { # q ( )
6822 1         2 my $q_string = '';
6823 1 50       3 local $nest = 1;
  7 50       54  
    50          
    50          
    100          
    50          
6824 0         0 while (not /\G \z/oxgc) {
6825 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6826 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6827             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6828 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         2  
6829 1         3 elsif (/\G (\)) /oxgc) {
6830             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6831 0         0 else { $q_string .= $1; }
6832             }
6833 6         15 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6834             }
6835             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6836             }
6837              
6838 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6839 599         1216 elsif (/\G (\{) /oxgc) { # q { }
6840 599         1139 my $q_string = '';
6841 599 50       2050 local $nest = 1;
  8319 50       40782  
    50          
    100          
    100          
    50          
6842 0         0 while (not /\G \z/oxgc) {
6843 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6844 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         191  
6845             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6846 114 100       205 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1664  
6847 599         2192 elsif (/\G (\}) /oxgc) {
6848             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6849 114         246 else { $q_string .= $1; }
6850             }
6851 7492         16005 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6852             }
6853             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6854             }
6855              
6856 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6857 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6858 0         0 my $q_string = '';
6859 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6860 0         0 while (not /\G \z/oxgc) {
6861 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6862 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6863             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6864 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6865 0         0 elsif (/\G (\]) /oxgc) {
6866             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6867 0         0 else { $q_string .= $1; }
6868             }
6869 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6870             }
6871             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6872             }
6873              
6874 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6875 5         11 elsif (/\G (\<) /oxgc) { # q < >
6876 5         11 my $q_string = '';
6877 5 50       19 local $nest = 1;
  82 50       448  
    50          
    50          
    100          
    50          
6878 0         0 while (not /\G \z/oxgc) {
6879 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6880 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6881             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6882 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         15  
6883 5         17 elsif (/\G (\>) /oxgc) {
6884             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6885 0         0 else { $q_string .= $1; }
6886             }
6887 77         157 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6888             }
6889             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6890             }
6891              
6892 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6893 1         2 elsif (/\G (\S) /oxgc) { # q * *
6894 1         2 my $delimiter = $1;
6895 1 50       3 my $q_string = '';
  14 50       84  
    100          
    50          
6896 0         0 while (not /\G \z/oxgc) {
6897 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6898 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6899             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6900 13         30 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6901             }
6902             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6903 0         0 }
6904             }
6905             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6906             }
6907             }
6908              
6909 0         0 # m//
6910 491 50       1356 elsif (/\G \b (m) \b /oxgc) {
6911 491         3147 my $ope = $1;
6912             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6913             return e_qr($ope,$1,$3,$2,$4);
6914 0         0 }
6915 491         789 else {
6916 491 50       1634 my $e = '';
  491 50       23157  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6917 0         0 while (not /\G \z/oxgc) {
6918 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6919 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6920 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6921 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6922 92         267 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6923 87         251 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6924 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6925             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6926 312         1199 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6927             }
6928             die __FILE__, ": Search pattern not terminated\n";
6929             }
6930             }
6931              
6932             # s///
6933              
6934             # about [cegimosxpradlunbB]* (/cg modifier)
6935             #
6936             # P.67 Pattern-Matching Operators
6937             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6938 0         0  
6939             elsif (/\G \b (s) \b /oxgc) {
6940             my $ope = $1;
6941 290 100       824  
6942 290         4877 # $1 $2 $3 $4 $5 $6
6943             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6944             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6945 1         7 }
6946 289         515 else {
6947 289 50       829 my $e = '';
  289 50       31178  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6948             while (not /\G \z/oxgc) {
6949 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6950 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6951 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6952             while (not /\G \z/oxgc) {
6953 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6954 0         0 # $1 $2 $3 $4
6955 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6956 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6957 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6958 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6959 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6963 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6964             }
6965             die __FILE__, ": Substitution replacement not terminated\n";
6966 0         0 }
6967 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6968 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6969             while (not /\G \z/oxgc) {
6970 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6971 0         0 # $1 $2 $3 $4
6972 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6973 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6974 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6975 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6976 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6979             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6980 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6981             }
6982             die __FILE__, ": Substitution replacement not terminated\n";
6983 0         0 }
6984 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6985 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6986             while (not /\G \z/oxgc) {
6987 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6988 0         0 # $1 $2 $3 $4
6989 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6990 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6991 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6995 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6996             }
6997             die __FILE__, ": Substitution replacement not terminated\n";
6998 0         0 }
6999 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
7000 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7001             while (not /\G \z/oxgc) {
7002 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7003 0         0 # $1 $2 $3 $4
7004 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7005 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7006 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7007 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7008 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7009 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7010 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7011             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7012 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7013             }
7014             die __FILE__, ": Substitution replacement not terminated\n";
7015             }
7016 0         0 # $1 $2 $3 $4 $5 $6
7017             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7018             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7019             }
7020 96         280 # $1 $2 $3 $4 $5 $6
7021             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7022             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7023             }
7024 2         26 # $1 $2 $3 $4 $5 $6
7025             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7026             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7027             }
7028 0         0 # $1 $2 $3 $4 $5 $6
7029             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7030             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7031 191         759 }
7032             }
7033             die __FILE__, ": Substitution pattern not terminated\n";
7034             }
7035             }
7036 0         0  
7037 1         6 # do
7038 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7039 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Einformixv6als::do'; }
7040 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7041             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7042             elsif (/\G \b do \b /oxmsgc) { return 'Einformixv6als::do'; }
7043 2         9  
7044 0         0 # require ignore module
7045 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7046             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "# require$1\n$2"; }
7047             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7048 0         0  
7049 0         0 # require version number
7050 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7051             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7052             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7053 0         0  
7054             # require bare package name
7055             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7056 18         145  
7057 0         0 # require else
7058             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Einformixv6als::require;'; }
7059             elsif (/\G \b require \b /oxmsgc) { return 'Einformixv6als::require'; }
7060 1         5  
7061 70         627 # use strict; --> use strict; no strict qw(refs);
7062 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7063             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7064             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7065              
7066 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7067 3         38 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7068             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7069             return "use $1; no strict qw(refs);";
7070 0         0 }
7071             else {
7072             return "use $1;";
7073             }
7074 3 0 0     19 }
      0        
7075 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7076             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7077             return "use $1; no strict qw(refs);";
7078 0         0 }
7079             else {
7080             return "use $1;";
7081             }
7082             }
7083 0         0  
7084 2         16 # ignore use module
7085 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7086             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "# use$1\n$2"; }
7087             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7088 0         0  
7089 0         0 # ignore no module
7090 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7091             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFD#]) /oxmsgc) { return "# no$1\n$2"; }
7092             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7093 0         0  
7094 0         0 # use without import
7095 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7096 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7097 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7098 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7099 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7100 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7101 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7102 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7103             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7104             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7105 0         0  
7106             # use with import no parameter
7107             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7108 0         0  
7109 0         0 # use with import parameters
7110 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\x9F\xE0-\xFD)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7111 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\x9F\xE0-\xFD']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7112 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\x9F\xE0-\xFD"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7113 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); }
7114 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); }
7115 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); }
7116 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); }
7117             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7118             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); }
7119 0         0  
7120 0         0 # no without unimport
7121 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7122 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7123 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7124 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7125 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7126 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7127 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7128 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7129             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7130             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7131 0         0  
7132             # no with unimport no parameter
7133             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7134 0         0  
7135 0         0 # no with unimport parameters
7136 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\x9F\xE0-\xFD)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7137 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\x9F\xE0-\xFD']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7138 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\x9F\xE0-\xFD"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7139 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); }
7140 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); }
7141 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); }
7142 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); }
7143             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7144             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); }
7145 0         0  
7146             # use else
7147             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7148 0         0  
7149             # use else
7150             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7151              
7152 2         10 # ''
7153 3177         7701 elsif (/\G (?
7154 3177 100       8534 my $q_string = '';
  15808 100       57432  
    100          
    50          
7155 8         21 while (not /\G \z/oxgc) {
7156 48         87 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7157 3177         7888 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7158             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7159 12575         29522 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7160             }
7161             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7162             }
7163              
7164 0         0 # ""
7165 3404         8124 elsif (/\G (\") /oxgc) {
7166 3404 100       9581 my $qq_string = '';
  73908 100       222127  
    100          
    50          
7167 109         241 while (not /\G \z/oxgc) {
7168 14         29 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7169 3404         9598 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7170             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7171 70381         158307 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7172             }
7173             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7174             }
7175              
7176 0         0 # ``
7177 37         124 elsif (/\G (\`) /oxgc) {
7178 37 50       260 my $qx_string = '';
  313 50       2596  
    100          
    50          
7179 0         0 while (not /\G \z/oxgc) {
7180 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7181 37         137 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7182             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7183 276         662 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7184             }
7185             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7186             }
7187              
7188 0         0 # // --- not divide operator (num / num), not defined-or
7189 1231         3152 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7190 1231 100       3599 my $regexp = '';
  12510 50       44860  
    100          
    50          
7191 11         32 while (not /\G \z/oxgc) {
7192 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7193 1231         3594 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7194             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7195 11268         23780 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7196             }
7197             die __FILE__, ": Search pattern not terminated\n";
7198             }
7199              
7200 0         0 # ?? --- not conditional operator (condition ? then : else)
7201 92         218 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7202 92 50       223 my $regexp = '';
  266 50       1236  
    100          
    50          
7203 0         0 while (not /\G \z/oxgc) {
7204 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7205 92         222 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7206             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7207 174         441 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7208             }
7209             die __FILE__, ": Search pattern not terminated\n";
7210             }
7211 0         0  
  0         0  
7212             # <<>> (a safer ARGV)
7213             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7214 0         0  
  0         0  
7215             # << (bit shift) --- not here document
7216             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7217              
7218 0         0 # <<~'HEREDOC'
7219 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7220 6         11 $slash = 'm//';
7221             my $here_quote = $1;
7222             my $delimiter = $2;
7223 6 50       10  
7224 6         12 # get here document
7225 6         30 if ($here_script eq '') {
7226             $here_script = CORE::substr $_, pos $_;
7227 6 50       31 $here_script =~ s/.*?\n//oxm;
7228 6         54 }
7229 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7230 6         11 my $heredoc = $1;
7231 6         46 my $indent = $2;
7232 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
7233             push @heredoc, $heredoc . qq{\n$delimiter\n};
7234             push @heredoc_delimiter, qq{\\s*$delimiter};
7235 6         13 }
7236             else {
7237 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7238             }
7239             return qq{<<'$delimiter'};
7240             }
7241              
7242             # <<~\HEREDOC
7243              
7244             # P.66 2.6.6. "Here" Documents
7245             # in Chapter 2: Bits and Pieces
7246             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7247              
7248             # P.73 "Here" Documents
7249             # in Chapter 2: Bits and Pieces
7250             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7251 6         24  
7252 3         7 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7253 3         8 $slash = 'm//';
7254             my $here_quote = $1;
7255             my $delimiter = $2;
7256 3 50       5  
7257 3         7 # get here document
7258 3         13 if ($here_script eq '') {
7259             $here_script = CORE::substr $_, pos $_;
7260 3 50       16 $here_script =~ s/.*?\n//oxm;
7261 3         35 }
7262 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7263 3         5 my $heredoc = $1;
7264 3         35 my $indent = $2;
7265 3         10 $heredoc =~ s{^$indent}{}msg; # no /ox
7266             push @heredoc, $heredoc . qq{\n$delimiter\n};
7267             push @heredoc_delimiter, qq{\\s*$delimiter};
7268 3         7 }
7269             else {
7270 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7271             }
7272             return qq{<<\\$delimiter};
7273             }
7274              
7275 3         11 # <<~"HEREDOC"
7276 6         26 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7277 6         15 $slash = 'm//';
7278             my $here_quote = $1;
7279             my $delimiter = $2;
7280 6 50       8  
7281 6         13 # get here document
7282 6         18 if ($here_script eq '') {
7283             $here_script = CORE::substr $_, pos $_;
7284 6 50       32 $here_script =~ s/.*?\n//oxm;
7285 6         59 }
7286 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7287 6         8 my $heredoc = $1;
7288 6         45 my $indent = $2;
7289 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
7290             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7291             push @heredoc_delimiter, qq{\\s*$delimiter};
7292 6         13 }
7293             else {
7294 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7295             }
7296             return qq{<<"$delimiter"};
7297             }
7298              
7299 6         22 # <<~HEREDOC
7300 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7301 3         7 $slash = 'm//';
7302             my $here_quote = $1;
7303             my $delimiter = $2;
7304 3 50       5  
7305 3         8 # get here document
7306 3         21 if ($here_script eq '') {
7307             $here_script = CORE::substr $_, pos $_;
7308 3 50       17 $here_script =~ s/.*?\n//oxm;
7309 3         35 }
7310 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7311 3         5 my $heredoc = $1;
7312 3         32 my $indent = $2;
7313 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
7314             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7315             push @heredoc_delimiter, qq{\\s*$delimiter};
7316 3         9 }
7317             else {
7318 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7319             }
7320             return qq{<<$delimiter};
7321             }
7322              
7323 3         13 # <<~`HEREDOC`
7324 6         14 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7325 6         13 $slash = 'm//';
7326             my $here_quote = $1;
7327             my $delimiter = $2;
7328 6 50       10  
7329 6         13 # get here document
7330 6         38 if ($here_script eq '') {
7331             $here_script = CORE::substr $_, pos $_;
7332 6 50       30 $here_script =~ s/.*?\n//oxm;
7333 6         60 }
7334 6         26 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7335 6         9 my $heredoc = $1;
7336 6         47 my $indent = $2;
7337 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
7338             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7339             push @heredoc_delimiter, qq{\\s*$delimiter};
7340 6         13 }
7341             else {
7342 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7343             }
7344             return qq{<<`$delimiter`};
7345             }
7346              
7347 6         22 # <<'HEREDOC'
7348 86         213 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7349 86         217 $slash = 'm//';
7350             my $here_quote = $1;
7351             my $delimiter = $2;
7352 86 100       162  
7353 86         191 # get here document
7354 83         423 if ($here_script eq '') {
7355             $here_script = CORE::substr $_, pos $_;
7356 83 50       462 $here_script =~ s/.*?\n//oxm;
7357 86         680 }
7358 86         299 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7359             push @heredoc, $1 . qq{\n$delimiter\n};
7360             push @heredoc_delimiter, $delimiter;
7361 86         144 }
7362             else {
7363 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7364             }
7365             return $here_quote;
7366             }
7367              
7368             # <<\HEREDOC
7369              
7370             # P.66 2.6.6. "Here" Documents
7371             # in Chapter 2: Bits and Pieces
7372             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7373              
7374             # P.73 "Here" Documents
7375             # in Chapter 2: Bits and Pieces
7376             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7377 86         366  
7378 2         7 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7379 2         5 $slash = 'm//';
7380             my $here_quote = $1;
7381             my $delimiter = $2;
7382 2 100       4  
7383 2         4 # get here document
7384 1         7 if ($here_script eq '') {
7385             $here_script = CORE::substr $_, pos $_;
7386 1 50       5 $here_script =~ s/.*?\n//oxm;
7387 2         25 }
7388 2         7 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7389             push @heredoc, $1 . qq{\n$delimiter\n};
7390             push @heredoc_delimiter, $delimiter;
7391 2         12 }
7392             else {
7393 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7394             }
7395             return $here_quote;
7396             }
7397              
7398 2         11 # <<"HEREDOC"
7399 39         109 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7400 39         102 $slash = 'm//';
7401             my $here_quote = $1;
7402             my $delimiter = $2;
7403 39 100       75  
7404 39         110 # get here document
7405 38         244 if ($here_script eq '') {
7406             $here_script = CORE::substr $_, pos $_;
7407 38 50       247 $here_script =~ s/.*?\n//oxm;
7408 39         480 }
7409 39         132 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7410             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7411             push @heredoc_delimiter, $delimiter;
7412 39         94 }
7413             else {
7414 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7415             }
7416             return $here_quote;
7417             }
7418              
7419 39         159 # <
7420 54         146 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7421 54         130 $slash = 'm//';
7422             my $here_quote = $1;
7423             my $delimiter = $2;
7424 54 100       106  
7425 54         174 # get here document
7426 51         355 if ($here_script eq '') {
7427             $here_script = CORE::substr $_, pos $_;
7428 51 50       408 $here_script =~ s/.*?\n//oxm;
7429 54         698 }
7430 54         192 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7431             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7432             push @heredoc_delimiter, $delimiter;
7433 54         128 }
7434             else {
7435 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7436             }
7437             return $here_quote;
7438             }
7439              
7440 54         232 # <<`HEREDOC`
7441 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7442 0         0 $slash = 'm//';
7443             my $here_quote = $1;
7444             my $delimiter = $2;
7445 0 0       0  
7446 0         0 # get here document
7447 0         0 if ($here_script eq '') {
7448             $here_script = CORE::substr $_, pos $_;
7449 0 0       0 $here_script =~ s/.*?\n//oxm;
7450 0         0 }
7451 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7452             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7453             push @heredoc_delimiter, $delimiter;
7454 0         0 }
7455             else {
7456 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7457             }
7458             return $here_quote;
7459             }
7460              
7461 0         0 # <<= <=> <= < operator
7462             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7463             return $1;
7464             }
7465              
7466 13         80 #
7467             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7468             return $1;
7469             }
7470              
7471             # --- glob
7472              
7473             # avoid "Error: Runtime exception" of perl version 5.005_03
7474 0         0  
7475             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) {
7476             return 'Einformixv6als::glob("' . $1 . '")';
7477             }
7478 0         0  
7479             # __DATA__
7480             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7481 0         0  
7482             # __END__
7483             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7484              
7485             # \cD Control-D
7486              
7487             # P.68 2.6.8. Other Literal Tokens
7488             # in Chapter 2: Bits and Pieces
7489             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7490              
7491             # P.76 Other Literal Tokens
7492             # in Chapter 2: Bits and Pieces
7493 384         3094 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7494              
7495             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7496 0         0  
7497             # \cZ Control-Z
7498             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7499              
7500             # any operator before div
7501             elsif (/\G (
7502             -- | \+\+ |
7503 0         0 [\)\}\]]
  14161         33577  
7504              
7505             ) /oxgc) { $slash = 'div'; return $1; }
7506              
7507             # yada-yada or triple-dot operator
7508             elsif (/\G (
7509 14161         67927 \.\.\.
  7         18  
7510              
7511             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7512              
7513             # any operator before m//
7514              
7515             # //, //= (defined-or)
7516              
7517             # P.164 Logical Operators
7518             # in Chapter 10: More Control Structures
7519             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7520              
7521             # P.119 C-Style Logical (Short-Circuit) Operators
7522             # in Chapter 3: Unary and Binary Operators
7523             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7524              
7525             # (and so on)
7526              
7527             # ~~
7528              
7529             # P.221 The Smart Match Operator
7530             # in Chapter 15: Smart Matching and given-when
7531             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7532              
7533             # P.112 Smartmatch Operator
7534             # in Chapter 3: Unary and Binary Operators
7535             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7536              
7537             # (and so on)
7538              
7539             elsif (/\G ((?>
7540              
7541             !~~ | !~ | != | ! |
7542             %= | % |
7543             &&= | && | &= | &\.= | &\. | & |
7544             -= | -> | - |
7545             :(?>\s*)= |
7546             : |
7547             <<>> |
7548             <<= | <=> | <= | < |
7549             == | => | =~ | = |
7550             >>= | >> | >= | > |
7551             \*\*= | \*\* | \*= | \* |
7552             \+= | \+ |
7553             \.\. | \.= | \. |
7554             \/\/= | \/\/ |
7555             \/= | \/ |
7556             \? |
7557             \\ |
7558             \^= | \^\.= | \^\. | \^ |
7559             \b x= |
7560             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7561             ~~ | ~\. | ~ |
7562             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7563             \b(?: print )\b |
7564              
7565 7         29 [,;\(\{\[]
  23792         51527  
7566              
7567             )) /oxgc) { $slash = 'm//'; return $1; }
7568 23792         118009  
  38298         87088  
7569             # other any character
7570             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7571              
7572 38298         209139 # system error
7573             else {
7574             die __FILE__, ": Oops, this shouldn't happen!\n";
7575             }
7576             }
7577              
7578 0     3097 0 0 # escape INFORMIX V6 ALS string
7579 3097         7711 sub e_string {
7580             my($string) = @_;
7581 3097         4811 my $e_string = '';
7582              
7583             local $slash = 'm//';
7584              
7585             # P.1024 Appendix W.10 Multibyte Processing
7586             # of ISBN 1-56592-224-7 CJKV Information Processing
7587 3097         4897 # (and so on)
7588              
7589             my @char = $string =~ / \G (?>[^\x81-\x9F\xE0-\xFD\\]|\\$q_char|$q_char) /oxmsg;
7590 3097 100 66     31583  
7591 3097 50       14730 # without { ... }
7592 3018         7095 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7593             if ($string !~ /<
7594             return $string;
7595             }
7596             }
7597 3018         7676  
7598 79 50       224 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          
7599             while ($string !~ /\G \z/oxgc) {
7600             if (0) {
7601             }
7602 606         93657  
7603 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Einformixv6als::PREMATCH()]}
7604 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7605             $e_string .= q{Einformixv6als::PREMATCH()};
7606             $slash = 'div';
7607             }
7608              
7609 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Einformixv6als::MATCH()]}
7610 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7611             $e_string .= q{Einformixv6als::MATCH()};
7612             $slash = 'div';
7613             }
7614              
7615 0         0 # $', ${'} --> $', ${'}
7616 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7617             $e_string .= $1;
7618             $slash = 'div';
7619             }
7620              
7621 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Einformixv6als::POSTMATCH()]}
7622 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7623             $e_string .= q{Einformixv6als::POSTMATCH()};
7624             $slash = 'div';
7625             }
7626              
7627 0         0 # bareword
7628 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7629             $e_string .= $1;
7630             $slash = 'div';
7631             }
7632              
7633 0         0 # $0 --> $0
7634 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7635             $e_string .= $1;
7636             $slash = 'div';
7637 0         0 }
7638 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7639             $e_string .= $1;
7640             $slash = 'div';
7641             }
7642              
7643 0         0 # $$ --> $$
7644 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7645             $e_string .= $1;
7646             $slash = 'div';
7647             }
7648              
7649             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7650 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7651 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7652             $e_string .= e_capture($1);
7653             $slash = 'div';
7654 0         0 }
7655 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7656             $e_string .= e_capture($1);
7657             $slash = 'div';
7658             }
7659              
7660 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7661 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7662             $e_string .= e_capture($1.'->'.$2);
7663             $slash = 'div';
7664             }
7665              
7666 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7667 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7668             $e_string .= e_capture($1.'->'.$2);
7669             $slash = 'div';
7670             }
7671              
7672 0         0 # $$foo
7673 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7674             $e_string .= e_capture($1);
7675             $slash = 'div';
7676             }
7677              
7678 0         0 # ${ foo }
7679 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7680             $e_string .= '${' . $1 . '}';
7681             $slash = 'div';
7682             }
7683              
7684 0         0 # ${ ... }
7685 3         12 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7686             $e_string .= e_capture($1);
7687             $slash = 'div';
7688             }
7689              
7690             # variable or function
7691 3         15 # $ @ % & * $ #
7692 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) {
7693             $e_string .= $1;
7694             $slash = 'div';
7695             }
7696             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7697 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7698 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7699             $e_string .= $1;
7700             $slash = 'div';
7701             }
7702 0         0  
  0         0  
7703 0         0 # subroutines of package Einformixv6als
  0         0  
7704 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7705 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7706 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7707 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7708 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::eval \b /oxgc) { $e_string .= 'eval INFORMIXV6ALS::escape'; $slash = 'm//'; }
  0         0  
7709 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Einformixv6als::chop'; $slash = 'm//'; }
  0         0  
7711 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7712 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7713 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::index \b /oxgc) { $e_string .= 'INFORMIXV6ALS::index'; $slash = 'm//'; }
  0         0  
7714 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Einformixv6als::index'; $slash = 'm//'; }
  0         0  
7715 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7716 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7717 0         0 elsif ($string =~ /\G \b INFORMIXV6ALS::rindex \b /oxgc) { $e_string .= 'INFORMIXV6ALS::rindex'; $slash = 'm//'; }
  0         0  
7718 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Einformixv6als::rindex'; $slash = 'm//'; }
  0         0  
7719 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::lc'; $slash = 'm//'; }
  0         0  
7720 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::lcfirst'; $slash = 'm//'; }
  0         0  
7721 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::uc'; $slash = 'm//'; }
  0         0  
7722             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::ucfirst'; $slash = 'm//'; }
7723 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::fc'; $slash = 'm//'; }
  0         0  
7724 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7725 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7726 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  
7727 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  
7728 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  
7729 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         7  
7730             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//'; }
7731             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//'; }
7732 1         4  
  1         5  
7733 1         3 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7734 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7735 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  
7736 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  
7737 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  
7738 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         6  
7739             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//'; }
7740             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//'; }
7741 1         4  
  0         0  
7742 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7743 0         0 { $e_string .= "Einformixv6als::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7744 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7745             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Einformixv6als::filetest qw($1),"; $slash = 'm//'; }
7746 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Einformixv6als::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7747 0         0  
  0         0  
7748 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7749 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  
7750 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  
7751 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  
7752 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         10  
7753             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7754 2         6 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         6  
7755 1         4  
  0         0  
7756 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7757 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  
7758 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  
7759 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  
7760 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         16  
7761             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Einformixv6als::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7762             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//'; }
7763 2         6  
  0         0  
7764 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7765 0         0 { $e_string .= "Einformixv6als::$1($2)"; $slash = 'm//'; }
  0         0  
7766 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Einformixv6als::$1($2)"; $slash = 'm//'; }
  0         0  
7767 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Einformixv6als::$1"; $slash = 'm//'; }
  0         0  
7768 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Einformixv6als::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7769 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7770             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::lstat'; $slash = 'm//'; }
7771             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::stat'; $slash = 'm//'; }
7772 0         0  
  0         0  
7773 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7774 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7775 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  
7776 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  
7777 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  
7778 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  
7779             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7780 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  
7781 0         0  
  0         0  
7782 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7783 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  
7784 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  
7785 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  
7786 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  
7787             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7788             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7789 0         0  
  0         0  
7790 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7791 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7792 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7793             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7794 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7795 0         0  
  0         0  
7796 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7797 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7798 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::chr'; $slash = 'm//'; }
  0         0  
7799 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7800 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7801 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Einformixv6als::glob'; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Einformixv6als::lc_'; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Einformixv6als::lcfirst_'; $slash = 'm//'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Einformixv6als::uc_'; $slash = 'm//'; }
  0         0  
7805 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Einformixv6als::ucfirst_'; $slash = 'm//'; }
  0         0  
7806 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Einformixv6als::fc_'; $slash = 'm//'; }
  0         0  
7807             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Einformixv6als::lstat_'; $slash = 'm//'; }
7808 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Einformixv6als::stat_'; $slash = 'm//'; }
  0         0  
7809 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7810 0         0 \b /oxgc) { $e_string .= "Einformixv6als::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7811             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Einformixv6als::${1}_"; $slash = 'm//'; }
7812 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7813 0         0  
  0         0  
7814 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7815 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7816 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Einformixv6als::chr_'; $slash = 'm//'; }
  0         0  
7817 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7818 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7819 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Einformixv6als::glob_'; $slash = 'm//'; }
  0         0  
7820 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7821 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7822 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Einformixv6als::opendir$1*"; $slash = 'm//'; }
  0         0  
7823             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Einformixv6als::opendir$1*"; $slash = 'm//'; }
7824             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Einformixv6als::unlink'; $slash = 'm//'; }
7825              
7826 0         0 # chdir
7827             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7828 0         0 $slash = 'm//';
7829              
7830 0         0 $e_string .= 'Einformixv6als::chdir';
7831 0         0  
7832             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7833             $e_string .= $1;
7834             }
7835 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7836             # end of chdir
7837             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7838 0         0  
  0         0  
7839             # chdir scalar value
7840             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7841              
7842 0 0       0 # chdir qq//
  0         0  
  0         0  
7843             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7844 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7845 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7846 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7847 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7848 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7849 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7850 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7851 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7852             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7853 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7854             }
7855             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7856             }
7857             }
7858              
7859 0 0       0 # chdir q//
  0         0  
  0         0  
7860             elsif ($string =~ /\G \b (q) \b /oxgc) {
7861 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7862 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7863 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7864 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7865 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  
7866 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  
7867 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  
7868 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  
7869             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7870 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 * *
7871             }
7872             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7873             }
7874             }
7875              
7876 0         0 # chdir ''
7877 0         0 elsif ($string =~ /\G (\') /oxgc) {
7878 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7879 0         0 while ($string !~ /\G \z/oxgc) {
7880 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7881 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7882             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7883 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7884             }
7885             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7886             }
7887              
7888 0         0 # chdir ""
7889 0         0 elsif ($string =~ /\G (\") /oxgc) {
7890 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7891 0         0 while ($string !~ /\G \z/oxgc) {
7892 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7893 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7894             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7895 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7896             }
7897             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7898             }
7899             }
7900              
7901 0         0 # split
7902             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7903 0         0 $slash = 'm//';
7904 0         0  
7905 0         0 my $e = '';
7906             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7907             $e .= $1;
7908             }
7909 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          
7910             # end of split
7911             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Einformixv6als::split' . $e; }
7912 0         0  
  0         0  
7913             # split scalar value
7914             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . e_string($1); next E_STRING_LOOP; }
7915 0         0  
  0         0  
7916 0         0 # split literal space
  0         0  
7917 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7918 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7919 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7920 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7921 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7922 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  
7923 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7924 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7925 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7926 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7927 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7928 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  
7929             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {' '}; next E_STRING_LOOP; }
7930             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Einformixv6als::split' . $e . qq {" "}; next E_STRING_LOOP; }
7931              
7932 0 0       0 # split qq//
  0         0  
  0         0  
7933             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7934 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7935 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7936 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7937 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7938 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  
7939 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  
7940 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  
7941 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  
7942             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7943 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 * *
7944             }
7945             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7946             }
7947             }
7948              
7949 0 0       0 # split qr//
  0         0  
  0         0  
7950             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7951 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7952 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7953 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7954 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7955 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  
7956 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  
7957 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  
7958 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  
7959 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  
7960             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7961 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 * *
7962             }
7963             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7964             }
7965             }
7966              
7967 0 0       0 # split q//
  0         0  
  0         0  
7968             elsif ($string =~ /\G \b (q) \b /oxgc) {
7969 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7970 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7971 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7972 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7973 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  
7974 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  
7975 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  
7976 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  
7977             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7978 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 * *
7979             }
7980             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7981             }
7982             }
7983              
7984 0 0       0 # split m//
  0         0  
  0         0  
7985             elsif ($string =~ /\G \b (m) \b /oxgc) {
7986 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 # #
7987 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7988 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7989 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7990 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  
7991 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  
7992 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  
7993 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  
7994 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  
7995             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7996 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 * *
7997             }
7998             die __FILE__, ": Search pattern not terminated\n";
7999             }
8000             }
8001              
8002 0         0 # split ''
8003 0         0 elsif ($string =~ /\G (\') /oxgc) {
8004 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
8005 0         0 while ($string !~ /\G \z/oxgc) {
8006 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
8007 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
8008             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
8009 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
8010             }
8011             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8012             }
8013              
8014 0         0 # split ""
8015 0         0 elsif ($string =~ /\G (\") /oxgc) {
8016 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
8017 0         0 while ($string !~ /\G \z/oxgc) {
8018 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8019 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8020             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8021 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8022             }
8023             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8024             }
8025              
8026 0         0 # split //
8027 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8028 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8029 0         0 while ($string !~ /\G \z/oxgc) {
8030 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8031 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8032             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8033 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8034             }
8035             die __FILE__, ": Search pattern not terminated\n";
8036             }
8037             }
8038              
8039 0         0 # qq//
8040 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8041 0         0 my $ope = $1;
8042             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8043             $e_string .= e_qq($ope,$1,$3,$2);
8044 0         0 }
8045 0         0 else {
8046 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8047 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8048 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8049 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8050 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8051 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8052             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8053 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8054             }
8055             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8056             }
8057             }
8058              
8059 0         0 # qx//
8060 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8061 0         0 my $ope = $1;
8062             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8063             $e_string .= e_qq($ope,$1,$3,$2);
8064 0         0 }
8065 0         0 else {
8066 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8067 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8068 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8069 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8070 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8071 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8072 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8073             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8074 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8075             }
8076             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8077             }
8078             }
8079              
8080 0         0 # q//
8081 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8082 0         0 my $ope = $1;
8083             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8084             $e_string .= e_q($ope,$1,$3,$2);
8085 0         0 }
8086 0         0 else {
8087 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8088 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8089 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8090 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8091 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8092 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8093             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8094 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 * *
8095             }
8096             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8097             }
8098             }
8099 0         0  
8100             # ''
8101             elsif ($string =~ /\G (?
8102 44         197  
8103             # ""
8104             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8105 6         68  
8106             # ``
8107             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8108 0         0  
8109             # <<>> (a safer ARGV)
8110             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8111 0         0  
8112             # <<= <=> <= < operator
8113             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8114 0         0  
8115             #
8116             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8117              
8118 0         0 # --- glob
8119             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8120             $e_string .= 'Einformixv6als::glob("' . $1 . '")';
8121             }
8122              
8123 0         0 # << (bit shift) --- not here document
8124 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8125             $slash = 'm//';
8126             $e_string .= $1;
8127             }
8128              
8129 0         0 # <<~'HEREDOC'
8130 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8131 0         0 $slash = 'm//';
8132             my $here_quote = $1;
8133             my $delimiter = $2;
8134 0 0       0  
8135 0         0 # get here document
8136 0         0 if ($here_script eq '') {
8137             $here_script = CORE::substr $_, pos $_;
8138 0 0       0 $here_script =~ s/.*?\n//oxm;
8139 0         0 }
8140 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8141 0         0 my $heredoc = $1;
8142 0         0 my $indent = $2;
8143 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8144             push @heredoc, $heredoc . qq{\n$delimiter\n};
8145             push @heredoc_delimiter, qq{\\s*$delimiter};
8146 0         0 }
8147             else {
8148 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8149             }
8150             $e_string .= qq{<<'$delimiter'};
8151             }
8152              
8153 0         0 # <<~\HEREDOC
8154 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8155 0         0 $slash = 'm//';
8156             my $here_quote = $1;
8157             my $delimiter = $2;
8158 0 0       0  
8159 0         0 # get here document
8160 0         0 if ($here_script eq '') {
8161             $here_script = CORE::substr $_, pos $_;
8162 0 0       0 $here_script =~ s/.*?\n//oxm;
8163 0         0 }
8164 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8165 0         0 my $heredoc = $1;
8166 0         0 my $indent = $2;
8167 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8168             push @heredoc, $heredoc . qq{\n$delimiter\n};
8169             push @heredoc_delimiter, qq{\\s*$delimiter};
8170 0         0 }
8171             else {
8172 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8173             }
8174             $e_string .= qq{<<\\$delimiter};
8175             }
8176              
8177 0         0 # <<~"HEREDOC"
8178 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8179 0         0 $slash = 'm//';
8180             my $here_quote = $1;
8181             my $delimiter = $2;
8182 0 0       0  
8183 0         0 # get here document
8184 0         0 if ($here_script eq '') {
8185             $here_script = CORE::substr $_, pos $_;
8186 0 0       0 $here_script =~ s/.*?\n//oxm;
8187 0         0 }
8188 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8189 0         0 my $heredoc = $1;
8190 0         0 my $indent = $2;
8191 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8192             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8193             push @heredoc_delimiter, qq{\\s*$delimiter};
8194 0         0 }
8195             else {
8196 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8197             }
8198             $e_string .= qq{<<"$delimiter"};
8199             }
8200              
8201 0         0 # <<~HEREDOC
8202 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8203 0         0 $slash = 'm//';
8204             my $here_quote = $1;
8205             my $delimiter = $2;
8206 0 0       0  
8207 0         0 # get here document
8208 0         0 if ($here_script eq '') {
8209             $here_script = CORE::substr $_, pos $_;
8210 0 0       0 $here_script =~ s/.*?\n//oxm;
8211 0         0 }
8212 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8213 0         0 my $heredoc = $1;
8214 0         0 my $indent = $2;
8215 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8216             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8217             push @heredoc_delimiter, qq{\\s*$delimiter};
8218 0         0 }
8219             else {
8220 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8221             }
8222             $e_string .= qq{<<$delimiter};
8223             }
8224              
8225 0         0 # <<~`HEREDOC`
8226 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8227 0         0 $slash = 'm//';
8228             my $here_quote = $1;
8229             my $delimiter = $2;
8230 0 0       0  
8231 0         0 # get here document
8232 0         0 if ($here_script eq '') {
8233             $here_script = CORE::substr $_, pos $_;
8234 0 0       0 $here_script =~ s/.*?\n//oxm;
8235 0         0 }
8236 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8237 0         0 my $heredoc = $1;
8238 0         0 my $indent = $2;
8239 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8240             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8241             push @heredoc_delimiter, qq{\\s*$delimiter};
8242 0         0 }
8243             else {
8244 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8245             }
8246             $e_string .= qq{<<`$delimiter`};
8247             }
8248              
8249 0         0 # <<'HEREDOC'
8250 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8251 0         0 $slash = 'm//';
8252             my $here_quote = $1;
8253             my $delimiter = $2;
8254 0 0       0  
8255 0         0 # get here document
8256 0         0 if ($here_script eq '') {
8257             $here_script = CORE::substr $_, pos $_;
8258 0 0       0 $here_script =~ s/.*?\n//oxm;
8259 0         0 }
8260 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8261             push @heredoc, $1 . qq{\n$delimiter\n};
8262             push @heredoc_delimiter, $delimiter;
8263 0         0 }
8264             else {
8265 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8266             }
8267             $e_string .= $here_quote;
8268             }
8269              
8270 0         0 # <<\HEREDOC
8271 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8272 0         0 $slash = 'm//';
8273             my $here_quote = $1;
8274             my $delimiter = $2;
8275 0 0       0  
8276 0         0 # get here document
8277 0         0 if ($here_script eq '') {
8278             $here_script = CORE::substr $_, pos $_;
8279 0 0       0 $here_script =~ s/.*?\n//oxm;
8280 0         0 }
8281 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8282             push @heredoc, $1 . qq{\n$delimiter\n};
8283             push @heredoc_delimiter, $delimiter;
8284 0         0 }
8285             else {
8286 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8287             }
8288             $e_string .= $here_quote;
8289             }
8290              
8291 0         0 # <<"HEREDOC"
8292 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8293 0         0 $slash = 'm//';
8294             my $here_quote = $1;
8295             my $delimiter = $2;
8296 0 0       0  
8297 0         0 # get here document
8298 0         0 if ($here_script eq '') {
8299             $here_script = CORE::substr $_, pos $_;
8300 0 0       0 $here_script =~ s/.*?\n//oxm;
8301 0         0 }
8302 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8303             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8304             push @heredoc_delimiter, $delimiter;
8305 0         0 }
8306             else {
8307 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8308             }
8309             $e_string .= $here_quote;
8310             }
8311              
8312 0         0 # <
8313 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8314 0         0 $slash = 'm//';
8315             my $here_quote = $1;
8316             my $delimiter = $2;
8317 0 0       0  
8318 0         0 # get here document
8319 0         0 if ($here_script eq '') {
8320             $here_script = CORE::substr $_, pos $_;
8321 0 0       0 $here_script =~ s/.*?\n//oxm;
8322 0         0 }
8323 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8324             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8325             push @heredoc_delimiter, $delimiter;
8326 0         0 }
8327             else {
8328 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8329             }
8330             $e_string .= $here_quote;
8331             }
8332              
8333 0         0 # <<`HEREDOC`
8334 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8335 0         0 $slash = 'm//';
8336             my $here_quote = $1;
8337             my $delimiter = $2;
8338 0 0       0  
8339 0         0 # get here document
8340 0         0 if ($here_script eq '') {
8341             $here_script = CORE::substr $_, pos $_;
8342 0 0       0 $here_script =~ s/.*?\n//oxm;
8343 0         0 }
8344 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8345             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8346             push @heredoc_delimiter, $delimiter;
8347 0         0 }
8348             else {
8349 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8350             }
8351             $e_string .= $here_quote;
8352             }
8353              
8354             # any operator before div
8355             elsif ($string =~ /\G (
8356             -- | \+\+ |
8357 0         0 [\)\}\]]
  80         159  
8358              
8359             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8360              
8361             # yada-yada or triple-dot operator
8362             elsif ($string =~ /\G (
8363 80         293 \.\.\.
  0         0  
8364              
8365             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8366              
8367             # any operator before m//
8368             elsif ($string =~ /\G ((?>
8369              
8370             !~~ | !~ | != | ! |
8371             %= | % |
8372             &&= | && | &= | &\.= | &\. | & |
8373             -= | -> | - |
8374             :(?>\s*)= |
8375             : |
8376             <<>> |
8377             <<= | <=> | <= | < |
8378             == | => | =~ | = |
8379             >>= | >> | >= | > |
8380             \*\*= | \*\* | \*= | \* |
8381             \+= | \+ |
8382             \.\. | \.= | \. |
8383             \/\/= | \/\/ |
8384             \/= | \/ |
8385             \? |
8386             \\ |
8387             \^= | \^\.= | \^\. | \^ |
8388             \b x= |
8389             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8390             ~~ | ~\. | ~ |
8391             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8392             \b(?: print )\b |
8393              
8394 0         0 [,;\(\{\[]
  112         259  
8395              
8396             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8397 112         821  
8398             # other any character
8399             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8400              
8401 353         1585 # system error
8402             else {
8403             die __FILE__, ": Oops, this shouldn't happen!\n";
8404             }
8405 0         0 }
8406              
8407             return $e_string;
8408             }
8409              
8410             #
8411             # character class
8412 79     5342 0 358 #
8413             sub character_class {
8414 5342 100       10781 my($char,$modifier) = @_;
8415 5342 100       8562  
8416 115         234 if ($char eq '.') {
8417             if ($modifier =~ /s/) {
8418             return '${Einformixv6als::dot_s}';
8419 23         107 }
8420             else {
8421             return '${Einformixv6als::dot}';
8422             }
8423 92         228 }
8424             else {
8425             return Einformixv6als::classic_character_class($char);
8426             }
8427             }
8428              
8429             #
8430             # escape capture ($1, $2, $3, ...)
8431             #
8432 5227     637 0 9347 sub e_capture {
8433 637         2944  
8434             return join '', '${Einformixv6als::capture(', $_[0], ')}';
8435             return join '', '${', $_[0], '}';
8436             }
8437              
8438             #
8439             # escape transliteration (tr/// or y///)
8440 0     11 0 0 #
8441 11         63 sub e_tr {
8442 11   100     24 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8443             my $e_tr = '';
8444 11         31 $modifier ||= '';
8445              
8446             $slash = 'div';
8447 11         17  
8448             # quote character class 1
8449             $charclass = q_tr($charclass);
8450 11         26  
8451             # quote character class 2
8452             $charclass2 = q_tr($charclass2);
8453 11 50       30  
8454 11 0       34 # /b /B modifier
8455 0         0 if ($modifier =~ tr/bB//d) {
8456             if ($variable eq '') {
8457             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8458 0         0 }
8459             else {
8460             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8461             }
8462 0 100       0 }
8463 11         23 else {
8464             if ($variable eq '') {
8465             $e_tr = qq{Einformixv6als::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8466 2         7 }
8467             else {
8468             $e_tr = qq{Einformixv6als::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8469             }
8470             }
8471 9         29  
8472 11         16 # clear tr/// variable
8473             $tr_variable = '';
8474 11         18 $bind_operator = '';
8475              
8476             return $e_tr;
8477             }
8478              
8479             #
8480             # quote for escape transliteration (tr/// or y///)
8481 11     22 0 67 #
8482             sub q_tr {
8483             my($charclass) = @_;
8484 22 50       34  
    0          
    0          
    0          
    0          
    0          
8485 22         49 # quote character class
8486             if ($charclass !~ /'/oxms) {
8487             return e_q('', "'", "'", $charclass); # --> q' '
8488 22         40 }
8489             elsif ($charclass !~ /\//oxms) {
8490             return e_q('q', '/', '/', $charclass); # --> q/ /
8491 0         0 }
8492             elsif ($charclass !~ /\#/oxms) {
8493             return e_q('q', '#', '#', $charclass); # --> q# #
8494 0         0 }
8495             elsif ($charclass !~ /[\<\>]/oxms) {
8496             return e_q('q', '<', '>', $charclass); # --> q< >
8497 0         0 }
8498             elsif ($charclass !~ /[\(\)]/oxms) {
8499             return e_q('q', '(', ')', $charclass); # --> q( )
8500 0         0 }
8501             elsif ($charclass !~ /[\{\}]/oxms) {
8502             return e_q('q', '{', '}', $charclass); # --> q{ }
8503 0         0 }
8504 0 0       0 else {
8505 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8506             if ($charclass !~ /\Q$char\E/xms) {
8507             return e_q('q', $char, $char, $charclass);
8508             }
8509             }
8510 0         0 }
8511              
8512             return e_q('q', '{', '}', $charclass);
8513             }
8514              
8515             #
8516             # escape q string (q//, '')
8517 0     3967 0 0 #
8518             sub e_q {
8519 3967         10808 my($ope,$delimiter,$end_delimiter,$string) = @_;
8520              
8521 3967         5959 $slash = 'div';
8522 3967         28867  
8523             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8524             for (my $i=0; $i <= $#char; $i++) {
8525 3967 100 100     11462  
    100 100        
8526 21453         126380 # escape last octet of multiple-octet
8527             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8528             $char[$i] = $1 . '\\' . $2;
8529 1         6 }
8530             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8531             $char[$i] = $1 . '\\' . $2;
8532 22 100 100     95 }
8533 3967         16295 }
8534             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8535             $char[-1] = $1 . '\\' . $2;
8536 204         644 }
8537 3967         21589  
8538             return join '', $ope, $delimiter, @char, $end_delimiter;
8539             return join '', $ope, $delimiter, $string, $end_delimiter;
8540             }
8541              
8542             #
8543             # escape qq string (qq//, "", qx//, ``)
8544 0     9552 0 0 #
8545             sub e_qq {
8546 9552         22625 my($ope,$delimiter,$end_delimiter,$string) = @_;
8547              
8548 9552         13996 $slash = 'div';
8549 9552         18530  
8550             my $left_e = 0;
8551             my $right_e = 0;
8552 9552         11468  
8553             # split regexp
8554             my @char = $string =~ /\G((?>
8555             [^\x81-\x9F\xE0-\xFD\\\$]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
8556             \\x\{ (?>[0-9A-Fa-f]+) \} |
8557             \\o\{ (?>[0-7]+) \} |
8558             \\N\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
8559             \\ $q_char |
8560             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8561             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8562             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8563             \$ (?>\s* [0-9]+) |
8564             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8565             \$ \$ (?![\w\{]) |
8566             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8567             $q_char
8568 9552         377910 ))/oxmsg;
8569              
8570             for (my $i=0; $i <= $#char; $i++) {
8571 9552 50 66     30655  
    50 33        
    100          
    100          
    50          
8572 312224         1011938 # "\L\u" --> "\u\L"
8573             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8574             @char[$i,$i+1] = @char[$i+1,$i];
8575             }
8576              
8577 0         0 # "\U\l" --> "\l\U"
8578             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8579             @char[$i,$i+1] = @char[$i+1,$i];
8580             }
8581              
8582 0         0 # octal escape sequence
8583             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8584             $char[$i] = Einformixv6als::octchr($1);
8585             }
8586              
8587 1         4 # hexadecimal escape sequence
8588             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8589             $char[$i] = Einformixv6als::hexchr($1);
8590             }
8591              
8592 1         4 # \N{CHARNAME} --> N{CHARNAME}
8593             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
8594             $char[$i] = $1;
8595 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          
8596              
8597             if (0) {
8598             }
8599              
8600             # escape last octet of multiple-octet
8601 312224         2917466 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8602 0         0 # variable $delimiter and $end_delimiter can be ''
8603             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8604             $char[$i] = $1 . '\\' . $2;
8605             }
8606              
8607             # \F
8608             #
8609             # P.69 Table 2-6. Translation escapes
8610             # in Chapter 2: Bits and Pieces
8611             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8612             # (and so on)
8613              
8614 1342 50       4683 # \u \l \U \L \F \Q \E
8615 647         1621 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8616             if ($right_e < $left_e) {
8617             $char[$i] = '\\' . $char[$i];
8618             }
8619             }
8620             elsif ($char[$i] eq '\u') {
8621              
8622             # "STRING @{[ LIST EXPR ]} MORE STRING"
8623              
8624             # P.257 Other Tricks You Can Do with Hard References
8625             # in Chapter 8: References
8626             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8627              
8628             # P.353 Other Tricks You Can Do with Hard References
8629             # in Chapter 8: References
8630             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8631              
8632 0         0 # (and so on)
8633 0         0  
8634             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
8635             $left_e++;
8636 0         0 }
8637 0         0 elsif ($char[$i] eq '\l') {
8638             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
8639             $left_e++;
8640 0         0 }
8641 0         0 elsif ($char[$i] eq '\U') {
8642             $char[$i] = '@{[Einformixv6als::uc qq<';
8643             $left_e++;
8644 0         0 }
8645 6         9 elsif ($char[$i] eq '\L') {
8646             $char[$i] = '@{[Einformixv6als::lc qq<';
8647             $left_e++;
8648 6         13 }
8649 9         21 elsif ($char[$i] eq '\F') {
8650             $char[$i] = '@{[Einformixv6als::fc qq<';
8651             $left_e++;
8652 9         24 }
8653 0         0 elsif ($char[$i] eq '\Q') {
8654             $char[$i] = '@{[CORE::quotemeta qq<';
8655             $left_e++;
8656 0 50       0 }
8657 12         25 elsif ($char[$i] eq '\E') {
8658 12         17 if ($right_e < $left_e) {
8659             $char[$i] = '>]}';
8660             $right_e++;
8661 12         25 }
8662             else {
8663             $char[$i] = '';
8664             }
8665 0         0 }
8666 0 0       0 elsif ($char[$i] eq '\Q') {
8667 0         0 while (1) {
8668             if (++$i > $#char) {
8669 0 0       0 last;
8670 0         0 }
8671             if ($char[$i] eq '\E') {
8672             last;
8673             }
8674             }
8675             }
8676             elsif ($char[$i] eq '\E') {
8677             }
8678              
8679             # $0 --> $0
8680             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8681             }
8682             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8683             }
8684              
8685             # $$ --> $$
8686             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8687             }
8688              
8689             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8690 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8691             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8692             $char[$i] = e_capture($1);
8693 415         1206 }
8694             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8695             $char[$i] = e_capture($1);
8696             }
8697              
8698 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8699             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8700             $char[$i] = e_capture($1.'->'.$2);
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_brace)*? \} ) \z/oxms) {
8705             $char[$i] = e_capture($1.'->'.$2);
8706             }
8707              
8708 0         0 # $$foo
8709             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8710             $char[$i] = e_capture($1);
8711             }
8712              
8713 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
8714             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8715             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
8716             }
8717              
8718 44         144 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
8719             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8720             $char[$i] = '@{[Einformixv6als::MATCH()]}';
8721             }
8722              
8723 45         150 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
8724             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8725             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
8726             }
8727              
8728             # ${ foo } --> ${ foo }
8729             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8730             }
8731              
8732 33         104 # ${ ... }
8733             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8734             $char[$i] = e_capture($1);
8735             }
8736             }
8737 0 100       0  
8738 9552         20995 # return string
8739             if ($left_e > $right_e) {
8740 3         17 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8741             }
8742             return join '', $ope, $delimiter, @char, $end_delimiter;
8743             }
8744              
8745             #
8746             # escape qw string (qw//)
8747 9549     34 0 91693 #
8748             sub e_qw {
8749 34         170 my($ope,$delimiter,$end_delimiter,$string) = @_;
8750              
8751             $slash = 'div';
8752 34         80  
  34         1468  
8753 621 50       1124 # choice again delimiter
    0          
    0          
    0          
    0          
8754 34         186 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8755             if (not $octet{$end_delimiter}) {
8756             return join '', $ope, $delimiter, $string, $end_delimiter;
8757 34         240 }
8758             elsif (not $octet{')'}) {
8759             return join '', $ope, '(', $string, ')';
8760 0         0 }
8761             elsif (not $octet{'}'}) {
8762             return join '', $ope, '{', $string, '}';
8763 0         0 }
8764             elsif (not $octet{']'}) {
8765             return join '', $ope, '[', $string, ']';
8766 0         0 }
8767             elsif (not $octet{'>'}) {
8768             return join '', $ope, '<', $string, '>';
8769 0         0 }
8770 0 0       0 else {
8771 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8772             if (not $octet{$char}) {
8773             return join '', $ope, $char, $string, $char;
8774             }
8775             }
8776             }
8777 0         0  
8778 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8779 0         0 my @string = CORE::split(/\s+/, $string);
8780 0         0 for my $string (@string) {
8781 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8782 0         0 for my $octet (@octet) {
8783             if ($octet =~ /\A (['\\]) \z/oxms) {
8784             $octet = '\\' . $1;
8785 0         0 }
8786             }
8787 0         0 $string = join '', @octet;
  0         0  
8788             }
8789             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8790             }
8791              
8792             #
8793             # escape here document (<<"HEREDOC", <
8794 0     108 0 0 #
8795             sub e_heredoc {
8796 108         297 my($string) = @_;
8797              
8798 108         274 $slash = 'm//';
8799              
8800 108         379 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8801 108         189  
8802             my $left_e = 0;
8803             my $right_e = 0;
8804 108         172  
8805             # split regexp
8806             my @char = $string =~ /\G((?>
8807             [^\x81-\x9F\xE0-\xFD\\\$]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
8808             \\x\{ (?>[0-9A-Fa-f]+) \} |
8809             \\o\{ (?>[0-7]+) \} |
8810             \\N\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
8811             \\ $q_char |
8812             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8813             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8814             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8815             \$ (?>\s* [0-9]+) |
8816             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8817             \$ \$ (?![\w\{]) |
8818             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8819             $q_char
8820 108         12000 ))/oxmsg;
8821              
8822             for (my $i=0; $i <= $#char; $i++) {
8823 108 50 66     550  
    50 33        
    100          
    100          
    50          
8824 3459         11005 # "\L\u" --> "\u\L"
8825             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8826             @char[$i,$i+1] = @char[$i+1,$i];
8827             }
8828              
8829 0         0 # "\U\l" --> "\l\U"
8830             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8831             @char[$i,$i+1] = @char[$i+1,$i];
8832             }
8833              
8834 0         0 # octal escape sequence
8835             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8836             $char[$i] = Einformixv6als::octchr($1);
8837             }
8838              
8839 1         3 # hexadecimal escape sequence
8840             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8841             $char[$i] = Einformixv6als::hexchr($1);
8842             }
8843              
8844 1         3 # \N{CHARNAME} --> N{CHARNAME}
8845             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
8846             $char[$i] = $1;
8847 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          
8848              
8849             if (0) {
8850             }
8851 3459         29785  
8852 0         0 # escape character
8853             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8854             $char[$i] = $1 . '\\' . $2;
8855             }
8856              
8857 57 50       230 # \u \l \U \L \F \Q \E
8858 72         139 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8859             if ($right_e < $left_e) {
8860             $char[$i] = '\\' . $char[$i];
8861             }
8862 0         0 }
8863 0         0 elsif ($char[$i] eq '\u') {
8864             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
8865             $left_e++;
8866 0         0 }
8867 0         0 elsif ($char[$i] eq '\l') {
8868             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
8869             $left_e++;
8870 0         0 }
8871 0         0 elsif ($char[$i] eq '\U') {
8872             $char[$i] = '@{[Einformixv6als::uc qq<';
8873             $left_e++;
8874 0         0 }
8875 6         9 elsif ($char[$i] eq '\L') {
8876             $char[$i] = '@{[Einformixv6als::lc qq<';
8877             $left_e++;
8878 6         11 }
8879 0         0 elsif ($char[$i] eq '\F') {
8880             $char[$i] = '@{[Einformixv6als::fc qq<';
8881             $left_e++;
8882 0         0 }
8883 0         0 elsif ($char[$i] eq '\Q') {
8884             $char[$i] = '@{[CORE::quotemeta qq<';
8885             $left_e++;
8886 0 50       0 }
8887 3         7 elsif ($char[$i] eq '\E') {
8888 3         4 if ($right_e < $left_e) {
8889             $char[$i] = '>]}';
8890             $right_e++;
8891 3         6 }
8892             else {
8893             $char[$i] = '';
8894             }
8895 0         0 }
8896 0 0       0 elsif ($char[$i] eq '\Q') {
8897 0         0 while (1) {
8898             if (++$i > $#char) {
8899 0 0       0 last;
8900 0         0 }
8901             if ($char[$i] eq '\E') {
8902             last;
8903             }
8904             }
8905             }
8906             elsif ($char[$i] eq '\E') {
8907             }
8908              
8909             # $0 --> $0
8910             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8911             }
8912             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8913             }
8914              
8915             # $$ --> $$
8916             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8917             }
8918              
8919             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8920 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8921             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8922             $char[$i] = e_capture($1);
8923 0         0 }
8924             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8925             $char[$i] = e_capture($1);
8926             }
8927              
8928 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8929             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8930             $char[$i] = e_capture($1.'->'.$2);
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_brace)*? \} ) \z/oxms) {
8935             $char[$i] = e_capture($1.'->'.$2);
8936             }
8937              
8938 0         0 # $$foo
8939             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8940             $char[$i] = e_capture($1);
8941             }
8942              
8943 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
8944             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8945             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
8946             }
8947              
8948 8         52 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
8949             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8950             $char[$i] = '@{[Einformixv6als::MATCH()]}';
8951             }
8952              
8953 8         51 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
8954             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8955             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
8956             }
8957              
8958             # ${ foo } --> ${ foo }
8959             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8960             }
8961              
8962 6         37 # ${ ... }
8963             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8964             $char[$i] = e_capture($1);
8965             }
8966             }
8967 0 100       0  
8968 108         293 # return string
8969             if ($left_e > $right_e) {
8970 3         22 return join '', @char, '>]}' x ($left_e - $right_e);
8971             }
8972             return join '', @char;
8973             }
8974              
8975             #
8976             # escape regexp (m//, qr//)
8977 105     1835 0 807 #
8978 1835   100     7680 sub e_qr {
8979             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8980 1835         6551 $modifier ||= '';
8981 1835 50       3416  
8982 1835         4797 $modifier =~ tr/p//d;
8983 0         0 if ($modifier =~ /([adlu])/oxms) {
8984 0 0       0 my $line = 0;
8985 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8986 0         0 if ($filename ne __FILE__) {
8987             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8988             last;
8989 0         0 }
8990             }
8991             die qq{Unsupported modifier "$1" used at line $line.\n};
8992 0         0 }
8993              
8994             $slash = 'div';
8995 1835 100       2929  
    100          
8996 1835         5251 # literal null string pattern
8997 8         12 if ($string eq '') {
8998 8         10 $modifier =~ tr/bB//d;
8999             $modifier =~ tr/i//d;
9000             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9001             }
9002              
9003             # /b /B modifier
9004             elsif ($modifier =~ tr/bB//d) {
9005 8 50       46  
9006 240         562 # choice again delimiter
9007 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9008 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9009 0         0 my %octet = map {$_ => 1} @char;
9010 0         0 if (not $octet{')'}) {
9011             $delimiter = '(';
9012             $end_delimiter = ')';
9013 0         0 }
9014 0         0 elsif (not $octet{'}'}) {
9015             $delimiter = '{';
9016             $end_delimiter = '}';
9017 0         0 }
9018 0         0 elsif (not $octet{']'}) {
9019             $delimiter = '[';
9020             $end_delimiter = ']';
9021 0         0 }
9022 0         0 elsif (not $octet{'>'}) {
9023             $delimiter = '<';
9024             $end_delimiter = '>';
9025 0         0 }
9026 0 0       0 else {
9027 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9028 0         0 if (not $octet{$char}) {
9029 0         0 $delimiter = $char;
9030             $end_delimiter = $char;
9031             last;
9032             }
9033             }
9034             }
9035 0 100 100     0 }
9036 240         1381  
9037             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9038             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9039 90         526 }
9040             else {
9041             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9042             }
9043 150 100       877 }
9044 1587         3833  
9045             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9046             my $metachar = qr/[\@\\|[\]{^]/oxms;
9047 1587         6174  
9048             # split regexp
9049             my @char = $string =~ /\G((?>
9050             [^\x81-\x9F\xE0-\xFD\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
9051             \\x (?>[0-9A-Fa-f]{1,2}) |
9052             \\ (?>[0-7]{2,3}) |
9053             \\c [\x40-\x5F] |
9054             \\x\{ (?>[0-9A-Fa-f]+) \} |
9055             \\o\{ (?>[0-7]+) \} |
9056             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
9057             \\ $q_char |
9058             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9059             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9060             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9061             [\$\@] $qq_variable |
9062             \$ (?>\s* [0-9]+) |
9063             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9064             \$ \$ (?![\w\{]) |
9065             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9066             \[\^ |
9067             \[\: (?>[a-z]+) :\] |
9068             \[\:\^ (?>[a-z]+) :\] |
9069             \(\? |
9070             $q_char
9071             ))/oxmsg;
9072 1587 50       166294  
9073 1587         7557 # choice again delimiter
  0         0  
9074 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9075 0         0 my %octet = map {$_ => 1} @char;
9076 0         0 if (not $octet{')'}) {
9077             $delimiter = '(';
9078             $end_delimiter = ')';
9079 0         0 }
9080 0         0 elsif (not $octet{'}'}) {
9081             $delimiter = '{';
9082             $end_delimiter = '}';
9083 0         0 }
9084 0         0 elsif (not $octet{']'}) {
9085             $delimiter = '[';
9086             $end_delimiter = ']';
9087 0         0 }
9088 0         0 elsif (not $octet{'>'}) {
9089             $delimiter = '<';
9090             $end_delimiter = '>';
9091 0         0 }
9092 0 0       0 else {
9093 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9094 0         0 if (not $octet{$char}) {
9095 0         0 $delimiter = $char;
9096             $end_delimiter = $char;
9097             last;
9098             }
9099             }
9100             }
9101 0         0 }
9102 1587         2511  
9103 1587         2278 my $left_e = 0;
9104             my $right_e = 0;
9105             for (my $i=0; $i <= $#char; $i++) {
9106 1587 50 66     4269  
    50 66        
    100          
    100          
    100          
    100          
9107 5422         27478 # "\L\u" --> "\u\L"
9108             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9109             @char[$i,$i+1] = @char[$i+1,$i];
9110             }
9111              
9112 0         0 # "\U\l" --> "\l\U"
9113             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9114             @char[$i,$i+1] = @char[$i+1,$i];
9115             }
9116              
9117 0         0 # octal escape sequence
9118             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9119             $char[$i] = Einformixv6als::octchr($1);
9120             }
9121              
9122 1         4 # hexadecimal escape sequence
9123             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9124             $char[$i] = Einformixv6als::hexchr($1);
9125             }
9126              
9127             # \b{...} --> b\{...}
9128             # \B{...} --> B\{...}
9129             # \N{CHARNAME} --> N\{CHARNAME}
9130             # \p{PROPERTY} --> p\{PROPERTY}
9131 1         4 # \P{PROPERTY} --> P\{PROPERTY}
9132             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
9133             $char[$i] = $1 . '\\' . $2;
9134             }
9135              
9136 6         22 # \p, \P, \X --> p, P, X
9137             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9138             $char[$i] = $1;
9139 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          
9140              
9141             if (0) {
9142             }
9143 5422         37047  
9144 0         0 # escape last octet of multiple-octet
9145             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9146             $char[$i] = $1 . '\\' . $2;
9147             }
9148              
9149 77 50 33     339 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9150 6         342 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9151             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)) {
9152             $char[$i] .= join '', splice @char, $i+1, 3;
9153 0         0 }
9154             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)) {
9155             $char[$i] .= join '', splice @char, $i+1, 2;
9156 0         0 }
9157             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)) {
9158             $char[$i] .= join '', splice @char, $i+1, 1;
9159             }
9160             }
9161              
9162 0         0 # open character class [...]
9163             elsif ($char[$i] eq '[') {
9164             my $left = $i;
9165              
9166             # [] make die "Unmatched [] in regexp ...\n"
9167 586 100       1010 # (and so on)
9168 586         1766  
9169             if ($char[$i+1] eq ']') {
9170             $i++;
9171 3         5 }
9172 586 50       765  
9173 2583         4008 while (1) {
9174             if (++$i > $#char) {
9175 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9176 2583         5016 }
9177             if ($char[$i] eq ']') {
9178             my $right = $i;
9179 586 100       853  
9180 586         3326 # [...]
  90         212  
9181             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9182             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);
9183 270         496 }
9184             else {
9185             splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
9186 496         1832 }
9187 586         1178  
9188             $i = $left;
9189             last;
9190             }
9191             }
9192             }
9193              
9194 586         1711 # open character class [^...]
9195             elsif ($char[$i] eq '[^') {
9196             my $left = $i;
9197              
9198             # [^] make die "Unmatched [] in regexp ...\n"
9199 328 100       465 # (and so on)
9200 328         692  
9201             if ($char[$i+1] eq ']') {
9202             $i++;
9203 5         9 }
9204 328 50       441  
9205 1447         2243 while (1) {
9206             if (++$i > $#char) {
9207 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9208 1447         2232 }
9209             if ($char[$i] eq ']') {
9210             my $right = $i;
9211 328 100       484  
9212 328         1566 # [^...]
  90         212  
9213             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9214             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);
9215 270         524 }
9216             else {
9217             splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9218 238         795 }
9219 328         595  
9220             $i = $left;
9221             last;
9222             }
9223             }
9224             }
9225              
9226 328         886 # rewrite character class or escape character
9227             elsif (my $char = character_class($char[$i],$modifier)) {
9228             $char[$i] = $char;
9229             }
9230              
9231 215 50       606 # /i modifier
9232 238         458 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
9233             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
9234             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
9235 238         457 }
9236             else {
9237             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
9238             }
9239             }
9240              
9241 0 50       0 # \u \l \U \L \F \Q \E
9242 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9243             if ($right_e < $left_e) {
9244             $char[$i] = '\\' . $char[$i];
9245             }
9246 0         0 }
9247 0         0 elsif ($char[$i] eq '\u') {
9248             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
9249             $left_e++;
9250 0         0 }
9251 0         0 elsif ($char[$i] eq '\l') {
9252             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
9253             $left_e++;
9254 0         0 }
9255 1         3 elsif ($char[$i] eq '\U') {
9256             $char[$i] = '@{[Einformixv6als::uc qq<';
9257             $left_e++;
9258 1         4 }
9259 1         3 elsif ($char[$i] eq '\L') {
9260             $char[$i] = '@{[Einformixv6als::lc qq<';
9261             $left_e++;
9262 1         3 }
9263 9         17 elsif ($char[$i] eq '\F') {
9264             $char[$i] = '@{[Einformixv6als::fc qq<';
9265             $left_e++;
9266 9         23 }
9267 22         50 elsif ($char[$i] eq '\Q') {
9268             $char[$i] = '@{[CORE::quotemeta qq<';
9269             $left_e++;
9270 22 50       62 }
9271 33         95 elsif ($char[$i] eq '\E') {
9272 33         60 if ($right_e < $left_e) {
9273             $char[$i] = '>]}';
9274             $right_e++;
9275 33         85 }
9276             else {
9277             $char[$i] = '';
9278             }
9279 0         0 }
9280 0 0       0 elsif ($char[$i] eq '\Q') {
9281 0         0 while (1) {
9282             if (++$i > $#char) {
9283 0 0       0 last;
9284 0         0 }
9285             if ($char[$i] eq '\E') {
9286             last;
9287             }
9288             }
9289             }
9290             elsif ($char[$i] eq '\E') {
9291             }
9292              
9293 0 0       0 # $0 --> $0
9294 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9295             if ($ignorecase) {
9296             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9297             }
9298 0 0       0 }
9299 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9300             if ($ignorecase) {
9301             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9302             }
9303             }
9304              
9305             # $$ --> $$
9306             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9307             }
9308              
9309             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9310 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9311 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9312 0         0 $char[$i] = e_capture($1);
9313             if ($ignorecase) {
9314             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9315             }
9316 0         0 }
9317 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9318 0         0 $char[$i] = e_capture($1);
9319             if ($ignorecase) {
9320             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9321             }
9322             }
9323              
9324 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9325 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) {
9326 0         0 $char[$i] = e_capture($1.'->'.$2);
9327             if ($ignorecase) {
9328             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9329             }
9330             }
9331              
9332 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9333 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) {
9334 0         0 $char[$i] = e_capture($1.'->'.$2);
9335             if ($ignorecase) {
9336             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9337             }
9338             }
9339              
9340 0         0 # $$foo
9341 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9342 0         0 $char[$i] = e_capture($1);
9343             if ($ignorecase) {
9344             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9345             }
9346             }
9347              
9348 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
9349 8         23 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9350             if ($ignorecase) {
9351             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::PREMATCH())]}';
9352 0         0 }
9353             else {
9354             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
9355             }
9356             }
9357              
9358 8 50       29 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
9359 8         21 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9360             if ($ignorecase) {
9361             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::MATCH())]}';
9362 0         0 }
9363             else {
9364             $char[$i] = '@{[Einformixv6als::MATCH()]}';
9365             }
9366             }
9367              
9368 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
9369 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9370             if ($ignorecase) {
9371             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::POSTMATCH())]}';
9372 0         0 }
9373             else {
9374             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
9375             }
9376             }
9377              
9378 6 0       19 # ${ foo }
9379 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) {
9380             if ($ignorecase) {
9381             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9382             }
9383             }
9384              
9385 0         0 # ${ ... }
9386 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9387 0         0 $char[$i] = e_capture($1);
9388             if ($ignorecase) {
9389             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9390             }
9391             }
9392              
9393 0         0 # $scalar or @array
9394 31 100       132 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9395 31         125 $char[$i] = e_string($char[$i]);
9396             if ($ignorecase) {
9397             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9398             }
9399             }
9400              
9401 4 100 66     18 # quote character before ? + * {
    50          
9402             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9403             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9404 188         1891 }
9405 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9406 0         0 my $char = $char[$i-1];
9407             if ($char[$i] eq '{') {
9408             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9409 0         0 }
9410             else {
9411             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9412             }
9413 0         0 }
9414             else {
9415             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9416             }
9417             }
9418             }
9419 187         873  
9420 1587 50       3035 # make regexp string
9421 1587 0 0     3731 $modifier =~ tr/i//d;
9422 0         0 if ($left_e > $right_e) {
9423             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9424             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9425 0         0 }
9426             else {
9427             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9428 0 100 100     0 }
9429 1587         8723 }
9430             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9431             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9432 94         736 }
9433             else {
9434             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9435             }
9436             }
9437              
9438             #
9439             # double quote stuff
9440 1493     540 0 13644 #
9441             sub qq_stuff {
9442             my($delimiter,$end_delimiter,$stuff) = @_;
9443 540 100       986  
9444 540         1116 # scalar variable or array variable
9445             if ($stuff =~ /\A [\$\@] /oxms) {
9446             return $stuff;
9447             }
9448 300         1124  
  240         605  
9449 280         1693 # quote by delimiter
9450 240 50       578 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9451 240 50       435 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9452 240 50       410 next if $char eq $delimiter;
9453 240         453 next if $char eq $end_delimiter;
9454             if (not $octet{$char}) {
9455             return join '', 'qq', $char, $stuff, $char;
9456 240         968 }
9457             }
9458             return join '', 'qq', '<', $stuff, '>';
9459             }
9460              
9461             #
9462             # escape regexp (m'', qr'', and m''b, qr''b)
9463 0     163 0 0 #
9464 163   100     752 sub e_qr_q {
9465             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9466 163         607 $modifier ||= '';
9467 163 50       352  
9468 163         397 $modifier =~ tr/p//d;
9469 0         0 if ($modifier =~ /([adlu])/oxms) {
9470 0 0       0 my $line = 0;
9471 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9472 0         0 if ($filename ne __FILE__) {
9473             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9474             last;
9475 0         0 }
9476             }
9477             die qq{Unsupported modifier "$1" used at line $line.\n};
9478 0         0 }
9479              
9480             $slash = 'div';
9481 163 100       238  
    100          
9482 163         445 # literal null string pattern
9483 8         10 if ($string eq '') {
9484 8         11 $modifier =~ tr/bB//d;
9485             $modifier =~ tr/i//d;
9486             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9487             }
9488              
9489 8         42 # with /b /B modifier
9490             elsif ($modifier =~ tr/bB//d) {
9491             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9492             }
9493              
9494 89         251 # without /b /B modifier
9495             else {
9496             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9497             }
9498             }
9499              
9500             #
9501             # escape regexp (m'', qr'')
9502 66     66 0 166 #
9503             sub e_qr_qt {
9504 66 100       171 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9505              
9506             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9507 66         171  
9508             # split regexp
9509             my @char = $string =~ /\G((?>
9510             [^\x81-\x9F\xE0-\xFD\\\[\$\@\/] |
9511             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
9512             \[\^ |
9513             \[\: (?>[a-z]+) \:\] |
9514             \[\:\^ (?>[a-z]+) \:\] |
9515             [\$\@\/] |
9516             \\ (?:$q_char) |
9517             (?:$q_char)
9518             ))/oxmsg;
9519 66         906  
9520 66 100 100     238 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9521             for (my $i=0; $i <= $#char; $i++) {
9522             if (0) {
9523             }
9524 79         957  
9525 0         0 # escape last octet of multiple-octet
9526             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9527             $char[$i] = $1 . '\\' . $2;
9528             }
9529              
9530 2         12 # open character class [...]
9531 0 0       0 elsif ($char[$i] eq '[') {
9532 0         0 my $left = $i;
9533             if ($char[$i+1] eq ']') {
9534 0         0 $i++;
9535 0 0       0 }
9536 0         0 while (1) {
9537             if (++$i > $#char) {
9538 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9539 0         0 }
9540             if ($char[$i] eq ']') {
9541             my $right = $i;
9542 0         0  
9543             # [...]
9544 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
9545 0         0  
9546             $i = $left;
9547             last;
9548             }
9549             }
9550             }
9551              
9552 0         0 # open character class [^...]
9553 0 0       0 elsif ($char[$i] eq '[^') {
9554 0         0 my $left = $i;
9555             if ($char[$i+1] eq ']') {
9556 0         0 $i++;
9557 0 0       0 }
9558 0         0 while (1) {
9559             if (++$i > $#char) {
9560 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9561 0         0 }
9562             if ($char[$i] eq ']') {
9563             my $right = $i;
9564 0         0  
9565             # [^...]
9566 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9567 0         0  
9568             $i = $left;
9569             last;
9570             }
9571             }
9572             }
9573              
9574 0         0 # escape $ @ / and \
9575             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9576             $char[$i] = '\\' . $char[$i];
9577             }
9578              
9579 0         0 # rewrite character class or escape character
9580             elsif (my $char = character_class($char[$i],$modifier)) {
9581             $char[$i] = $char;
9582             }
9583              
9584 0 50       0 # /i modifier
9585 16         39 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
9586             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
9587             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
9588 16         87 }
9589             else {
9590             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
9591             }
9592             }
9593              
9594 0 0       0 # quote character before ? + * {
9595             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9596             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9597 0         0 }
9598             else {
9599             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9600             }
9601             }
9602 0         0 }
9603 66         132  
9604             $delimiter = '/';
9605 66         97 $end_delimiter = '/';
9606 66         102  
9607             $modifier =~ tr/i//d;
9608             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9609             }
9610              
9611             #
9612             # escape regexp (m''b, qr''b)
9613 66     89 0 472 #
9614             sub e_qr_qb {
9615             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9616 89         232  
9617             # split regexp
9618             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9619 89         364  
9620 89 50       267 # unescape character
    50          
9621             for (my $i=0; $i <= $#char; $i++) {
9622             if (0) {
9623             }
9624 199         657  
9625             # remain \\
9626             elsif ($char[$i] eq '\\\\') {
9627             }
9628              
9629 0         0 # escape $ @ / and \
9630             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9631             $char[$i] = '\\' . $char[$i];
9632             }
9633 0         0 }
9634 89         216  
9635 89         120 $delimiter = '/';
9636             $end_delimiter = '/';
9637             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9638             }
9639              
9640             #
9641             # escape regexp (s/here//)
9642 89     194 0 533 #
9643 194   100     636 sub e_s1 {
9644             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9645 194         689 $modifier ||= '';
9646 194 50       313  
9647 194         684 $modifier =~ tr/p//d;
9648 0         0 if ($modifier =~ /([adlu])/oxms) {
9649 0 0       0 my $line = 0;
9650 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9651 0         0 if ($filename ne __FILE__) {
9652             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9653             last;
9654 0         0 }
9655             }
9656             die qq{Unsupported modifier "$1" used at line $line.\n};
9657 0         0 }
9658              
9659             $slash = 'div';
9660 194 100       423  
    100          
9661 194         710 # literal null string pattern
9662 8         10 if ($string eq '') {
9663 8         11 $modifier =~ tr/bB//d;
9664             $modifier =~ tr/i//d;
9665             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9666             }
9667              
9668             # /b /B modifier
9669             elsif ($modifier =~ tr/bB//d) {
9670 8 50       52  
9671 44         95 # choice again delimiter
9672 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9673 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9674 0         0 my %octet = map {$_ => 1} @char;
9675 0         0 if (not $octet{')'}) {
9676             $delimiter = '(';
9677             $end_delimiter = ')';
9678 0         0 }
9679 0         0 elsif (not $octet{'}'}) {
9680             $delimiter = '{';
9681             $end_delimiter = '}';
9682 0         0 }
9683 0         0 elsif (not $octet{']'}) {
9684             $delimiter = '[';
9685             $end_delimiter = ']';
9686 0         0 }
9687 0         0 elsif (not $octet{'>'}) {
9688             $delimiter = '<';
9689             $end_delimiter = '>';
9690 0         0 }
9691 0 0       0 else {
9692 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9693 0         0 if (not $octet{$char}) {
9694 0         0 $delimiter = $char;
9695             $end_delimiter = $char;
9696             last;
9697             }
9698             }
9699             }
9700 0         0 }
9701 44         59  
9702 44         158 my $prematch = '';
9703             $prematch = q{(\G[\x00-\xFF]*?)};
9704             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9705 44 100       276 }
9706 142         639  
9707             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9708             my $metachar = qr/[\@\\|[\]{^]/oxms;
9709 142         585  
9710             # split regexp
9711             my @char = $string =~ /\G((?>
9712             [^\x81-\x9F\xE0-\xFD\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
9713             \\ (?>[1-9][0-9]*) |
9714             \\g (?>\s*) (?>[1-9][0-9]*) |
9715             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9716             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9717             \\x (?>[0-9A-Fa-f]{1,2}) |
9718             \\ (?>[0-7]{2,3}) |
9719             \\c [\x40-\x5F] |
9720             \\x\{ (?>[0-9A-Fa-f]+) \} |
9721             \\o\{ (?>[0-7]+) \} |
9722             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
9723             \\ $q_char |
9724             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9725             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9726             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9727             [\$\@] $qq_variable |
9728             \$ (?>\s* [0-9]+) |
9729             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9730             \$ \$ (?![\w\{]) |
9731             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9732             \[\^ |
9733             \[\: (?>[a-z]+) :\] |
9734             \[\:\^ (?>[a-z]+) :\] |
9735             \(\? |
9736             $q_char
9737             ))/oxmsg;
9738 142 50       41943  
9739 142         1249 # choice again delimiter
  0         0  
9740 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9741 0         0 my %octet = map {$_ => 1} @char;
9742 0         0 if (not $octet{')'}) {
9743             $delimiter = '(';
9744             $end_delimiter = ')';
9745 0         0 }
9746 0         0 elsif (not $octet{'}'}) {
9747             $delimiter = '{';
9748             $end_delimiter = '}';
9749 0         0 }
9750 0         0 elsif (not $octet{']'}) {
9751             $delimiter = '[';
9752             $end_delimiter = ']';
9753 0         0 }
9754 0         0 elsif (not $octet{'>'}) {
9755             $delimiter = '<';
9756             $end_delimiter = '>';
9757 0         0 }
9758 0 0       0 else {
9759 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9760 0         0 if (not $octet{$char}) {
9761 0         0 $delimiter = $char;
9762             $end_delimiter = $char;
9763             last;
9764             }
9765             }
9766             }
9767             }
9768 0         0  
  142         318  
9769             # count '('
9770 476         1075 my $parens = grep { $_ eq '(' } @char;
9771 142         239  
9772 142         237 my $left_e = 0;
9773             my $right_e = 0;
9774             for (my $i=0; $i <= $#char; $i++) {
9775 142 50 33     485  
    50 33        
    100          
    100          
    50          
    50          
9776 397         2752 # "\L\u" --> "\u\L"
9777             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9778             @char[$i,$i+1] = @char[$i+1,$i];
9779             }
9780              
9781 0         0 # "\U\l" --> "\l\U"
9782             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9783             @char[$i,$i+1] = @char[$i+1,$i];
9784             }
9785              
9786 0         0 # octal escape sequence
9787             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9788             $char[$i] = Einformixv6als::octchr($1);
9789             }
9790              
9791 1         3 # hexadecimal escape sequence
9792             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9793             $char[$i] = Einformixv6als::hexchr($1);
9794             }
9795              
9796             # \b{...} --> b\{...}
9797             # \B{...} --> B\{...}
9798             # \N{CHARNAME} --> N\{CHARNAME}
9799             # \p{PROPERTY} --> p\{PROPERTY}
9800 1         4 # \P{PROPERTY} --> P\{PROPERTY}
9801             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
9802             $char[$i] = $1 . '\\' . $2;
9803             }
9804              
9805 0         0 # \p, \P, \X --> p, P, X
9806             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9807             $char[$i] = $1;
9808 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          
9809              
9810             if (0) {
9811             }
9812 397         4421  
9813 0         0 # escape last octet of multiple-octet
9814             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9815             $char[$i] = $1 . '\\' . $2;
9816             }
9817              
9818 23 0 0     146 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9819 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9820             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)) {
9821             $char[$i] .= join '', splice @char, $i+1, 3;
9822 0         0 }
9823             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)) {
9824             $char[$i] .= join '', splice @char, $i+1, 2;
9825 0         0 }
9826             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)) {
9827             $char[$i] .= join '', splice @char, $i+1, 1;
9828             }
9829             }
9830              
9831 0         0 # open character class [...]
9832 20 50       46 elsif ($char[$i] eq '[') {
9833 20         65 my $left = $i;
9834             if ($char[$i+1] eq ']') {
9835 0         0 $i++;
9836 20 50       60 }
9837 79         144 while (1) {
9838             if (++$i > $#char) {
9839 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9840 79         246 }
9841             if ($char[$i] eq ']') {
9842             my $right = $i;
9843 20 50       55  
9844 20         158 # [...]
  0         0  
9845             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9846             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);
9847 0         0 }
9848             else {
9849             splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
9850 20         117 }
9851 20         39  
9852             $i = $left;
9853             last;
9854             }
9855             }
9856             }
9857              
9858 20         68 # open character class [^...]
9859 0 0       0 elsif ($char[$i] eq '[^') {
9860 0         0 my $left = $i;
9861             if ($char[$i+1] eq ']') {
9862 0         0 $i++;
9863 0 0       0 }
9864 0         0 while (1) {
9865             if (++$i > $#char) {
9866 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9867 0         0 }
9868             if ($char[$i] eq ']') {
9869             my $right = $i;
9870 0 0       0  
9871 0         0 # [^...]
  0         0  
9872             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9873             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);
9874 0         0 }
9875             else {
9876             splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9877 0         0 }
9878 0         0  
9879             $i = $left;
9880             last;
9881             }
9882             }
9883             }
9884              
9885 0         0 # rewrite character class or escape character
9886             elsif (my $char = character_class($char[$i],$modifier)) {
9887             $char[$i] = $char;
9888             }
9889              
9890 11 50       29 # /i modifier
9891 11         24 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
9892             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
9893             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
9894 11         28 }
9895             else {
9896             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
9897             }
9898             }
9899              
9900 0 50       0 # \u \l \U \L \F \Q \E
9901 8         26 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9902             if ($right_e < $left_e) {
9903             $char[$i] = '\\' . $char[$i];
9904             }
9905 0         0 }
9906 0         0 elsif ($char[$i] eq '\u') {
9907             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
9908             $left_e++;
9909 0         0 }
9910 0         0 elsif ($char[$i] eq '\l') {
9911             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
9912             $left_e++;
9913 0         0 }
9914 0         0 elsif ($char[$i] eq '\U') {
9915             $char[$i] = '@{[Einformixv6als::uc qq<';
9916             $left_e++;
9917 0         0 }
9918 0         0 elsif ($char[$i] eq '\L') {
9919             $char[$i] = '@{[Einformixv6als::lc qq<';
9920             $left_e++;
9921 0         0 }
9922 0         0 elsif ($char[$i] eq '\F') {
9923             $char[$i] = '@{[Einformixv6als::fc qq<';
9924             $left_e++;
9925 0         0 }
9926 7         14 elsif ($char[$i] eq '\Q') {
9927             $char[$i] = '@{[CORE::quotemeta qq<';
9928             $left_e++;
9929 7 50       17 }
9930 7         17 elsif ($char[$i] eq '\E') {
9931 7         10 if ($right_e < $left_e) {
9932             $char[$i] = '>]}';
9933             $right_e++;
9934 7         16 }
9935             else {
9936             $char[$i] = '';
9937             }
9938 0         0 }
9939 0 0       0 elsif ($char[$i] eq '\Q') {
9940 0         0 while (1) {
9941             if (++$i > $#char) {
9942 0 0       0 last;
9943 0         0 }
9944             if ($char[$i] eq '\E') {
9945             last;
9946             }
9947             }
9948             }
9949             elsif ($char[$i] eq '\E') {
9950             }
9951              
9952             # \0 --> \0
9953             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9954             }
9955              
9956             # \g{N}, \g{-N}
9957              
9958             # P.108 Using Simple Patterns
9959             # in Chapter 7: In the World of Regular Expressions
9960             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9961              
9962             # P.221 Capturing
9963             # in Chapter 5: Pattern Matching
9964             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9965              
9966             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9967             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9968             }
9969              
9970 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9971 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9972             if ($1 <= $parens) {
9973             $char[$i] = '\\g{' . ($1 + 1) . '}';
9974             }
9975             }
9976              
9977 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9978 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9979             if ($1 <= $parens) {
9980             $char[$i] = '\\g' . ($1 + 1);
9981             }
9982             }
9983              
9984 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9985 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9986             if ($1 <= $parens) {
9987             $char[$i] = '\\' . ($1 + 1);
9988             }
9989             }
9990              
9991 0 0       0 # $0 --> $0
9992 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9993             if ($ignorecase) {
9994             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
9995             }
9996 0 0       0 }
9997 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9998             if ($ignorecase) {
9999             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10000             }
10001             }
10002              
10003             # $$ --> $$
10004             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10005             }
10006              
10007             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10008 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10009 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10010 0         0 $char[$i] = e_capture($1);
10011             if ($ignorecase) {
10012             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10013             }
10014 0         0 }
10015 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10016 0         0 $char[$i] = e_capture($1);
10017             if ($ignorecase) {
10018             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10019             }
10020             }
10021              
10022 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10023 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) {
10024 0         0 $char[$i] = e_capture($1.'->'.$2);
10025             if ($ignorecase) {
10026             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10027             }
10028             }
10029              
10030 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10031 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) {
10032 0         0 $char[$i] = e_capture($1.'->'.$2);
10033             if ($ignorecase) {
10034             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10035             }
10036             }
10037              
10038 0         0 # $$foo
10039 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10040 0         0 $char[$i] = e_capture($1);
10041             if ($ignorecase) {
10042             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10043             }
10044             }
10045              
10046 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
10047 4         15 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10048             if ($ignorecase) {
10049             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::PREMATCH())]}';
10050 0         0 }
10051             else {
10052             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
10053             }
10054             }
10055              
10056 4 50       20 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
10057 4         16 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10058             if ($ignorecase) {
10059             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::MATCH())]}';
10060 0         0 }
10061             else {
10062             $char[$i] = '@{[Einformixv6als::MATCH()]}';
10063             }
10064             }
10065              
10066 4 50       18 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
10067 3         12 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10068             if ($ignorecase) {
10069             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::POSTMATCH())]}';
10070 0         0 }
10071             else {
10072             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
10073             }
10074             }
10075              
10076 3 0       11 # ${ foo }
10077 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) {
10078             if ($ignorecase) {
10079             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10080             }
10081             }
10082              
10083 0         0 # ${ ... }
10084 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10085 0         0 $char[$i] = e_capture($1);
10086             if ($ignorecase) {
10087             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10088             }
10089             }
10090              
10091 0         0 # $scalar or @array
10092 13 50       52 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10093 13         60 $char[$i] = e_string($char[$i]);
10094             if ($ignorecase) {
10095             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10096             }
10097             }
10098              
10099 0 50       0 # quote character before ? + * {
10100             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10101             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10102 23         139 }
10103             else {
10104             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10105             }
10106             }
10107             }
10108 23         127  
10109 142         340 # make regexp string
10110 142         380 my $prematch = '';
10111 142 50       241 $prematch = "($anchor)";
10112 142         369 $modifier =~ tr/i//d;
10113             if ($left_e > $right_e) {
10114 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10115             }
10116             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10117             }
10118              
10119             #
10120             # escape regexp (s'here'' or s'here''b)
10121 142     96 0 1785 #
10122 96   100     194 sub e_s1_q {
10123             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10124 96         241 $modifier ||= '';
10125 96 50       186  
10126 96         223 $modifier =~ tr/p//d;
10127 0         0 if ($modifier =~ /([adlu])/oxms) {
10128 0 0       0 my $line = 0;
10129 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10130 0         0 if ($filename ne __FILE__) {
10131             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10132             last;
10133 0         0 }
10134             }
10135             die qq{Unsupported modifier "$1" used at line $line.\n};
10136 0         0 }
10137              
10138             $slash = 'div';
10139 96 100       142  
    100          
10140 96         208 # literal null string pattern
10141 8         12 if ($string eq '') {
10142 8         11 $modifier =~ tr/bB//d;
10143             $modifier =~ tr/i//d;
10144             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10145             }
10146              
10147 8         56 # with /b /B modifier
10148             elsif ($modifier =~ tr/bB//d) {
10149             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10150             }
10151              
10152 44         85 # without /b /B modifier
10153             else {
10154             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10155             }
10156             }
10157              
10158             #
10159             # escape regexp (s'here'')
10160 44     44 0 92 #
10161             sub e_s1_qt {
10162 44 100       100 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10163              
10164             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10165 44         88  
10166             # split regexp
10167             my @char = $string =~ /\G((?>
10168             [^\x81-\x9F\xE0-\xFD\\\[\$\@\/] |
10169             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
10170             \[\^ |
10171             \[\: (?>[a-z]+) \:\] |
10172             \[\:\^ (?>[a-z]+) \:\] |
10173             [\$\@\/] |
10174             \\ (?:$q_char) |
10175             (?:$q_char)
10176             ))/oxmsg;
10177 44         522  
10178 44 50 100     120 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10179             for (my $i=0; $i <= $#char; $i++) {
10180             if (0) {
10181             }
10182 62         569  
10183 0         0 # escape last octet of multiple-octet
10184             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10185             $char[$i] = $1 . '\\' . $2;
10186             }
10187              
10188 0         0 # open character class [...]
10189 0 0       0 elsif ($char[$i] eq '[') {
10190 0         0 my $left = $i;
10191             if ($char[$i+1] eq ']') {
10192 0         0 $i++;
10193 0 0       0 }
10194 0         0 while (1) {
10195             if (++$i > $#char) {
10196 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10197 0         0 }
10198             if ($char[$i] eq ']') {
10199             my $right = $i;
10200 0         0  
10201             # [...]
10202 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
10203 0         0  
10204             $i = $left;
10205             last;
10206             }
10207             }
10208             }
10209              
10210 0         0 # open character class [^...]
10211 0 0       0 elsif ($char[$i] eq '[^') {
10212 0         0 my $left = $i;
10213             if ($char[$i+1] eq ']') {
10214 0         0 $i++;
10215 0 0       0 }
10216 0         0 while (1) {
10217             if (++$i > $#char) {
10218 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10219 0         0 }
10220             if ($char[$i] eq ']') {
10221             my $right = $i;
10222 0         0  
10223             # [^...]
10224 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10225 0         0  
10226             $i = $left;
10227             last;
10228             }
10229             }
10230             }
10231              
10232 0         0 # escape $ @ / and \
10233             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10234             $char[$i] = '\\' . $char[$i];
10235             }
10236              
10237 0         0 # rewrite character class or escape character
10238             elsif (my $char = character_class($char[$i],$modifier)) {
10239             $char[$i] = $char;
10240             }
10241              
10242 6 50       14 # /i modifier
10243 8         20 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
10244             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
10245             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
10246 8         16 }
10247             else {
10248             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
10249             }
10250             }
10251              
10252 0 0       0 # quote character before ? + * {
10253             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10254             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10255 0         0 }
10256             else {
10257             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10258             }
10259             }
10260 0         0 }
10261 44         90  
10262 44         68 $modifier =~ tr/i//d;
10263 44         51 $delimiter = '/';
10264 44         55 $end_delimiter = '/';
10265 44         85 my $prematch = '';
10266             $prematch = "($anchor)";
10267             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10268             }
10269              
10270             #
10271             # escape regexp (s'here''b)
10272 44     44 0 292 #
10273             sub e_s1_qb {
10274             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10275 44         93  
10276             # split regexp
10277             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10278 44         156  
10279 44 50       131 # unescape character
    50          
10280             for (my $i=0; $i <= $#char; $i++) {
10281             if (0) {
10282             }
10283 98         310  
10284             # remain \\
10285             elsif ($char[$i] eq '\\\\') {
10286             }
10287              
10288 0         0 # escape $ @ / and \
10289             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10290             $char[$i] = '\\' . $char[$i];
10291             }
10292 0         0 }
10293 44         71  
10294 44         53 $delimiter = '/';
10295 44         52 $end_delimiter = '/';
10296 44         51 my $prematch = '';
10297             $prematch = q{(\G[\x00-\xFF]*?)};
10298             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10299             }
10300              
10301             #
10302             # escape regexp (s''here')
10303 44     91 0 278 #
10304             sub e_s2_q {
10305 91         165 my($ope,$delimiter,$end_delimiter,$string) = @_;
10306              
10307 91         118 $slash = 'div';
10308 91         332  
10309 91 50 66     230 my @char = $string =~ / \G (?>[^\x81-\x9F\xE0-\xFD\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10310             for (my $i=0; $i <= $#char; $i++) {
10311             if (0) {
10312             }
10313 9         101  
10314 0         0 # escape last octet of multiple-octet
10315             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10316             $char[$i] = $1 . '\\' . $2;
10317 0         0 }
10318             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10319             $char[$i] = $1 . '\\' . $2;
10320             }
10321              
10322             # not escape \\
10323             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10324             }
10325              
10326 0         0 # escape $ @ / and \
10327             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10328             $char[$i] = '\\' . $char[$i];
10329 5 50 66     19 }
10330 91         226 }
10331             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10332             $char[-1] = $1 . '\\' . $2;
10333 0         0 }
10334              
10335             return join '', $ope, $delimiter, @char, $end_delimiter;
10336             }
10337              
10338             #
10339             # escape regexp (s/here/and here/modifier)
10340 91     290 0 264 #
10341 290   100     2178 sub e_sub {
10342             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10343 290         1165 $modifier ||= '';
10344 290 50       563  
10345 290         1016 $modifier =~ tr/p//d;
10346 0         0 if ($modifier =~ /([adlu])/oxms) {
10347 0 0       0 my $line = 0;
10348 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10349 0         0 if ($filename ne __FILE__) {
10350             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10351             last;
10352 0         0 }
10353             }
10354             die qq{Unsupported modifier "$1" used at line $line.\n};
10355 0 100       0 }
10356 290         672  
10357 37         52 if ($variable eq '') {
10358             $variable = '$_';
10359             $bind_operator = ' =~ ';
10360 37         54 }
10361              
10362             $slash = 'div';
10363              
10364             # P.128 Start of match (or end of previous match): \G
10365             # P.130 Advanced Use of \G with Perl
10366             # in Chapter 3: Overview of Regular Expression Features and Flavors
10367             # P.312 Iterative Matching: Scalar Context, with /g
10368             # in Chapter 7: Perl
10369             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10370              
10371             # P.181 Where You Left Off: The \G Assertion
10372             # in Chapter 5: Pattern Matching
10373             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10374              
10375             # P.220 Where You Left Off: The \G Assertion
10376             # in Chapter 5: Pattern Matching
10377 290         453 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10378 290         436  
10379             my $e_modifier = $modifier =~ tr/e//d;
10380 290         502 my $r_modifier = $modifier =~ tr/r//d;
10381 290 50       445  
10382 290         698 my $my = '';
10383 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10384 0         0 $my = $variable;
10385             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10386             $variable =~ s/ = .+ \z//oxms;
10387 0         0 }
10388 290         675  
10389             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10390             $variable_basename =~ s/ \s+ \z//oxms;
10391 290         509  
10392 290 100       437 # quote replacement string
10393 290         617 my $e_replacement = '';
10394 17         34 if ($e_modifier >= 1) {
10395             $e_replacement = e_qq('', '', '', $replacement);
10396             $e_modifier--;
10397 17 100       27 }
10398 273         553 else {
10399             if ($delimiter2 eq "'") {
10400             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10401 91         178 }
10402             else {
10403             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10404             }
10405 182         439 }
10406              
10407             my $sub = '';
10408 290 100       495  
10409 290 100       595 # with /r
    50          
10410             if ($r_modifier) {
10411             if (0) {
10412             }
10413 8         26  
10414 0 50       0 # s///gr with multibyte anchoring
10415             elsif ($modifier =~ /g/oxms) {
10416             $sub = sprintf(
10417             # 1 2 3 4 5
10418             q,
10419              
10420             $variable, # 1
10421             ($delimiter1 eq "'") ? # 2
10422             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10423             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10424             $s_matched, # 3
10425             $e_replacement, # 4
10426             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10427             );
10428             }
10429              
10430 4 0       17 # s///gr without multibyte anchoring
10431             elsif ($modifier =~ /g/oxms) {
10432             $sub = sprintf(
10433             # 1 2 3 4 5
10434             q,
10435              
10436             $variable, # 1
10437             ($delimiter1 eq "'") ? # 2
10438             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10439             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10440             $s_matched, # 3
10441             $e_replacement, # 4
10442             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10443             );
10444             }
10445              
10446             # s///r
10447 0         0 else {
10448 4         6  
10449             my $prematch = q{$`};
10450 4 50       7 $prematch = q{${1}};
10451              
10452             $sub = sprintf(
10453             # 1 2 3 4 5 6 7
10454             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Einformixv6als::re_r=%s; %s"%s$Einformixv6als::re_r$'" } : %s>,
10455              
10456             $variable, # 1
10457             ($delimiter1 eq "'") ? # 2
10458             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10459             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10460             $s_matched, # 3
10461             $e_replacement, # 4
10462             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10463             $prematch, # 6
10464             $variable, # 7
10465             );
10466             }
10467 4 50       19  
10468 8         30 # $var !~ s///r doesn't make sense
10469             if ($bind_operator =~ / !~ /oxms) {
10470             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10471             }
10472             }
10473              
10474 0 100       0 # without /r
    50          
10475             else {
10476             if (0) {
10477             }
10478 282         848  
10479 0 100       0 # s///g with multibyte anchoring
    100          
10480             elsif ($modifier =~ /g/oxms) {
10481             $sub = sprintf(
10482             # 1 2 3 4 5 6 7 8 9 10
10483             q,
10484              
10485             $variable, # 1
10486             ($delimiter1 eq "'") ? # 2
10487             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10488             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10489             $s_matched, # 3
10490             $e_replacement, # 4
10491             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10492             $variable, # 6
10493             $variable, # 7
10494             $variable, # 8
10495             $variable, # 9
10496              
10497             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10498             # It returns false if the match succeeds, and true if it fails.
10499             # (and so on)
10500              
10501             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10502             );
10503             }
10504              
10505 35 0       141 # s///g without multibyte anchoring
    0          
10506             elsif ($modifier =~ /g/oxms) {
10507             $sub = sprintf(
10508             # 1 2 3 4 5 6 7 8
10509             q,
10510              
10511             $variable, # 1
10512             ($delimiter1 eq "'") ? # 2
10513             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10514             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10515             $s_matched, # 3
10516             $e_replacement, # 4
10517             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 5
10518             $variable, # 6
10519             $variable, # 7
10520             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10521             );
10522             }
10523              
10524             # s///
10525 0         0 else {
10526 247         376  
10527             my $prematch = q{$`};
10528 247 100       333 $prematch = q{${1}};
    100          
10529              
10530             $sub = sprintf(
10531              
10532             ($bind_operator =~ / =~ /oxms) ?
10533              
10534             # 1 2 3 4 5 6 7 8
10535             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Einformixv6als::re_r=%s; %s%s="%s$Einformixv6als::re_r$'"; 1 } : undef> :
10536              
10537             # 1 2 3 4 5 6 7 8
10538             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Einformixv6als::re_r=%s; %s%s="%s$Einformixv6als::re_r$'"; undef }>,
10539              
10540             $variable, # 1
10541             $bind_operator, # 2
10542             ($delimiter1 eq "'") ? # 3
10543             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10544             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10545             $s_matched, # 4
10546             $e_replacement, # 5
10547             '$Einformixv6als::re_r=CORE::eval $Einformixv6als::re_r; ' x $e_modifier, # 6
10548             $variable, # 7
10549             $prematch, # 8
10550             );
10551             }
10552             }
10553 247 50       1215  
10554 290         781 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10555             if ($my ne '') {
10556             $sub = "($my, $sub)[1]";
10557             }
10558 0         0  
10559 290         443 # clear s/// variable
10560             $sub_variable = '';
10561 290         372 $bind_operator = '';
10562              
10563             return $sub;
10564             }
10565              
10566             #
10567             # escape chdir (qq//, "")
10568 290     0 0 2180 #
10569             sub e_chdir {
10570 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10571 0 0       0  
10572 0 0       0 if ($^W) {
10573 0         0 if (Einformixv6als::_MSWin32_5Cended_path($string)) {
10574 0         0 if ($] !~ /^5\.005/oxms) {
10575             warn <
10576             @{[__FILE__]}: Can't chdir to '$string'
10577              
10578             chdir does not work with chr(0x5C) at end of path
10579             http://bugs.activestate.com/show_bug.cgi?id=81839
10580             END
10581             }
10582             }
10583 0         0 }
10584              
10585             return e_qq($ope,$delimiter,$end_delimiter,$string);
10586             }
10587              
10588             #
10589             # escape chdir (q//, '')
10590 0     2 0 0 #
10591             sub e_chdir_q {
10592 2 50       6 my($ope,$delimiter,$end_delimiter,$string) = @_;
10593 2 0       7  
10594 0 0       0 if ($^W) {
10595 0         0 if (Einformixv6als::_MSWin32_5Cended_path($string)) {
10596 0         0 if ($] !~ /^5\.005/oxms) {
10597             warn <
10598             @{[__FILE__]}: Can't chdir to '$string'
10599              
10600             chdir does not work with chr(0x5C) at end of path
10601             http://bugs.activestate.com/show_bug.cgi?id=81839
10602             END
10603             }
10604             }
10605 0         0 }
10606              
10607             return e_q($ope,$delimiter,$end_delimiter,$string);
10608             }
10609              
10610             #
10611             # escape regexp of split qr//
10612 2     273 0 13 #
10613 273   100     1252 sub e_split {
10614             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10615 273         1054 $modifier ||= '';
10616 273 50       514  
10617 273         738 $modifier =~ tr/p//d;
10618 0         0 if ($modifier =~ /([adlu])/oxms) {
10619 0 0       0 my $line = 0;
10620 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10621 0         0 if ($filename ne __FILE__) {
10622             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10623             last;
10624 0         0 }
10625             }
10626             die qq{Unsupported modifier "$1" used at line $line.\n};
10627 0         0 }
10628              
10629             $slash = 'div';
10630 273 100       450  
10631 273         606 # /b /B modifier
10632             if ($modifier =~ tr/bB//d) {
10633             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10634 84 100       390 }
10635 189         641  
10636             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10637             my $metachar = qr/[\@\\|[\]{^]/oxms;
10638 189         697  
10639             # split regexp
10640             my @char = $string =~ /\G((?>
10641             [^\x81-\x9F\xE0-\xFD\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
10642             \\x (?>[0-9A-Fa-f]{1,2}) |
10643             \\ (?>[0-7]{2,3}) |
10644             \\c [\x40-\x5F] |
10645             \\x\{ (?>[0-9A-Fa-f]+) \} |
10646             \\o\{ (?>[0-7]+) \} |
10647             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} |
10648             \\ $q_char |
10649             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10650             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10651             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10652             [\$\@] $qq_variable |
10653             \$ (?>\s* [0-9]+) |
10654             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10655             \$ \$ (?![\w\{]) |
10656             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10657             \[\^ |
10658             \[\: (?>[a-z]+) :\] |
10659             \[\:\^ (?>[a-z]+) :\] |
10660             \(\? |
10661             $q_char
10662 189         19170 ))/oxmsg;
10663 189         697  
10664 189         298 my $left_e = 0;
10665             my $right_e = 0;
10666             for (my $i=0; $i <= $#char; $i++) {
10667 189 50 33     714  
    50 33        
    100          
    100          
    50          
    50          
10668 372         2492 # "\L\u" --> "\u\L"
10669             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10670             @char[$i,$i+1] = @char[$i+1,$i];
10671             }
10672              
10673 0         0 # "\U\l" --> "\l\U"
10674             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10675             @char[$i,$i+1] = @char[$i+1,$i];
10676             }
10677              
10678 0         0 # octal escape sequence
10679             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10680             $char[$i] = Einformixv6als::octchr($1);
10681             }
10682              
10683 1         4 # hexadecimal escape sequence
10684             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10685             $char[$i] = Einformixv6als::hexchr($1);
10686             }
10687              
10688             # \b{...} --> b\{...}
10689             # \B{...} --> B\{...}
10690             # \N{CHARNAME} --> N\{CHARNAME}
10691             # \p{PROPERTY} --> p\{PROPERTY}
10692 1         3 # \P{PROPERTY} --> P\{PROPERTY}
10693             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFD0-9\}][^\x81-\x9F\xE0-\xFD\}]*) \} ) \z/oxms) {
10694             $char[$i] = $1 . '\\' . $2;
10695             }
10696              
10697 0         0 # \p, \P, \X --> p, P, X
10698             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10699             $char[$i] = $1;
10700 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          
10701              
10702             if (0) {
10703             }
10704 372         3410  
10705 0         0 # escape last octet of multiple-octet
10706             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10707             $char[$i] = $1 . '\\' . $2;
10708             }
10709              
10710 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10711 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10712             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)) {
10713             $char[$i] .= join '', splice @char, $i+1, 3;
10714 0         0 }
10715             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)) {
10716             $char[$i] .= join '', splice @char, $i+1, 2;
10717 0         0 }
10718             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)) {
10719             $char[$i] .= join '', splice @char, $i+1, 1;
10720             }
10721             }
10722              
10723 0         0 # open character class [...]
10724 3 50       6 elsif ($char[$i] eq '[') {
10725 3         12 my $left = $i;
10726             if ($char[$i+1] eq ']') {
10727 0         0 $i++;
10728 3 50       6 }
10729 7         12 while (1) {
10730             if (++$i > $#char) {
10731 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10732 7         17 }
10733             if ($char[$i] eq ']') {
10734             my $right = $i;
10735 3 50       4  
10736 3         18 # [...]
  0         0  
10737             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10738             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);
10739 0         0 }
10740             else {
10741             splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
10742 3         14 }
10743 3         6  
10744             $i = $left;
10745             last;
10746             }
10747             }
10748             }
10749              
10750 3         8 # open character class [^...]
10751 1 50       3 elsif ($char[$i] eq '[^') {
10752 1         4 my $left = $i;
10753             if ($char[$i+1] eq ']') {
10754 0         0 $i++;
10755 1 50       2 }
10756 2         7 while (1) {
10757             if (++$i > $#char) {
10758 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10759 2         5 }
10760             if ($char[$i] eq ']') {
10761             my $right = $i;
10762 1 50       2  
10763 1         9 # [^...]
  0         0  
10764             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10765             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);
10766 0         0 }
10767             else {
10768             splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10769 1         29 }
10770 1         3  
10771             $i = $left;
10772             last;
10773             }
10774             }
10775             }
10776              
10777 1         3 # rewrite character class or escape character
10778             elsif (my $char = character_class($char[$i],$modifier)) {
10779             $char[$i] = $char;
10780             }
10781              
10782             # P.794 29.2.161. split
10783             # in Chapter 29: Functions
10784             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10785              
10786             # P.951 split
10787             # in Chapter 27: Functions
10788             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10789              
10790             # said "The //m modifier is assumed when you split on the pattern /^/",
10791             # but perl5.008 is not so. Therefore, this software adds //m.
10792             # (and so on)
10793              
10794 5         21 # split(m/^/) --> split(m/^/m)
10795             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10796             $modifier .= 'm';
10797             }
10798              
10799 11 50       42 # /i modifier
10800 18         37 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
10801             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
10802             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
10803 18         35 }
10804             else {
10805             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
10806             }
10807             }
10808              
10809 0 50       0 # \u \l \U \L \F \Q \E
10810 2         7 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10811             if ($right_e < $left_e) {
10812             $char[$i] = '\\' . $char[$i];
10813             }
10814 0         0 }
10815 0         0 elsif ($char[$i] eq '\u') {
10816             $char[$i] = '@{[Einformixv6als::ucfirst qq<';
10817             $left_e++;
10818 0         0 }
10819 0         0 elsif ($char[$i] eq '\l') {
10820             $char[$i] = '@{[Einformixv6als::lcfirst qq<';
10821             $left_e++;
10822 0         0 }
10823 0         0 elsif ($char[$i] eq '\U') {
10824             $char[$i] = '@{[Einformixv6als::uc qq<';
10825             $left_e++;
10826 0         0 }
10827 0         0 elsif ($char[$i] eq '\L') {
10828             $char[$i] = '@{[Einformixv6als::lc qq<';
10829             $left_e++;
10830 0         0 }
10831 0         0 elsif ($char[$i] eq '\F') {
10832             $char[$i] = '@{[Einformixv6als::fc qq<';
10833             $left_e++;
10834 0         0 }
10835 0         0 elsif ($char[$i] eq '\Q') {
10836             $char[$i] = '@{[CORE::quotemeta qq<';
10837             $left_e++;
10838 0 0       0 }
10839 0         0 elsif ($char[$i] eq '\E') {
10840 0         0 if ($right_e < $left_e) {
10841             $char[$i] = '>]}';
10842             $right_e++;
10843 0         0 }
10844             else {
10845             $char[$i] = '';
10846             }
10847 0         0 }
10848 0 0       0 elsif ($char[$i] eq '\Q') {
10849 0         0 while (1) {
10850             if (++$i > $#char) {
10851 0 0       0 last;
10852 0         0 }
10853             if ($char[$i] eq '\E') {
10854             last;
10855             }
10856             }
10857             }
10858             elsif ($char[$i] eq '\E') {
10859             }
10860              
10861 0 0       0 # $0 --> $0
10862 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10863             if ($ignorecase) {
10864             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10865             }
10866 0 0       0 }
10867 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10868             if ($ignorecase) {
10869             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10870             }
10871             }
10872              
10873             # $$ --> $$
10874             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10875             }
10876              
10877             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10878 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10879 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10880 0         0 $char[$i] = e_capture($1);
10881             if ($ignorecase) {
10882             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10883             }
10884 0         0 }
10885 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10886 0         0 $char[$i] = e_capture($1);
10887             if ($ignorecase) {
10888             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10889             }
10890             }
10891              
10892 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10893 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) {
10894 0         0 $char[$i] = e_capture($1.'->'.$2);
10895             if ($ignorecase) {
10896             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10897             }
10898             }
10899              
10900 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10901 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) {
10902 0         0 $char[$i] = e_capture($1.'->'.$2);
10903             if ($ignorecase) {
10904             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10905             }
10906             }
10907              
10908 0         0 # $$foo
10909 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10910 0         0 $char[$i] = e_capture($1);
10911             if ($ignorecase) {
10912             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10913             }
10914             }
10915              
10916 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Einformixv6als::PREMATCH()
10917 12         41 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10918             if ($ignorecase) {
10919             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::PREMATCH())]}';
10920 0         0 }
10921             else {
10922             $char[$i] = '@{[Einformixv6als::PREMATCH()]}';
10923             }
10924             }
10925              
10926 12 50       64 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Einformixv6als::MATCH()
10927 12         39 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10928             if ($ignorecase) {
10929             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::MATCH())]}';
10930 0         0 }
10931             else {
10932             $char[$i] = '@{[Einformixv6als::MATCH()]}';
10933             }
10934             }
10935              
10936 12 50       71 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Einformixv6als::POSTMATCH()
10937 9         23 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10938             if ($ignorecase) {
10939             $char[$i] = '@{[Einformixv6als::ignorecase(Einformixv6als::POSTMATCH())]}';
10940 0         0 }
10941             else {
10942             $char[$i] = '@{[Einformixv6als::POSTMATCH()]}';
10943             }
10944             }
10945              
10946 9 0       46 # ${ foo }
10947 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) {
10948             if ($ignorecase) {
10949             $char[$i] = '@{[Einformixv6als::ignorecase(' . $1 . ')]}';
10950             }
10951             }
10952              
10953 0         0 # ${ ... }
10954 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10955 0         0 $char[$i] = e_capture($1);
10956             if ($ignorecase) {
10957             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10958             }
10959             }
10960              
10961 0         0 # $scalar or @array
10962 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10963 3         15 $char[$i] = e_string($char[$i]);
10964             if ($ignorecase) {
10965             $char[$i] = '@{[Einformixv6als::ignorecase(' . $char[$i] . ')]}';
10966             }
10967             }
10968              
10969 0 100       0 # quote character before ? + * {
10970             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10971             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10972 7         47 }
10973             else {
10974             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10975             }
10976             }
10977             }
10978 4         25  
10979 189 50       406 # make regexp string
10980 189         429 $modifier =~ tr/i//d;
10981             if ($left_e > $right_e) {
10982 0         0 return join '', 'Einformixv6als::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10983             }
10984             return join '', 'Einformixv6als::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10985             }
10986              
10987             #
10988             # escape regexp of split qr''
10989 189     112 0 1756 #
10990 112   100     631 sub e_split_q {
10991             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10992 112         409 $modifier ||= '';
10993 112 50       350  
10994 112         374 $modifier =~ tr/p//d;
10995 0         0 if ($modifier =~ /([adlu])/oxms) {
10996 0 0       0 my $line = 0;
10997 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10998 0         0 if ($filename ne __FILE__) {
10999             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
11000             last;
11001 0         0 }
11002             }
11003             die qq{Unsupported modifier "$1" used at line $line.\n};
11004 0         0 }
11005              
11006             $slash = 'div';
11007 112 100       293  
11008 112         255 # /b /B modifier
11009             if ($modifier =~ tr/bB//d) {
11010             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
11011 56 100       301 }
11012              
11013             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11014 56         153  
11015             # split regexp
11016             my @char = $string =~ /\G((?>
11017             [^\x81-\x9F\xE0-\xFD\\\[] |
11018             [\x81-\x9F\xE0-\xFC][\x00-\xFF]|\xFD[\xA1-\xFE][\x00-\xFF] |
11019             \[\^ |
11020             \[\: (?>[a-z]+) \:\] |
11021             \[\:\^ (?>[a-z]+) \:\] |
11022             \\ (?:$q_char) |
11023             (?:$q_char)
11024             ))/oxmsg;
11025 56         350  
11026 56 50 33     175 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11027             for (my $i=0; $i <= $#char; $i++) {
11028             if (0) {
11029             }
11030 56         527  
11031 0         0 # escape last octet of multiple-octet
11032             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11033             $char[$i] = $1 . '\\' . $2;
11034             }
11035              
11036 0         0 # open character class [...]
11037 0 0       0 elsif ($char[$i] eq '[') {
11038 0         0 my $left = $i;
11039             if ($char[$i+1] eq ']') {
11040 0         0 $i++;
11041 0 0       0 }
11042 0         0 while (1) {
11043             if (++$i > $#char) {
11044 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11045 0         0 }
11046             if ($char[$i] eq ']') {
11047             my $right = $i;
11048 0         0  
11049             # [...]
11050 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_qr(@char[$left+1..$right-1], $modifier);
11051 0         0  
11052             $i = $left;
11053             last;
11054             }
11055             }
11056             }
11057              
11058 0         0 # open character class [^...]
11059 0 0       0 elsif ($char[$i] eq '[^') {
11060 0         0 my $left = $i;
11061             if ($char[$i+1] eq ']') {
11062 0         0 $i++;
11063 0 0       0 }
11064 0         0 while (1) {
11065             if (++$i > $#char) {
11066 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11067 0         0 }
11068             if ($char[$i] eq ']') {
11069             my $right = $i;
11070 0         0  
11071             # [^...]
11072 0         0 splice @char, $left, $right-$left+1, Einformixv6als::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11073 0         0  
11074             $i = $left;
11075             last;
11076             }
11077             }
11078             }
11079              
11080 0         0 # rewrite character class or escape character
11081             elsif (my $char = character_class($char[$i],$modifier)) {
11082             $char[$i] = $char;
11083             }
11084              
11085 0         0 # split(m/^/) --> split(m/^/m)
11086             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11087             $modifier .= 'm';
11088             }
11089              
11090 0 50       0 # /i modifier
11091 12         27 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Einformixv6als::uc($char[$i]) ne Einformixv6als::fc($char[$i]))) {
11092             if (CORE::length(Einformixv6als::fc($char[$i])) == 1) {
11093             $char[$i] = '[' . Einformixv6als::uc($char[$i]) . Einformixv6als::fc($char[$i]) . ']';
11094 12         28 }
11095             else {
11096             $char[$i] = '(?:' . Einformixv6als::uc($char[$i]) . '|' . Einformixv6als::fc($char[$i]) . ')';
11097             }
11098             }
11099              
11100 0 0       0 # quote character before ? + * {
11101             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11102             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11103 0         0 }
11104             else {
11105             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11106             }
11107             }
11108 0         0 }
11109 56         113  
11110             $modifier =~ tr/i//d;
11111             return join '', 'Einformixv6als::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11112             }
11113              
11114             #
11115             # escape use without import
11116 56     0 0 306 #
11117             sub e_use_noimport {
11118 0           my($module) = @_;
11119              
11120 0           my $expr = _pathof($module);
11121 0            
11122             my $fh = gensym();
11123 0 0         for my $realfilename (_realfilename($expr)) {
11124 0            
11125 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11126 0 0         local $/ = undef; # slurp mode
11127             my $script = <$fh>;
11128 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11129 0            
11130             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11131 0           return qq;
11132             }
11133             last;
11134             }
11135 0           }
11136              
11137             return qq;
11138             }
11139              
11140             #
11141             # escape no without unimport
11142 0     0 0   #
11143             sub e_no_nounimport {
11144 0           my($module) = @_;
11145              
11146 0           my $expr = _pathof($module);
11147 0            
11148             my $fh = gensym();
11149 0 0         for my $realfilename (_realfilename($expr)) {
11150 0            
11151 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11152 0 0         local $/ = undef; # slurp mode
11153             my $script = <$fh>;
11154 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11155 0            
11156             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11157 0           return qq;
11158             }
11159             last;
11160             }
11161 0           }
11162              
11163             return qq;
11164             }
11165              
11166             #
11167             # escape use with import no parameter
11168 0     0 0   #
11169             sub e_use_noparam {
11170 0           my($module) = @_;
11171              
11172 0           my $expr = _pathof($module);
11173 0            
11174             my $fh = gensym();
11175 0 0         for my $realfilename (_realfilename($expr)) {
11176 0            
11177 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11178 0 0         local $/ = undef; # slurp mode
11179             my $script = <$fh>;
11180 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11181              
11182             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11183              
11184             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11185             # in Chapter 12: Objects
11186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11187              
11188             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11189             # in Chapter 12: Objects
11190             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11191              
11192 0           # (and so on)
11193              
11194 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->import() if $module->can('import'); }];
11195             }
11196             last;
11197             }
11198 0           }
11199              
11200             return qq;
11201             }
11202              
11203             #
11204             # escape no with unimport no parameter
11205 0     0 0   #
11206             sub e_no_noparam {
11207 0           my($module) = @_;
11208              
11209 0           my $expr = _pathof($module);
11210 0            
11211             my $fh = gensym();
11212 0 0         for my $realfilename (_realfilename($expr)) {
11213 0            
11214 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11215 0 0         local $/ = undef; # slurp mode
11216             my $script = <$fh>;
11217 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11218 0            
11219             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11220 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11221             }
11222             last;
11223             }
11224 0           }
11225              
11226             return qq;
11227             }
11228              
11229             #
11230             # escape use with import parameters
11231 0     0 0   #
11232             sub e_use {
11233 0           my($module,$list) = @_;
11234              
11235 0           my $expr = _pathof($module);
11236 0            
11237             my $fh = gensym();
11238 0 0         for my $realfilename (_realfilename($expr)) {
11239 0            
11240 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11241 0 0         local $/ = undef; # slurp mode
11242             my $script = <$fh>;
11243 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11244 0            
11245             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11246 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->import($list) if $module->can('import'); }];
11247             }
11248             last;
11249             }
11250 0           }
11251              
11252             return qq;
11253             }
11254              
11255             #
11256             # escape no with unimport parameters
11257 0     0 0   #
11258             sub e_no {
11259 0           my($module,$list) = @_;
11260              
11261 0           my $expr = _pathof($module);
11262 0            
11263             my $fh = gensym();
11264 0 0         for my $realfilename (_realfilename($expr)) {
11265 0            
11266 0           if (Einformixv6als::_open_r($fh, $realfilename)) {
11267 0 0         local $/ = undef; # slurp mode
11268             my $script = <$fh>;
11269 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11270 0            
11271             if ($script =~ /^ (?>\s*) use (?>\s+) INFORMIXV6ALS (?>\s*) ([^\x81-\x9F\xE0-\xFD;]*) ; (?>\s*) \n? $/oxms) {
11272 0           return qq[BEGIN { Einformixv6als::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11273             }
11274             last;
11275             }
11276 0           }
11277              
11278             return qq;
11279             }
11280              
11281             #
11282             # file path of module
11283 0     0     #
11284             sub _pathof {
11285 0 0         my($expr) = @_;
11286 0            
11287             if ($^O eq 'MacOS') {
11288             $expr =~ s#::#:#g;
11289 0           }
11290             else {
11291 0 0         $expr =~ s#::#/#g;
11292             }
11293 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11294              
11295             return $expr;
11296             }
11297              
11298             #
11299             # real file name of module
11300 0     0     #
11301             sub _realfilename {
11302 0 0         my($expr) = @_;
11303 0            
  0            
11304             if ($^O eq 'MacOS') {
11305             return map {"$_$expr"} @INC;
11306 0           }
  0            
11307             else {
11308             return map {"$_/$expr"} @INC;
11309             }
11310             }
11311              
11312             #
11313             # instead of Carp::carp
11314 0     0 0   #
11315 0           sub carp {
11316             my($package,$filename,$line) = caller(1);
11317             print STDERR "@_ at $filename line $line.\n";
11318             }
11319              
11320             #
11321             # instead of Carp::croak
11322 0     0 0   #
11323 0           sub croak {
11324 0           my($package,$filename,$line) = caller(1);
11325             print STDERR "@_ at $filename line $line.\n";
11326             die "\n";
11327             }
11328              
11329             #
11330             # instead of Carp::cluck
11331 0     0 0   #
11332 0           sub cluck {
11333 0           my $i = 0;
11334 0           my @cluck = ();
11335 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11336             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11337 0           $i++;
11338 0           }
11339 0           print STDERR CORE::reverse @cluck;
11340             print STDERR "\n";
11341             print STDERR @_;
11342             }
11343              
11344             #
11345             # instead of Carp::confess
11346 0     0 0   #
11347 0           sub confess {
11348 0           my $i = 0;
11349 0           my @confess = ();
11350 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11351             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11352 0           $i++;
11353 0           }
11354 0           print STDERR CORE::reverse @confess;
11355 0           print STDERR "\n";
11356             print STDERR @_;
11357             die "\n";
11358             }
11359              
11360             1;
11361              
11362             __END__