File Coverage

blib/lib/Elatin8.pm
Criterion Covered Total %
statement 905 2814 32.1
branch 890 2412 36.9
condition 98 355 27.6
subroutine 54 113 47.7
pod 7 74 9.4
total 1954 5768 33.8


line stmt bran cond sub pod time code
1             package Elatin8;
2 206     206   1117 use strict;
  206         331  
  206         7411  
3 206 50   206   3395 BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 } use warnings;
  206     206   850  
  206         323  
  206         6105  
4             ######################################################################
5             #
6             # Elatin8 - Run-time routines for Latin8.pm
7             #
8             # http://search.cpan.org/dist/Char-Latin8/
9             #
10             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
11             ######################################################################
12              
13 206     206   3123 use 5.00503; # Galapagos Consensus 1998 for primetools
  206         671  
14             # use 5.008001; # Lancaster Consensus 2013 for toolchains
15              
16             # 12.3. Delaying use Until Runtime
17             # in Chapter 12. Packages, Libraries, and Modules
18             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
19             # (and so on)
20              
21             # Version numbers should be boring
22             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
23             # For the impatient, the disinterested or those who just want to follow
24             # a recipe, my advice for all modules is this:
25             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
26             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
27              
28 206     206   994 use vars qw($VERSION);
  206         384  
  206         28715  
29             $VERSION = '1.22';
30             $VERSION = $VERSION;
31              
32             BEGIN {
33 206 50   206   1196 if ($^X =~ / jperl /oxmsi) {
34 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
35             }
36 206         304 if (CORE::ord('A') == 193) {
37             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
38             }
39 206         24440 if (CORE::ord('A') != 0x41) {
40             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
41             }
42             }
43              
44             BEGIN {
45              
46             # instead of utf8.pm
47 206     206   12596 CORE::eval q{
  206     206   1201  
  206     68   396  
  206         20615  
  0         0  
  0         0  
  0         0  
  0         0  
48             no warnings qw(redefine);
49             *utf8::upgrade = sub { CORE::length $_[0] };
50             *utf8::downgrade = sub { 1 };
51             *utf8::encode = sub { };
52             *utf8::decode = sub { 1 };
53             *utf8::is_utf8 = sub { };
54             *utf8::valid = sub { 1 };
55             };
56 206 50       76418 if ($@) {
57 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
58 0         0 *utf8::downgrade = sub { 1 };
  0         0  
59 0         0 *utf8::encode = sub { };
60 0         0 *utf8::decode = sub { 1 };
  0         0  
61 0         0 *utf8::is_utf8 = sub { };
62 0         0 *utf8::valid = sub { 1 };
  0         0  
63             }
64             }
65              
66             # instead of Symbol.pm
67 0         0 BEGIN {
68             sub gensym () {
69 0 0   0 0 0 if ($] < 5.006) {
70 0         0 return \do { local *_ };
  0         0  
71             }
72             else {
73 0         0 return undef;
74             }
75             }
76              
77             sub qualify ($$) {
78 0     0 0 0 my($name) = @_;
79              
80 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
81 0         0 return $name;
82             }
83             elsif (Elatin8::index($name,'::') >= 0) {
84 0         0 return $name;
85             }
86             elsif (Elatin8::index($name,"'") >= 0) {
87 0         0 return $name;
88             }
89              
90             # special character, "^xyz"
91             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
92              
93             # RGS 2001-11-05 : translate leading ^X to control-char
94 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
95 0         0 return 'main::' . $name;
96             }
97              
98             # Global names
99             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
100 0         0 return 'main::' . $name;
101             }
102              
103             # or other
104             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
105 0         0 return 'main::' . $name;
106             }
107              
108             elsif (defined $_[1]) {
109 0         0 return $_[1] . '::' . $name;
110             }
111             else {
112 0         0 return (caller)[0] . '::' . $name;
113             }
114             }
115              
116             sub qualify_to_ref ($;$) {
117 0 0   0 0 0 if (defined $_[1]) {
118 206     206   1355 no strict qw(refs);
  206         349  
  206         12232  
119 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
120             }
121             else {
122 206     206   1140 no strict qw(refs);
  206     0   387  
  206         32067  
123 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
124             }
125             }
126             }
127              
128             # P.714 29.2.39. flock
129             # in Chapter 29: Functions
130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
131              
132             # P.863 flock
133             # in Chapter 27: Functions
134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
135              
136             sub LOCK_SH() {1}
137             sub LOCK_EX() {2}
138             sub LOCK_UN() {8}
139             sub LOCK_NB() {4}
140              
141             # instead of Carp.pm
142             sub carp;
143             sub croak;
144             sub cluck;
145             sub confess;
146              
147             # 6.18. Matching Multiple-Byte Characters
148             # in Chapter 6. Pattern Matching
149             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
150             # (and so on)
151              
152             # regexp of character
153             my $your_char = q{[\x00-\xFF]};
154 206     206   1345 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  206         402  
  206         10911  
155 206     206   1102 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  206         475  
  206         342386  
156              
157             #
158             # Latin-8 character range per length
159             #
160             my %range_tr = ();
161              
162             #
163             # Latin-8 case conversion
164             #
165             my %lc = ();
166             @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)} =
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             my %uc = ();
169             @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)} =
170             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);
171             my %fc = ();
172             @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)} =
173             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);
174              
175             if (0) {
176             }
177              
178             elsif (__PACKAGE__ =~ / \b Elatin8 \z/oxms) {
179             %range_tr = (
180             1 => [ [0x00..0xFF],
181             ],
182             );
183              
184             %lc = (%lc,
185             "\xA1" => "\xA2", # LATIN LETTER B WITH DOT ABOVE
186             "\xA4" => "\xA5", # LATIN LETTER C WITH DOT ABOVE
187             "\xA6" => "\xAB", # LATIN LETTER D WITH DOT ABOVE
188             "\xA8" => "\xB8", # LATIN LETTER W WITH GRAVE
189             "\xAA" => "\xBA", # LATIN LETTER W WITH ACUTE
190             "\xAC" => "\xBC", # LATIN LETTER Y WITH GRAVE
191             "\xAF" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
192             "\xB0" => "\xB1", # LATIN LETTER F WITH DOT ABOVE
193             "\xB2" => "\xB3", # LATIN LETTER G WITH DOT ABOVE
194             "\xB4" => "\xB5", # LATIN LETTER M WITH DOT ABOVE
195             "\xB7" => "\xB9", # LATIN LETTER P WITH DOT ABOVE
196             "\xBB" => "\xBF", # LATIN LETTER S WITH DOT ABOVE
197             "\xBD" => "\xBE", # LATIN LETTER W WITH DIAERESIS
198             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
199             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
200             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
201             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
202             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
203             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
204             "\xC6" => "\xE6", # LATIN LETTER AE
205             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
206             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
207             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
208             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
209             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
210             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
211             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
212             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
213             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
214             "\xD0" => "\xF0", # LATIN LETTER W WITH CIRCUMFLEX
215             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
216             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
217             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
218             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
219             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
220             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
221             "\xD7" => "\xF7", # LATIN LETTER T WITH DOT ABOVE
222             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
223             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
224             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
225             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
226             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
227             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
228             "\xDE" => "\xFE", # LATIN LETTER Y WITH CIRCUMFLEX
229             );
230              
231             %uc = (%uc,
232             "\xA2" => "\xA1", # LATIN LETTER B WITH DOT ABOVE
233             "\xA5" => "\xA4", # LATIN LETTER C WITH DOT ABOVE
234             "\xAB" => "\xA6", # LATIN LETTER D WITH DOT ABOVE
235             "\xB1" => "\xB0", # LATIN LETTER F WITH DOT ABOVE
236             "\xB3" => "\xB2", # LATIN LETTER G WITH DOT ABOVE
237             "\xB5" => "\xB4", # LATIN LETTER M WITH DOT ABOVE
238             "\xB8" => "\xA8", # LATIN LETTER W WITH GRAVE
239             "\xB9" => "\xB7", # LATIN LETTER P WITH DOT ABOVE
240             "\xBA" => "\xAA", # LATIN LETTER W WITH ACUTE
241             "\xBC" => "\xAC", # LATIN LETTER Y WITH GRAVE
242             "\xBE" => "\xBD", # LATIN LETTER W WITH DIAERESIS
243             "\xBF" => "\xBB", # LATIN LETTER S WITH DOT ABOVE
244             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
245             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
246             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
247             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
248             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
249             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
250             "\xE6" => "\xC6", # LATIN LETTER AE
251             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
252             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
253             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
254             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
255             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
256             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
257             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
258             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
259             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
260             "\xF0" => "\xD0", # LATIN LETTER W WITH CIRCUMFLEX
261             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
262             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
263             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
264             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
265             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
266             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
267             "\xF7" => "\xD7", # LATIN LETTER T WITH DOT ABOVE
268             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
269             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
270             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
271             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
272             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
273             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
274             "\xFE" => "\xDE", # LATIN LETTER Y WITH CIRCUMFLEX
275             "\xFF" => "\xAF", # LATIN LETTER Y WITH DIAERESIS
276             );
277              
278             %fc = (%fc,
279             "\xA1" => "\xA2", # LATIN CAPITAL LETTER B WITH DOT ABOVE --> LATIN SMALL LETTER B WITH DOT ABOVE
280             "\xA4" => "\xA5", # LATIN CAPITAL LETTER C WITH DOT ABOVE --> LATIN SMALL LETTER C WITH DOT ABOVE
281             "\xA6" => "\xAB", # LATIN CAPITAL LETTER D WITH DOT ABOVE --> LATIN SMALL LETTER D WITH DOT ABOVE
282             "\xA8" => "\xB8", # LATIN CAPITAL LETTER W WITH GRAVE --> LATIN SMALL LETTER W WITH GRAVE
283             "\xAA" => "\xBA", # LATIN CAPITAL LETTER W WITH ACUTE --> LATIN SMALL LETTER W WITH ACUTE
284             "\xAC" => "\xBC", # LATIN CAPITAL LETTER Y WITH GRAVE --> LATIN SMALL LETTER Y WITH GRAVE
285             "\xAF" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
286             "\xB0" => "\xB1", # LATIN CAPITAL LETTER F WITH DOT ABOVE --> LATIN SMALL LETTER F WITH DOT ABOVE
287             "\xB2" => "\xB3", # LATIN CAPITAL LETTER G WITH DOT ABOVE --> LATIN SMALL LETTER G WITH DOT ABOVE
288             "\xB4" => "\xB5", # LATIN CAPITAL LETTER M WITH DOT ABOVE --> LATIN SMALL LETTER M WITH DOT ABOVE
289             "\xB7" => "\xB9", # LATIN CAPITAL LETTER P WITH DOT ABOVE --> LATIN SMALL LETTER P WITH DOT ABOVE
290             "\xBB" => "\xBF", # LATIN CAPITAL LETTER S WITH DOT ABOVE --> LATIN SMALL LETTER S WITH DOT ABOVE
291             "\xBD" => "\xBE", # LATIN CAPITAL LETTER W WITH DIAERESIS --> LATIN SMALL LETTER W WITH DIAERESIS
292             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
293             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
294             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
295             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
296             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
297             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
298             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
299             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
300             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
301             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
302             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
303             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
304             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
305             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
306             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
307             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
308             "\xD0" => "\xF0", # LATIN CAPITAL LETTER W WITH CIRCUMFLEX --> LATIN SMALL LETTER W WITH CIRCUMFLEX
309             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
310             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
311             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
312             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
313             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
314             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
315             "\xD7" => "\xF7", # LATIN CAPITAL LETTER T WITH DOT ABOVE --> LATIN SMALL LETTER T WITH DOT ABOVE
316             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
317             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
318             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
319             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
320             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
321             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
322             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Y WITH CIRCUMFLEX --> LATIN SMALL LETTER Y WITH CIRCUMFLEX
323             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
324             );
325             }
326              
327             else {
328             croak "Don't know my package name '@{[__PACKAGE__]}'";
329             }
330              
331             #
332             # @ARGV wildcard globbing
333             #
334             sub import {
335              
336 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
337 0         0 my @argv = ();
338 0         0 for (@ARGV) {
339              
340             # has space
341 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
342 0 0       0 if (my @glob = Elatin8::glob(qq{"$_"})) {
343 0         0 push @argv, @glob;
344             }
345             else {
346 0         0 push @argv, $_;
347             }
348             }
349              
350             # has wildcard metachar
351             elsif (/\A (?:$q_char)*? [*?] /oxms) {
352 0 0       0 if (my @glob = Elatin8::glob($_)) {
353 0         0 push @argv, @glob;
354             }
355             else {
356 0         0 push @argv, $_;
357             }
358             }
359              
360             # no wildcard globbing
361             else {
362 0         0 push @argv, $_;
363             }
364             }
365 0         0 @ARGV = @argv;
366             }
367              
368 0         0 *Char::ord = \&Latin8::ord;
369 0         0 *Char::ord_ = \&Latin8::ord_;
370 0         0 *Char::reverse = \&Latin8::reverse;
371 0         0 *Char::getc = \&Latin8::getc;
372 0         0 *Char::length = \&Latin8::length;
373 0         0 *Char::substr = \&Latin8::substr;
374 0         0 *Char::index = \&Latin8::index;
375 0         0 *Char::rindex = \&Latin8::rindex;
376 0         0 *Char::eval = \&Latin8::eval;
377 0         0 *Char::escape = \&Latin8::escape;
378 0         0 *Char::escape_token = \&Latin8::escape_token;
379 0         0 *Char::escape_script = \&Latin8::escape_script;
380             }
381              
382             # P.230 Care with Prototypes
383             # in Chapter 6: Subroutines
384             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
385             #
386             # If you aren't careful, you can get yourself into trouble with prototypes.
387             # But if you are careful, you can do a lot of neat things with them. This is
388             # all very powerful, of course, and should only be used in moderation to make
389             # the world a better place.
390              
391             # P.332 Care with Prototypes
392             # in Chapter 7: Subroutines
393             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
394             #
395             # If you aren't careful, you can get yourself into trouble with prototypes.
396             # But if you are careful, you can do a lot of neat things with them. This is
397             # all very powerful, of course, and should only be used in moderation to make
398             # the world a better place.
399              
400             #
401             # Prototypes of subroutines
402             #
403       0     sub unimport {}
404             sub Elatin8::split(;$$$);
405             sub Elatin8::tr($$$$;$);
406             sub Elatin8::chop(@);
407             sub Elatin8::index($$;$);
408             sub Elatin8::rindex($$;$);
409             sub Elatin8::lcfirst(@);
410             sub Elatin8::lcfirst_();
411             sub Elatin8::lc(@);
412             sub Elatin8::lc_();
413             sub Elatin8::ucfirst(@);
414             sub Elatin8::ucfirst_();
415             sub Elatin8::uc(@);
416             sub Elatin8::uc_();
417             sub Elatin8::fc(@);
418             sub Elatin8::fc_();
419             sub Elatin8::ignorecase;
420             sub Elatin8::classic_character_class;
421             sub Elatin8::capture;
422             sub Elatin8::chr(;$);
423             sub Elatin8::chr_();
424             sub Elatin8::glob($);
425             sub Elatin8::glob_();
426              
427             sub Latin8::ord(;$);
428             sub Latin8::ord_();
429             sub Latin8::reverse(@);
430             sub Latin8::getc(;*@);
431             sub Latin8::length(;$);
432             sub Latin8::substr($$;$$);
433             sub Latin8::index($$;$);
434             sub Latin8::rindex($$;$);
435             sub Latin8::escape(;$);
436              
437             #
438             # Regexp work
439             #
440 206         16222 use vars qw(
441             $re_a
442             $re_t
443             $re_n
444             $re_r
445 206     206   1532 );
  206         434  
446              
447             #
448             # Character class
449             #
450 206         1697061 use vars qw(
451             $dot
452             $dot_s
453             $eD
454             $eS
455             $eW
456             $eH
457             $eV
458             $eR
459             $eN
460             $not_alnum
461             $not_alpha
462             $not_ascii
463             $not_blank
464             $not_cntrl
465             $not_digit
466             $not_graph
467             $not_lower
468             $not_lower_i
469             $not_print
470             $not_punct
471             $not_space
472             $not_upper
473             $not_upper_i
474             $not_word
475             $not_xdigit
476             $eb
477             $eB
478 206     206   1223 );
  206         357  
479              
480             ${Elatin8::dot} = qr{(?>[^\x0A])};
481             ${Elatin8::dot_s} = qr{(?>[\x00-\xFF])};
482             ${Elatin8::eD} = qr{(?>[^0-9])};
483              
484             # Vertical tabs are now whitespace
485             # \s in a regex now matches a vertical tab in all circumstances.
486             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
487             # ${Elatin8::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
488             # ${Elatin8::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
489             ${Elatin8::eS} = qr{(?>[^\s])};
490              
491             ${Elatin8::eW} = qr{(?>[^0-9A-Z_a-z])};
492             ${Elatin8::eH} = qr{(?>[^\x09\x20])};
493             ${Elatin8::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
494             ${Elatin8::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
495             ${Elatin8::eN} = qr{(?>[^\x0A])};
496             ${Elatin8::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
497             ${Elatin8::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
498             ${Elatin8::not_ascii} = qr{(?>[^\x00-\x7F])};
499             ${Elatin8::not_blank} = qr{(?>[^\x09\x20])};
500             ${Elatin8::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
501             ${Elatin8::not_digit} = qr{(?>[^\x30-\x39])};
502             ${Elatin8::not_graph} = qr{(?>[^\x21-\x7F])};
503             ${Elatin8::not_lower} = qr{(?>[^\x61-\x7A])};
504             ${Elatin8::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
505             # ${Elatin8::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
506             ${Elatin8::not_print} = qr{(?>[^\x20-\x7F])};
507             ${Elatin8::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
508             ${Elatin8::not_space} = qr{(?>[^\s\x0B])};
509             ${Elatin8::not_upper} = qr{(?>[^\x41-\x5A])};
510             ${Elatin8::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
511             # ${Elatin8::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
512             ${Elatin8::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
513             ${Elatin8::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
514             ${Elatin8::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))};
515             ${Elatin8::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]))};
516              
517             # avoid: Name "Elatin8::foo" used only once: possible typo at here.
518             ${Elatin8::dot} = ${Elatin8::dot};
519             ${Elatin8::dot_s} = ${Elatin8::dot_s};
520             ${Elatin8::eD} = ${Elatin8::eD};
521             ${Elatin8::eS} = ${Elatin8::eS};
522             ${Elatin8::eW} = ${Elatin8::eW};
523             ${Elatin8::eH} = ${Elatin8::eH};
524             ${Elatin8::eV} = ${Elatin8::eV};
525             ${Elatin8::eR} = ${Elatin8::eR};
526             ${Elatin8::eN} = ${Elatin8::eN};
527             ${Elatin8::not_alnum} = ${Elatin8::not_alnum};
528             ${Elatin8::not_alpha} = ${Elatin8::not_alpha};
529             ${Elatin8::not_ascii} = ${Elatin8::not_ascii};
530             ${Elatin8::not_blank} = ${Elatin8::not_blank};
531             ${Elatin8::not_cntrl} = ${Elatin8::not_cntrl};
532             ${Elatin8::not_digit} = ${Elatin8::not_digit};
533             ${Elatin8::not_graph} = ${Elatin8::not_graph};
534             ${Elatin8::not_lower} = ${Elatin8::not_lower};
535             ${Elatin8::not_lower_i} = ${Elatin8::not_lower_i};
536             ${Elatin8::not_print} = ${Elatin8::not_print};
537             ${Elatin8::not_punct} = ${Elatin8::not_punct};
538             ${Elatin8::not_space} = ${Elatin8::not_space};
539             ${Elatin8::not_upper} = ${Elatin8::not_upper};
540             ${Elatin8::not_upper_i} = ${Elatin8::not_upper_i};
541             ${Elatin8::not_word} = ${Elatin8::not_word};
542             ${Elatin8::not_xdigit} = ${Elatin8::not_xdigit};
543             ${Elatin8::eb} = ${Elatin8::eb};
544             ${Elatin8::eB} = ${Elatin8::eB};
545              
546             #
547             # Latin-8 split
548             #
549             sub Elatin8::split(;$$$) {
550              
551             # P.794 29.2.161. split
552             # in Chapter 29: Functions
553             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
554              
555             # P.951 split
556             # in Chapter 27: Functions
557             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
558              
559 0     0 0 0 my $pattern = $_[0];
560 0         0 my $string = $_[1];
561 0         0 my $limit = $_[2];
562              
563             # if $pattern is also omitted or is the literal space, " "
564 0 0       0 if (not defined $pattern) {
565 0         0 $pattern = ' ';
566             }
567              
568             # if $string is omitted, the function splits the $_ string
569 0 0       0 if (not defined $string) {
570 0 0       0 if (defined $_) {
571 0         0 $string = $_;
572             }
573             else {
574 0         0 $string = '';
575             }
576             }
577              
578 0         0 my @split = ();
579              
580             # when string is empty
581 0 0       0 if ($string eq '') {
    0          
582              
583             # resulting list value in list context
584 0 0       0 if (wantarray) {
585 0         0 return @split;
586             }
587              
588             # count of substrings in scalar context
589             else {
590 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
591 0         0 @_ = @split;
592 0         0 return scalar @_;
593             }
594             }
595              
596             # split's first argument is more consistently interpreted
597             #
598             # After some changes earlier in v5.17, split's behavior has been simplified:
599             # if the PATTERN argument evaluates to a string containing one space, it is
600             # treated the way that a literal string containing one space once was.
601             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
602              
603             # if $pattern is also omitted or is the literal space, " ", the function splits
604             # on whitespace, /\s+/, after skipping any leading whitespace
605             # (and so on)
606              
607             elsif ($pattern eq ' ') {
608 0 0       0 if (not defined $limit) {
609 0         0 return CORE::split(' ', $string);
610             }
611             else {
612 0         0 return CORE::split(' ', $string, $limit);
613             }
614             }
615              
616             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
617 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
618              
619             # a pattern capable of matching either the null string or something longer than the
620             # null string will split the value of $string into separate characters wherever it
621             # matches the null string between characters
622             # (and so on)
623              
624 0 0       0 if ('' =~ / \A $pattern \z /xms) {
625 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
626 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
627              
628             # P.1024 Appendix W.10 Multibyte Processing
629             # of ISBN 1-56592-224-7 CJKV Information Processing
630             # (and so on)
631              
632             # the //m modifier is assumed when you split on the pattern /^/
633             # (and so on)
634              
635 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
636             # V
637 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
638              
639             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
640             # is included in the resulting list, interspersed with the fields that are ordinarily returned
641             # (and so on)
642              
643 0         0 local $@;
644 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
645 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
646 0         0 push @split, CORE::eval('$' . $digit);
647             }
648             }
649             }
650              
651             else {
652 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
653              
654 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
655             # V
656 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
657 0         0 local $@;
658 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
659 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
660 0         0 push @split, CORE::eval('$' . $digit);
661             }
662             }
663             }
664             }
665              
666             elsif ($limit > 0) {
667 0 0       0 if ('' =~ / \A $pattern \z /xms) {
668 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
669 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
670              
671 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
672             # V
673 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
674 0         0 local $@;
675 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
676 0         0 push @split, CORE::eval('$' . $digit);
677             }
678             }
679             }
680             }
681             else {
682 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
683 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
684              
685 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
686             # V
687 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
688 0         0 local $@;
689 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
690 0         0 push @split, CORE::eval('$' . $digit);
691             }
692             }
693             }
694             }
695             }
696              
697 0 0       0 if (CORE::length($string) > 0) {
698 0         0 push @split, $string;
699             }
700              
701             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
702 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
703 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
704 0         0 pop @split;
705             }
706             }
707              
708             # resulting list value in list context
709 0 0       0 if (wantarray) {
710 0         0 return @split;
711             }
712              
713             # count of substrings in scalar context
714             else {
715 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
716 0         0 @_ = @split;
717 0         0 return scalar @_;
718             }
719             }
720              
721             #
722             # get last subexpression offsets
723             #
724             sub _last_subexpression_offsets {
725 0     0   0 my $pattern = $_[0];
726              
727             # remove comment
728 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
729              
730 0         0 my $modifier = '';
731 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
732 0         0 $modifier = $1;
733 0         0 $modifier =~ s/-[A-Za-z]*//;
734             }
735              
736             # with /x modifier
737 0         0 my @char = ();
738 0 0       0 if ($modifier =~ /x/oxms) {
739 0         0 @char = $pattern =~ /\G((?>
740             [^\\\#\[\(] |
741             \\ $q_char |
742             \# (?>[^\n]*) $ |
743             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
744             \(\? |
745             $q_char
746             ))/oxmsg;
747             }
748              
749             # without /x modifier
750             else {
751 0         0 @char = $pattern =~ /\G((?>
752             [^\\\[\(] |
753             \\ $q_char |
754             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
755             \(\? |
756             $q_char
757             ))/oxmsg;
758             }
759              
760 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
761             }
762              
763             #
764             # Latin-8 transliteration (tr///)
765             #
766             sub Elatin8::tr($$$$;$) {
767              
768 0     0 0 0 my $bind_operator = $_[1];
769 0         0 my $searchlist = $_[2];
770 0         0 my $replacementlist = $_[3];
771 0   0     0 my $modifier = $_[4] || '';
772              
773 0 0       0 if ($modifier =~ /r/oxms) {
774 0 0       0 if ($bind_operator =~ / !~ /oxms) {
775 0         0 croak "Using !~ with tr///r doesn't make sense";
776             }
777             }
778              
779 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
780 0         0 my @searchlist = _charlist_tr($searchlist);
781 0         0 my @replacementlist = _charlist_tr($replacementlist);
782              
783 0         0 my %tr = ();
784 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
785 0 0       0 if (not exists $tr{$searchlist[$i]}) {
786 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
787 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
788             }
789             elsif ($modifier =~ /d/oxms) {
790 0         0 $tr{$searchlist[$i]} = '';
791             }
792             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
793 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
794             }
795             else {
796 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
797             }
798             }
799             }
800              
801 0         0 my $tr = 0;
802 0         0 my $replaced = '';
803 0 0       0 if ($modifier =~ /c/oxms) {
804 0         0 while (defined(my $char = shift @char)) {
805 0 0       0 if (not exists $tr{$char}) {
806 0 0       0 if (defined $replacementlist[-1]) {
807 0         0 $replaced .= $replacementlist[-1];
808             }
809 0         0 $tr++;
810 0 0       0 if ($modifier =~ /s/oxms) {
811 0   0     0 while (@char and (not exists $tr{$char[0]})) {
812 0         0 shift @char;
813 0         0 $tr++;
814             }
815             }
816             }
817             else {
818 0         0 $replaced .= $char;
819             }
820             }
821             }
822             else {
823 0         0 while (defined(my $char = shift @char)) {
824 0 0       0 if (exists $tr{$char}) {
825 0         0 $replaced .= $tr{$char};
826 0         0 $tr++;
827 0 0       0 if ($modifier =~ /s/oxms) {
828 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
829 0         0 shift @char;
830 0         0 $tr++;
831             }
832             }
833             }
834             else {
835 0         0 $replaced .= $char;
836             }
837             }
838             }
839              
840 0 0       0 if ($modifier =~ /r/oxms) {
841 0         0 return $replaced;
842             }
843             else {
844 0         0 $_[0] = $replaced;
845 0 0       0 if ($bind_operator =~ / !~ /oxms) {
846 0         0 return not $tr;
847             }
848             else {
849 0         0 return $tr;
850             }
851             }
852             }
853              
854             #
855             # Latin-8 chop
856             #
857             sub Elatin8::chop(@) {
858              
859 0     0 0 0 my $chop;
860 0 0       0 if (@_ == 0) {
861 0         0 my @char = /\G (?>$q_char) /oxmsg;
862 0         0 $chop = pop @char;
863 0         0 $_ = join '', @char;
864             }
865             else {
866 0         0 for (@_) {
867 0         0 my @char = /\G (?>$q_char) /oxmsg;
868 0         0 $chop = pop @char;
869 0         0 $_ = join '', @char;
870             }
871             }
872 0         0 return $chop;
873             }
874              
875             #
876             # Latin-8 index by octet
877             #
878             sub Elatin8::index($$;$) {
879              
880 0     0 1 0 my($str,$substr,$position) = @_;
881 0   0     0 $position ||= 0;
882 0         0 my $pos = 0;
883              
884 0         0 while ($pos < CORE::length($str)) {
885 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
886 0 0       0 if ($pos >= $position) {
887 0         0 return $pos;
888             }
889             }
890 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
891 0         0 $pos += CORE::length($1);
892             }
893             else {
894 0         0 $pos += 1;
895             }
896             }
897 0         0 return -1;
898             }
899              
900             #
901             # Latin-8 reverse index
902             #
903             sub Elatin8::rindex($$;$) {
904              
905 0     0 0 0 my($str,$substr,$position) = @_;
906 0   0     0 $position ||= CORE::length($str) - 1;
907 0         0 my $pos = 0;
908 0         0 my $rindex = -1;
909              
910 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
911 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
912 0         0 $rindex = $pos;
913             }
914 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
915 0         0 $pos += CORE::length($1);
916             }
917             else {
918 0         0 $pos += 1;
919             }
920             }
921 0         0 return $rindex;
922             }
923              
924             #
925             # Latin-8 lower case first with parameter
926             #
927             sub Elatin8::lcfirst(@) {
928 0 0   0 0 0 if (@_) {
929 0         0 my $s = shift @_;
930 0 0 0     0 if (@_ and wantarray) {
931 0         0 return Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
932             }
933             else {
934 0         0 return Elatin8::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
935             }
936             }
937             else {
938 0         0 return Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
939             }
940             }
941              
942             #
943             # Latin-8 lower case first without parameter
944             #
945             sub Elatin8::lcfirst_() {
946 0     0 0 0 return Elatin8::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
947             }
948              
949             #
950             # Latin-8 lower case with parameter
951             #
952             sub Elatin8::lc(@) {
953 0 0   0 0 0 if (@_) {
954 0         0 my $s = shift @_;
955 0 0 0     0 if (@_ and wantarray) {
956 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
957             }
958             else {
959 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
960             }
961             }
962             else {
963 0         0 return Elatin8::lc_();
964             }
965             }
966              
967             #
968             # Latin-8 lower case without parameter
969             #
970             sub Elatin8::lc_() {
971 0     0 0 0 my $s = $_;
972 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
973             }
974              
975             #
976             # Latin-8 upper case first with parameter
977             #
978             sub Elatin8::ucfirst(@) {
979 0 0   0 0 0 if (@_) {
980 0         0 my $s = shift @_;
981 0 0 0     0 if (@_ and wantarray) {
982 0         0 return Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
983             }
984             else {
985 0         0 return Elatin8::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
986             }
987             }
988             else {
989 0         0 return Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
990             }
991             }
992              
993             #
994             # Latin-8 upper case first without parameter
995             #
996             sub Elatin8::ucfirst_() {
997 0     0 0 0 return Elatin8::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
998             }
999              
1000             #
1001             # Latin-8 upper case with parameter
1002             #
1003             sub Elatin8::uc(@) {
1004 0 50   174 0 0 if (@_) {
1005 174         280 my $s = shift @_;
1006 174 50 33     200 if (@_ and wantarray) {
1007 174 0       303 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1008             }
1009             else {
1010 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         497  
1011             }
1012             }
1013             else {
1014 174         587 return Elatin8::uc_();
1015             }
1016             }
1017              
1018             #
1019             # Latin-8 upper case without parameter
1020             #
1021             sub Elatin8::uc_() {
1022 0     0 0 0 my $s = $_;
1023 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1024             }
1025              
1026             #
1027             # Latin-8 fold case with parameter
1028             #
1029             sub Elatin8::fc(@) {
1030 0 50   197 0 0 if (@_) {
1031 197         257 my $s = shift @_;
1032 197 50 33     221 if (@_ and wantarray) {
1033 197 0       347 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1034             }
1035             else {
1036 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         483  
1037             }
1038             }
1039             else {
1040 197         1022 return Elatin8::fc_();
1041             }
1042             }
1043              
1044             #
1045             # Latin-8 fold case without parameter
1046             #
1047             sub Elatin8::fc_() {
1048 0     0 0 0 my $s = $_;
1049 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1050             }
1051              
1052             #
1053             # Latin-8 regexp capture
1054             #
1055             {
1056             sub Elatin8::capture {
1057 0     0 1 0 return $_[0];
1058             }
1059             }
1060              
1061             #
1062             # Latin-8 regexp ignore case modifier
1063             #
1064             sub Elatin8::ignorecase {
1065              
1066 0     0 0 0 my @string = @_;
1067 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1068              
1069             # ignore case of $scalar or @array
1070 0         0 for my $string (@string) {
1071              
1072             # split regexp
1073 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1074              
1075             # unescape character
1076 0         0 for (my $i=0; $i <= $#char; $i++) {
1077 0 0       0 next if not defined $char[$i];
1078              
1079             # open character class [...]
1080 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1081 0         0 my $left = $i;
1082              
1083             # [] make die "unmatched [] in regexp ...\n"
1084              
1085 0 0       0 if ($char[$i+1] eq ']') {
1086 0         0 $i++;
1087             }
1088              
1089 0         0 while (1) {
1090 0 0       0 if (++$i > $#char) {
1091 0         0 croak "Unmatched [] in regexp";
1092             }
1093 0 0       0 if ($char[$i] eq ']') {
1094 0         0 my $right = $i;
1095 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1096              
1097             # escape character
1098 0         0 for my $char (@charlist) {
1099 0 0       0 if (0) {
1100             }
1101              
1102 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1103 0         0 $char = '\\' . $char;
1104             }
1105             }
1106              
1107             # [...]
1108 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1109              
1110 0         0 $i = $left;
1111 0         0 last;
1112             }
1113             }
1114             }
1115              
1116             # open character class [^...]
1117             elsif ($char[$i] eq '[^') {
1118 0         0 my $left = $i;
1119              
1120             # [^] make die "unmatched [] in regexp ...\n"
1121              
1122 0 0       0 if ($char[$i+1] eq ']') {
1123 0         0 $i++;
1124             }
1125              
1126 0         0 while (1) {
1127 0 0       0 if (++$i > $#char) {
1128 0         0 croak "Unmatched [] in regexp";
1129             }
1130 0 0       0 if ($char[$i] eq ']') {
1131 0         0 my $right = $i;
1132 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1133              
1134             # escape character
1135 0         0 for my $char (@charlist) {
1136 0 0       0 if (0) {
1137             }
1138              
1139 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1140 0         0 $char = '\\' . $char;
1141             }
1142             }
1143              
1144             # [^...]
1145 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1146              
1147 0         0 $i = $left;
1148 0         0 last;
1149             }
1150             }
1151             }
1152              
1153             # rewrite classic character class or escape character
1154             elsif (my $char = classic_character_class($char[$i])) {
1155 0         0 $char[$i] = $char;
1156             }
1157              
1158             # with /i modifier
1159             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1160 0         0 my $uc = Elatin8::uc($char[$i]);
1161 0         0 my $fc = Elatin8::fc($char[$i]);
1162 0 0       0 if ($uc ne $fc) {
1163 0 0       0 if (CORE::length($fc) == 1) {
1164 0         0 $char[$i] = '[' . $uc . $fc . ']';
1165             }
1166             else {
1167 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1168             }
1169             }
1170             }
1171             }
1172              
1173             # characterize
1174 0         0 for (my $i=0; $i <= $#char; $i++) {
1175 0 0       0 next if not defined $char[$i];
1176              
1177 0 0       0 if (0) {
1178             }
1179              
1180             # quote character before ? + * {
1181 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1182 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1183 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1184             }
1185             }
1186             }
1187              
1188 0         0 $string = join '', @char;
1189             }
1190              
1191             # make regexp string
1192 0         0 return @string;
1193             }
1194              
1195             #
1196             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1197             #
1198             sub Elatin8::classic_character_class {
1199 0     1867 0 0 my($char) = @_;
1200              
1201             return {
1202             '\D' => '${Elatin8::eD}',
1203             '\S' => '${Elatin8::eS}',
1204             '\W' => '${Elatin8::eW}',
1205             '\d' => '[0-9]',
1206              
1207             # Before Perl 5.6, \s only matched the five whitespace characters
1208             # tab, newline, form-feed, carriage return, and the space character
1209             # itself, which, taken together, is the character class [\t\n\f\r ].
1210              
1211             # Vertical tabs are now whitespace
1212             # \s in a regex now matches a vertical tab in all circumstances.
1213             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1214             # \t \n \v \f \r space
1215             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1216             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1217             '\s' => '\s',
1218              
1219             '\w' => '[0-9A-Z_a-z]',
1220             '\C' => '[\x00-\xFF]',
1221             '\X' => 'X',
1222              
1223             # \h \v \H \V
1224              
1225             # P.114 Character Class Shortcuts
1226             # in Chapter 7: In the World of Regular Expressions
1227             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1228              
1229             # P.357 13.2.3 Whitespace
1230             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1231             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1232             #
1233             # 0x00009 CHARACTER TABULATION h s
1234             # 0x0000a LINE FEED (LF) vs
1235             # 0x0000b LINE TABULATION v
1236             # 0x0000c FORM FEED (FF) vs
1237             # 0x0000d CARRIAGE RETURN (CR) vs
1238             # 0x00020 SPACE h s
1239              
1240             # P.196 Table 5-9. Alphanumeric regex metasymbols
1241             # in Chapter 5. Pattern Matching
1242             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1243              
1244             # (and so on)
1245              
1246             '\H' => '${Elatin8::eH}',
1247             '\V' => '${Elatin8::eV}',
1248             '\h' => '[\x09\x20]',
1249             '\v' => '[\x0A\x0B\x0C\x0D]',
1250             '\R' => '${Elatin8::eR}',
1251              
1252             # \N
1253             #
1254             # http://perldoc.perl.org/perlre.html
1255             # Character Classes and other Special Escapes
1256             # Any character but \n (experimental). Not affected by /s modifier
1257              
1258             '\N' => '${Elatin8::eN}',
1259              
1260             # \b \B
1261              
1262             # P.180 Boundaries: The \b and \B Assertions
1263             # in Chapter 5: Pattern Matching
1264             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1265              
1266             # P.219 Boundaries: The \b and \B Assertions
1267             # in Chapter 5: Pattern Matching
1268             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1269              
1270             # \b really means (?:(?<=\w)(?!\w)|(?
1271             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1272             '\b' => '${Elatin8::eb}',
1273              
1274             # \B really means (?:(?<=\w)(?=\w)|(?
1275             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1276             '\B' => '${Elatin8::eB}',
1277              
1278 1867   100     11545 }->{$char} || '';
1279             }
1280              
1281             #
1282             # prepare Latin-8 characters per length
1283             #
1284              
1285             # 1 octet characters
1286             my @chars1 = ();
1287             sub chars1 {
1288 1867 0   0 0 62203 if (@chars1) {
1289 0         0 return @chars1;
1290             }
1291 0 0       0 if (exists $range_tr{1}) {
1292 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1293 0         0 while (my @range = splice(@ranges,0,1)) {
1294 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1295 0         0 push @chars1, pack 'C', $oct0;
1296             }
1297             }
1298             }
1299 0         0 return @chars1;
1300             }
1301              
1302             # 2 octets characters
1303             my @chars2 = ();
1304             sub chars2 {
1305 0 0   0 0 0 if (@chars2) {
1306 0         0 return @chars2;
1307             }
1308 0 0       0 if (exists $range_tr{2}) {
1309 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1310 0         0 while (my @range = splice(@ranges,0,2)) {
1311 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1312 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1313 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1314             }
1315             }
1316             }
1317             }
1318 0         0 return @chars2;
1319             }
1320              
1321             # 3 octets characters
1322             my @chars3 = ();
1323             sub chars3 {
1324 0 0   0 0 0 if (@chars3) {
1325 0         0 return @chars3;
1326             }
1327 0 0       0 if (exists $range_tr{3}) {
1328 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1329 0         0 while (my @range = splice(@ranges,0,3)) {
1330 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1331 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1332 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1333 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1334             }
1335             }
1336             }
1337             }
1338             }
1339 0         0 return @chars3;
1340             }
1341              
1342             # 4 octets characters
1343             my @chars4 = ();
1344             sub chars4 {
1345 0 0   0 0 0 if (@chars4) {
1346 0         0 return @chars4;
1347             }
1348 0 0       0 if (exists $range_tr{4}) {
1349 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1350 0         0 while (my @range = splice(@ranges,0,4)) {
1351 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1352 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1353 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1354 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1355 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1356             }
1357             }
1358             }
1359             }
1360             }
1361             }
1362 0         0 return @chars4;
1363             }
1364              
1365             #
1366             # Latin-8 open character list for tr
1367             #
1368             sub _charlist_tr {
1369              
1370 0     0   0 local $_ = shift @_;
1371              
1372             # unescape character
1373 0         0 my @char = ();
1374 0         0 while (not /\G \z/oxmsgc) {
1375 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1376 0         0 push @char, '\-';
1377             }
1378             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1379 0         0 push @char, CORE::chr(oct $1);
1380             }
1381             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1382 0         0 push @char, CORE::chr(hex $1);
1383             }
1384             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1385 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1386             }
1387             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1388             push @char, {
1389             '\0' => "\0",
1390             '\n' => "\n",
1391             '\r' => "\r",
1392             '\t' => "\t",
1393             '\f' => "\f",
1394             '\b' => "\x08", # \b means backspace in character class
1395             '\a' => "\a",
1396             '\e' => "\e",
1397 0         0 }->{$1};
1398             }
1399             elsif (/\G \\ ($q_char) /oxmsgc) {
1400 0         0 push @char, $1;
1401             }
1402             elsif (/\G ($q_char) /oxmsgc) {
1403 0         0 push @char, $1;
1404             }
1405             }
1406              
1407             # join separated multiple-octet
1408 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1409              
1410             # unescape '-'
1411 0         0 my @i = ();
1412 0         0 for my $i (0 .. $#char) {
1413 0 0       0 if ($char[$i] eq '\-') {
    0          
1414 0         0 $char[$i] = '-';
1415             }
1416             elsif ($char[$i] eq '-') {
1417 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1418 0         0 push @i, $i;
1419             }
1420             }
1421             }
1422              
1423             # open character list (reverse for splice)
1424 0         0 for my $i (CORE::reverse @i) {
1425 0         0 my @range = ();
1426              
1427             # range error
1428 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1429 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1430             }
1431              
1432             # range of multiple-octet code
1433 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1434 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1435 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1436             }
1437             elsif (CORE::length($char[$i+1]) == 2) {
1438 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1439 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1440             }
1441             elsif (CORE::length($char[$i+1]) == 3) {
1442 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1443 0         0 push @range, chars2();
1444 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1445             }
1446             elsif (CORE::length($char[$i+1]) == 4) {
1447 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1448 0         0 push @range, chars2();
1449 0         0 push @range, chars3();
1450 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1451             }
1452             else {
1453 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1454             }
1455             }
1456             elsif (CORE::length($char[$i-1]) == 2) {
1457 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1458 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1459             }
1460             elsif (CORE::length($char[$i+1]) == 3) {
1461 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1462 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1463             }
1464             elsif (CORE::length($char[$i+1]) == 4) {
1465 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1466 0         0 push @range, chars3();
1467 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1468             }
1469             else {
1470 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1471             }
1472             }
1473             elsif (CORE::length($char[$i-1]) == 3) {
1474 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1475 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1476             }
1477             elsif (CORE::length($char[$i+1]) == 4) {
1478 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1479 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1480             }
1481             else {
1482 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1483             }
1484             }
1485             elsif (CORE::length($char[$i-1]) == 4) {
1486 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1487 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1488             }
1489             else {
1490 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1491             }
1492             }
1493             else {
1494 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1495             }
1496              
1497 0         0 splice @char, $i-1, 3, @range;
1498             }
1499              
1500 0         0 return @char;
1501             }
1502              
1503             #
1504             # Latin-8 open character class
1505             #
1506             sub _cc {
1507 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1508 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1509             }
1510             elsif (scalar(@_) == 1) {
1511 0         0 return sprintf('\x%02X',$_[0]);
1512             }
1513             elsif (scalar(@_) == 2) {
1514 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1515 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1516             }
1517             elsif ($_[0] == $_[1]) {
1518 0         0 return sprintf('\x%02X',$_[0]);
1519             }
1520             elsif (($_[0]+1) == $_[1]) {
1521 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1522             }
1523             else {
1524 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1525             }
1526             }
1527             else {
1528 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1529             }
1530             }
1531              
1532             #
1533             # Latin-8 octet range
1534             #
1535             sub _octets {
1536 0     182   0 my $length = shift @_;
1537              
1538 182 50       282 if ($length == 1) {
1539 182         353 my($a1) = unpack 'C', $_[0];
1540 182         444 my($z1) = unpack 'C', $_[1];
1541              
1542 182 50       299 if ($a1 > $z1) {
1543 182         333 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1544             }
1545              
1546 0 50       0 if ($a1 == $z1) {
    50          
1547 182         378 return sprintf('\x%02X',$a1);
1548             }
1549             elsif (($a1+1) == $z1) {
1550 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1551             }
1552             else {
1553 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1554             }
1555             }
1556             else {
1557 182         1078 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1558             }
1559             }
1560              
1561             #
1562             # Latin-8 range regexp
1563             #
1564             sub _range_regexp {
1565 0     182   0 my($length,$first,$last) = @_;
1566              
1567 182         355 my @range_regexp = ();
1568 182 50       224 if (not exists $range_tr{$length}) {
1569 182         409 return @range_regexp;
1570             }
1571              
1572 0         0 my @ranges = @{ $range_tr{$length} };
  182         250  
1573 182         351 while (my @range = splice(@ranges,0,$length)) {
1574 182         536 my $min = '';
1575 182         255 my $max = '';
1576 182         227 for (my $i=0; $i < $length; $i++) {
1577 182         424 $min .= pack 'C', $range[$i][0];
1578 182         566 $max .= pack 'C', $range[$i][-1];
1579             }
1580              
1581             # min___max
1582             # FIRST_____________LAST
1583             # (nothing)
1584              
1585 182 50 33     422 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1586             }
1587              
1588             # **********
1589             # min_________max
1590             # FIRST_____________LAST
1591             # **********
1592              
1593             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1594 182         1694 push @range_regexp, _octets($length,$first,$max,$min,$max);
1595             }
1596              
1597             # **********************
1598             # min________________max
1599             # FIRST_____________LAST
1600             # **********************
1601              
1602             elsif (($min eq $first) and ($max eq $last)) {
1603 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1604             }
1605              
1606             # *********
1607             # min___max
1608             # FIRST_____________LAST
1609             # *********
1610              
1611             elsif (($first le $min) and ($max le $last)) {
1612 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1613             }
1614              
1615             # **********************
1616             # min__________________________max
1617             # FIRST_____________LAST
1618             # **********************
1619              
1620             elsif (($min le $first) and ($last le $max)) {
1621 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1622             }
1623              
1624             # *********
1625             # min________max
1626             # FIRST_____________LAST
1627             # *********
1628              
1629             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1630 182         412 push @range_regexp, _octets($length,$min,$last,$min,$max);
1631             }
1632              
1633             # min___max
1634             # FIRST_____________LAST
1635             # (nothing)
1636              
1637             elsif ($last lt $min) {
1638             }
1639              
1640             else {
1641 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1642             }
1643             }
1644              
1645 0         0 return @range_regexp;
1646             }
1647              
1648             #
1649             # Latin-8 open character list for qr and not qr
1650             #
1651             sub _charlist {
1652              
1653 182     358   381 my $modifier = pop @_;
1654 358         687 my @char = @_;
1655              
1656 358 100       730 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1657              
1658             # unescape character
1659 358         775 for (my $i=0; $i <= $#char; $i++) {
1660              
1661             # escape - to ...
1662 358 100 100     1164 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1663 1125 100 100     7224 if ((0 < $i) and ($i < $#char)) {
1664 206         681 $char[$i] = '...';
1665             }
1666             }
1667              
1668             # octal escape sequence
1669             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1670 182         382 $char[$i] = octchr($1);
1671             }
1672              
1673             # hexadecimal escape sequence
1674             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1675 0         0 $char[$i] = hexchr($1);
1676             }
1677              
1678             # \b{...} --> b\{...}
1679             # \B{...} --> B\{...}
1680             # \N{CHARNAME} --> N\{CHARNAME}
1681             # \p{PROPERTY} --> p\{PROPERTY}
1682             # \P{PROPERTY} --> P\{PROPERTY}
1683             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1684 0         0 $char[$i] = $1 . '\\' . $2;
1685             }
1686              
1687             # \p, \P, \X --> p, P, X
1688             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1689 0         0 $char[$i] = $1;
1690             }
1691              
1692             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1693 0         0 $char[$i] = CORE::chr oct $1;
1694             }
1695             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1696 0         0 $char[$i] = CORE::chr hex $1;
1697             }
1698             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1699 22         90 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1700             }
1701             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1702             $char[$i] = {
1703             '\0' => "\0",
1704             '\n' => "\n",
1705             '\r' => "\r",
1706             '\t' => "\t",
1707             '\f' => "\f",
1708             '\b' => "\x08", # \b means backspace in character class
1709             '\a' => "\a",
1710             '\e' => "\e",
1711             '\d' => '[0-9]',
1712              
1713             # Vertical tabs are now whitespace
1714             # \s in a regex now matches a vertical tab in all circumstances.
1715             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1716             # \t \n \v \f \r space
1717             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1718             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1719             '\s' => '\s',
1720              
1721             '\w' => '[0-9A-Z_a-z]',
1722             '\D' => '${Elatin8::eD}',
1723             '\S' => '${Elatin8::eS}',
1724             '\W' => '${Elatin8::eW}',
1725              
1726             '\H' => '${Elatin8::eH}',
1727             '\V' => '${Elatin8::eV}',
1728             '\h' => '[\x09\x20]',
1729             '\v' => '[\x0A\x0B\x0C\x0D]',
1730             '\R' => '${Elatin8::eR}',
1731              
1732 0         0 }->{$1};
1733             }
1734              
1735             # POSIX-style character classes
1736             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1737             $char[$i] = {
1738              
1739             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1740             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1741             '[:^lower:]' => '${Elatin8::not_lower_i}',
1742             '[:^upper:]' => '${Elatin8::not_upper_i}',
1743              
1744 25         530 }->{$1};
1745             }
1746             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1747             $char[$i] = {
1748              
1749             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1750             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1751             '[:ascii:]' => '[\x00-\x7F]',
1752             '[:blank:]' => '[\x09\x20]',
1753             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1754             '[:digit:]' => '[\x30-\x39]',
1755             '[:graph:]' => '[\x21-\x7F]',
1756             '[:lower:]' => '[\x61-\x7A]',
1757             '[:print:]' => '[\x20-\x7F]',
1758             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1759              
1760             # P.174 POSIX-Style Character Classes
1761             # in Chapter 5: Pattern Matching
1762             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1763              
1764             # P.311 11.2.4 Character Classes and other Special Escapes
1765             # in Chapter 11: perlre: Perl regular expressions
1766             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1767              
1768             # P.210 POSIX-Style Character Classes
1769             # in Chapter 5: Pattern Matching
1770             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1771              
1772             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1773              
1774             '[:upper:]' => '[\x41-\x5A]',
1775             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1776             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1777             '[:^alnum:]' => '${Elatin8::not_alnum}',
1778             '[:^alpha:]' => '${Elatin8::not_alpha}',
1779             '[:^ascii:]' => '${Elatin8::not_ascii}',
1780             '[:^blank:]' => '${Elatin8::not_blank}',
1781             '[:^cntrl:]' => '${Elatin8::not_cntrl}',
1782             '[:^digit:]' => '${Elatin8::not_digit}',
1783             '[:^graph:]' => '${Elatin8::not_graph}',
1784             '[:^lower:]' => '${Elatin8::not_lower}',
1785             '[:^print:]' => '${Elatin8::not_print}',
1786             '[:^punct:]' => '${Elatin8::not_punct}',
1787             '[:^space:]' => '${Elatin8::not_space}',
1788             '[:^upper:]' => '${Elatin8::not_upper}',
1789             '[:^word:]' => '${Elatin8::not_word}',
1790             '[:^xdigit:]' => '${Elatin8::not_xdigit}',
1791              
1792 8         53 }->{$1};
1793             }
1794             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1795 70         1135 $char[$i] = $1;
1796             }
1797             }
1798              
1799             # open character list
1800 7         30 my @singleoctet = ();
1801 358         583 my @multipleoctet = ();
1802 358         443 for (my $i=0; $i <= $#char; ) {
1803              
1804             # escaped -
1805 358 100 100     749 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1806 943         3627 $i += 1;
1807 182         242 next;
1808             }
1809              
1810             # make range regexp
1811             elsif ($char[$i] eq '...') {
1812              
1813             # range error
1814 182 50       331 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1815 182         575 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1816             }
1817             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1818 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1819 182         452 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1820             }
1821             }
1822              
1823             # make range regexp per length
1824 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1825 182         471 my @regexp = ();
1826              
1827             # is first and last
1828 182 50 33     237 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1829 182         612 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1830             }
1831              
1832             # is first
1833             elsif ($length == CORE::length($char[$i-1])) {
1834 182         466 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1835             }
1836              
1837             # is inside in first and last
1838             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1839 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1840             }
1841              
1842             # is last
1843             elsif ($length == CORE::length($char[$i+1])) {
1844 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1845             }
1846              
1847             else {
1848 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1849             }
1850              
1851 0 50       0 if ($length == 1) {
1852 182         343 push @singleoctet, @regexp;
1853             }
1854             else {
1855 182         370 push @multipleoctet, @regexp;
1856             }
1857             }
1858              
1859 0         0 $i += 2;
1860             }
1861              
1862             # with /i modifier
1863             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1864 182 100       363 if ($modifier =~ /i/oxms) {
1865 493         687 my $uc = Elatin8::uc($char[$i]);
1866 24         41 my $fc = Elatin8::fc($char[$i]);
1867 24 100       43 if ($uc ne $fc) {
1868 24 50       42 if (CORE::length($fc) == 1) {
1869 12         34 push @singleoctet, $uc, $fc;
1870             }
1871             else {
1872 12         23 push @singleoctet, $uc;
1873 0         0 push @multipleoctet, $fc;
1874             }
1875             }
1876             else {
1877 0         0 push @singleoctet, $char[$i];
1878             }
1879             }
1880             else {
1881 12         22 push @singleoctet, $char[$i];
1882             }
1883 469         661 $i += 1;
1884             }
1885              
1886             # single character of single octet code
1887             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1888 493         778 push @singleoctet, "\t", "\x20";
1889 0         0 $i += 1;
1890             }
1891             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1892 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1893 0         0 $i += 1;
1894             }
1895             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1896 0         0 push @singleoctet, $char[$i];
1897 2         7 $i += 1;
1898             }
1899              
1900             # single character of multiple-octet code
1901             else {
1902 2         7 push @multipleoctet, $char[$i];
1903 84         159 $i += 1;
1904             }
1905             }
1906              
1907             # quote metachar
1908 84         145 for (@singleoctet) {
1909 358 50       648 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1910 689         2734 $_ = '-';
1911             }
1912             elsif (/\A \n \z/oxms) {
1913 0         0 $_ = '\n';
1914             }
1915             elsif (/\A \r \z/oxms) {
1916 8         24 $_ = '\r';
1917             }
1918             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1919 8         18 $_ = sprintf('\x%02X', CORE::ord $1);
1920             }
1921             elsif (/\A [\x00-\xFF] \z/oxms) {
1922 60         186 $_ = quotemeta $_;
1923             }
1924             }
1925              
1926             # return character list
1927 429         634 return \@singleoctet, \@multipleoctet;
1928             }
1929              
1930             #
1931             # Latin-8 octal escape sequence
1932             #
1933             sub octchr {
1934 358     5 0 1116 my($octdigit) = @_;
1935              
1936 5         13 my @binary = ();
1937 5         8 for my $octal (split(//,$octdigit)) {
1938             push @binary, {
1939             '0' => '000',
1940             '1' => '001',
1941             '2' => '010',
1942             '3' => '011',
1943             '4' => '100',
1944             '5' => '101',
1945             '6' => '110',
1946             '7' => '111',
1947 5         19 }->{$octal};
1948             }
1949 50         171 my $binary = join '', @binary;
1950              
1951             my $octchr = {
1952             # 1234567
1953             1 => pack('B*', "0000000$binary"),
1954             2 => pack('B*', "000000$binary"),
1955             3 => pack('B*', "00000$binary"),
1956             4 => pack('B*', "0000$binary"),
1957             5 => pack('B*', "000$binary"),
1958             6 => pack('B*', "00$binary"),
1959             7 => pack('B*', "0$binary"),
1960             0 => pack('B*', "$binary"),
1961              
1962 5         15 }->{CORE::length($binary) % 8};
1963              
1964 5         51 return $octchr;
1965             }
1966              
1967             #
1968             # Latin-8 hexadecimal escape sequence
1969             #
1970             sub hexchr {
1971 5     5 0 19 my($hexdigit) = @_;
1972              
1973             my $hexchr = {
1974             1 => pack('H*', "0$hexdigit"),
1975             0 => pack('H*', "$hexdigit"),
1976              
1977 5         21 }->{CORE::length($_[0]) % 2};
1978              
1979 5         41 return $hexchr;
1980             }
1981              
1982             #
1983             # Latin-8 open character list for qr
1984             #
1985             sub charlist_qr {
1986              
1987 5     314 0 19 my $modifier = pop @_;
1988 314         545 my @char = @_;
1989              
1990 314         749 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1991 314         826 my @singleoctet = @$singleoctet;
1992 314         617 my @multipleoctet = @$multipleoctet;
1993              
1994             # return character list
1995 314 100       489 if (scalar(@singleoctet) >= 1) {
1996              
1997             # with /i modifier
1998 314 100       664 if ($modifier =~ m/i/oxms) {
1999 236         456 my %singleoctet_ignorecase = ();
2000 22         35 for (@singleoctet) {
2001 22   100     27 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2002 46         208 for my $ord (hex($1) .. hex($2)) {
2003 46         137 my $char = CORE::chr($ord);
2004 66         100 my $uc = Elatin8::uc($char);
2005 66         89 my $fc = Elatin8::fc($char);
2006 66 100       96 if ($uc eq $fc) {
2007 66         106 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2008             }
2009             else {
2010 12 50       75 if (CORE::length($fc) == 1) {
2011 54         82 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2012 54         117 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2013             }
2014             else {
2015 54         180 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2016 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2017             }
2018             }
2019             }
2020             }
2021 0 50       0 if ($_ ne '') {
2022 46         97 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2023             }
2024             }
2025 0         0 my $i = 0;
2026 22         27 my @singleoctet_ignorecase = ();
2027 22         28 for my $ord (0 .. 255) {
2028 22 100       36 if (exists $singleoctet_ignorecase{$ord}) {
2029 5632         6359 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         89  
2030             }
2031             else {
2032 96         199 $i++;
2033             }
2034             }
2035 5536         5589 @singleoctet = ();
2036 22         32 for my $range (@singleoctet_ignorecase) {
2037 22 100       55 if (ref $range) {
2038 3648 100       5349 if (scalar(@{$range}) == 1) {
  56 50       54  
2039 56         87 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         42  
2040             }
2041 36         132 elsif (scalar(@{$range}) == 2) {
2042 20         24 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2043             }
2044             else {
2045 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         21  
2046             }
2047             }
2048             }
2049             }
2050              
2051 20         70 my $not_anchor = '';
2052              
2053 236         322 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2054             }
2055 236 100       620 if (scalar(@multipleoctet) >= 2) {
2056 314         644 return '(?:' . join('|', @multipleoctet) . ')';
2057             }
2058             else {
2059 6         31 return $multipleoctet[0];
2060             }
2061             }
2062              
2063             #
2064             # Latin-8 open character list for not qr
2065             #
2066             sub charlist_not_qr {
2067              
2068 308     44 0 1265 my $modifier = pop @_;
2069 44         96 my @char = @_;
2070              
2071 44         123 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2072 44         125 my @singleoctet = @$singleoctet;
2073 44         104 my @multipleoctet = @$multipleoctet;
2074              
2075             # with /i modifier
2076 44 100       67 if ($modifier =~ m/i/oxms) {
2077 44         131 my %singleoctet_ignorecase = ();
2078 10         15 for (@singleoctet) {
2079 10   66     14 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2080 10         43 for my $ord (hex($1) .. hex($2)) {
2081 10         30 my $char = CORE::chr($ord);
2082 30         46 my $uc = Elatin8::uc($char);
2083 30         42 my $fc = Elatin8::fc($char);
2084 30 50       43 if ($uc eq $fc) {
2085 30         49 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2086             }
2087             else {
2088 0 50       0 if (CORE::length($fc) == 1) {
2089 30         42 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2090 30         67 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2091             }
2092             else {
2093 30         91 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2094 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2095             }
2096             }
2097             }
2098             }
2099 0 50       0 if ($_ ne '') {
2100 10         20 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2101             }
2102             }
2103 0         0 my $i = 0;
2104 10         12 my @singleoctet_ignorecase = ();
2105 10         11 for my $ord (0 .. 255) {
2106 10 100       14 if (exists $singleoctet_ignorecase{$ord}) {
2107 2560         2850 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         54  
2108             }
2109             else {
2110 60         91 $i++;
2111             }
2112             }
2113 2500         2425 @singleoctet = ();
2114 10         15 for my $range (@singleoctet_ignorecase) {
2115 10 100       21 if (ref $range) {
2116 960 50       1781 if (scalar(@{$range}) == 1) {
  20 50       21  
2117 20         26 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2118             }
2119 0         0 elsif (scalar(@{$range}) == 2) {
2120 20         25 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2121             }
2122             else {
2123 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         26  
2124             }
2125             }
2126             }
2127             }
2128              
2129             # return character list
2130 20 50       83 if (scalar(@multipleoctet) >= 1) {
2131 44 0       141 if (scalar(@singleoctet) >= 1) {
2132              
2133             # any character other than multiple-octet and single octet character class
2134 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2135             }
2136             else {
2137              
2138             # any character other than multiple-octet character class
2139 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2140             }
2141             }
2142             else {
2143 0 50       0 if (scalar(@singleoctet) >= 1) {
2144              
2145             # any character other than single octet character class
2146 44         86 return '(?:[^' . join('', @singleoctet) . '])';
2147             }
2148             else {
2149              
2150             # any character
2151 44         253 return "(?:$your_char)";
2152             }
2153             }
2154             }
2155              
2156             #
2157             # open file in read mode
2158             #
2159             sub _open_r {
2160 0     412   0 my(undef,$file) = @_;
2161 206     206   2074 use Fcntl qw(O_RDONLY);
  206         3938  
  206         24990  
2162 412         1051 return CORE::sysopen($_[0], $file, &O_RDONLY);
2163             }
2164              
2165             #
2166             # open file in append mode
2167             #
2168             sub _open_a {
2169 412     206   15439 my(undef,$file) = @_;
2170 206     206   1397 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  206         379  
  206         532900  
2171 206         714 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2172             }
2173              
2174             #
2175             # safe system
2176             #
2177             sub _systemx {
2178              
2179             # P.707 29.2.33. exec
2180             # in Chapter 29: Functions
2181             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2182             #
2183             # Be aware that in older releases of Perl, exec (and system) did not flush
2184             # your output buffer, so you needed to enable command buffering by setting $|
2185             # on one or more filehandles to avoid lost output in the case of exec, or
2186             # misordererd output in the case of system. This situation was largely remedied
2187             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2188              
2189             # P.855 exec
2190             # in Chapter 27: Functions
2191             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2192             #
2193             # In very old release of Perl (before v5.6), exec (and system) did not flush
2194             # your output buffer, so you needed to enable command buffering by setting $|
2195             # on one or more filehandles to avoid lost output with exec or misordered
2196             # output with system.
2197              
2198 206     206   21864 $| = 1;
2199              
2200             # P.565 23.1.2. Cleaning Up Your Environment
2201             # in Chapter 23: Security
2202             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2203              
2204             # P.656 Cleaning Up Your Environment
2205             # in Chapter 20: Security
2206             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2207              
2208             # local $ENV{'PATH'} = '.';
2209 206         764 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2210              
2211             # P.707 29.2.33. exec
2212             # in Chapter 29: Functions
2213             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2214             #
2215             # As we mentioned earlier, exec treats a discrete list of arguments as an
2216             # indication that it should bypass shell processing. However, there is one
2217             # place where you might still get tripped up. The exec call (and system, too)
2218             # will not distinguish between a single scalar argument and an array containing
2219             # only one element.
2220             #
2221             # @args = ("echo surprise"); # just one element in list
2222             # exec @args # still subject to shell escapes
2223             # or die "exec: $!"; # because @args == 1
2224             #
2225             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2226             # first argument as the pathname, which forces the rest of the arguments to be
2227             # interpreted as a list, even if there is only one of them:
2228             #
2229             # exec { $args[0] } @args # safe even with one-argument list
2230             # or die "can't exec @args: $!";
2231              
2232             # P.855 exec
2233             # in Chapter 27: Functions
2234             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2235             #
2236             # As we mentioned earlier, exec treats a discrete list of arguments as a
2237             # directive to bypass shell processing. However, there is one place where
2238             # you might still get tripped up. The exec call (and system, too) cannot
2239             # distinguish between a single scalar argument and an array containing
2240             # only one element.
2241             #
2242             # @args = ("echo surprise"); # just one element in list
2243             # exec @args # still subject to shell escapes
2244             # || die "exec: $!"; # because @args == 1
2245             #
2246             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2247             # argument as the pathname, which forces the rest of the arguments to be
2248             # interpreted as a list, even if there is only one of them:
2249             #
2250             # exec { $args[0] } @args # safe even with one-argument list
2251             # || die "can't exec @args: $!";
2252              
2253 206         1846 return CORE::system { $_[0] } @_; # safe even with one-argument list
  206         425  
2254             }
2255              
2256             #
2257             # Latin-8 order to character (with parameter)
2258             #
2259             sub Elatin8::chr(;$) {
2260              
2261 206 0   0 0 13087062 my $c = @_ ? $_[0] : $_;
2262              
2263 0 0       0 if ($c == 0x00) {
2264 0         0 return "\x00";
2265             }
2266             else {
2267 0         0 my @chr = ();
2268 0         0 while ($c > 0) {
2269 0         0 unshift @chr, ($c % 0x100);
2270 0         0 $c = int($c / 0x100);
2271             }
2272 0         0 return pack 'C*', @chr;
2273             }
2274             }
2275              
2276             #
2277             # Latin-8 order to character (without parameter)
2278             #
2279             sub Elatin8::chr_() {
2280              
2281 0     0 0 0 my $c = $_;
2282              
2283 0 0       0 if ($c == 0x00) {
2284 0         0 return "\x00";
2285             }
2286             else {
2287 0         0 my @chr = ();
2288 0         0 while ($c > 0) {
2289 0         0 unshift @chr, ($c % 0x100);
2290 0         0 $c = int($c / 0x100);
2291             }
2292 0         0 return pack 'C*', @chr;
2293             }
2294             }
2295              
2296             #
2297             # Latin-8 path globbing (with parameter)
2298             #
2299             sub Elatin8::glob($) {
2300              
2301 0 0   0 0 0 if (wantarray) {
2302 0         0 my @glob = _DOS_like_glob(@_);
2303 0         0 for my $glob (@glob) {
2304 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2305             }
2306 0         0 return @glob;
2307             }
2308             else {
2309 0         0 my $glob = _DOS_like_glob(@_);
2310 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2311 0         0 return $glob;
2312             }
2313             }
2314              
2315             #
2316             # Latin-8 path globbing (without parameter)
2317             #
2318             sub Elatin8::glob_() {
2319              
2320 0 0   0 0 0 if (wantarray) {
2321 0         0 my @glob = _DOS_like_glob();
2322 0         0 for my $glob (@glob) {
2323 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2324             }
2325 0         0 return @glob;
2326             }
2327             else {
2328 0         0 my $glob = _DOS_like_glob();
2329 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2330 0         0 return $glob;
2331             }
2332             }
2333              
2334             #
2335             # Latin-8 path globbing via File::DosGlob 1.10
2336             #
2337             # Often I confuse "_dosglob" and "_doglob".
2338             # So, I renamed "_dosglob" to "_DOS_like_glob".
2339             #
2340             my %iter;
2341             my %entries;
2342             sub _DOS_like_glob {
2343              
2344             # context (keyed by second cxix argument provided by core)
2345 0     0   0 my($expr,$cxix) = @_;
2346              
2347             # glob without args defaults to $_
2348 0 0       0 $expr = $_ if not defined $expr;
2349              
2350             # represents the current user's home directory
2351             #
2352             # 7.3. Expanding Tildes in Filenames
2353             # in Chapter 7. File Access
2354             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2355             #
2356             # and File::HomeDir, File::HomeDir::Windows module
2357              
2358             # DOS-like system
2359 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2360 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2361             { my_home_MSWin32() }oxmse;
2362             }
2363              
2364             # UNIX-like system
2365 0 0 0     0 else {
  0         0  
2366             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2367             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2368             }
2369 0 0       0  
2370 0 0       0 # assume global context if not provided one
2371             $cxix = '_G_' if not defined $cxix;
2372             $iter{$cxix} = 0 if not exists $iter{$cxix};
2373 0 0       0  
2374 0         0 # if we're just beginning, do it all first
2375             if ($iter{$cxix} == 0) {
2376             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2377             }
2378 0 0       0  
2379 0         0 # chuck it all out, quick or slow
2380 0         0 if (wantarray) {
  0         0  
2381             delete $iter{$cxix};
2382             return @{delete $entries{$cxix}};
2383 0 0       0 }
  0         0  
2384 0         0 else {
  0         0  
2385             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2386             return shift @{$entries{$cxix}};
2387             }
2388 0         0 else {
2389 0         0 # return undef for EOL
2390 0         0 delete $iter{$cxix};
2391             delete $entries{$cxix};
2392             return undef;
2393             }
2394             }
2395             }
2396              
2397             #
2398             # Latin-8 path globbing subroutine
2399             #
2400 0     0   0 sub _do_glob {
2401 0         0  
2402 0         0 my($cond,@expr) = @_;
2403             my @glob = ();
2404             my $fix_drive_relative_paths = 0;
2405 0         0  
2406 0 0       0 OUTER:
2407 0 0       0 for my $expr (@expr) {
2408             next OUTER if not defined $expr;
2409 0         0 next OUTER if $expr eq '';
2410 0         0  
2411 0         0 my @matched = ();
2412 0         0 my @globdir = ();
2413 0         0 my $head = '.';
2414             my $pathsep = '/';
2415             my $tail;
2416 0 0       0  
2417 0         0 # if argument is within quotes strip em and do no globbing
2418 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2419 0 0       0 $expr = $1;
2420 0         0 if ($cond eq 'd') {
2421             if (-d $expr) {
2422             push @glob, $expr;
2423             }
2424 0 0       0 }
2425 0         0 else {
2426             if (-e $expr) {
2427             push @glob, $expr;
2428 0         0 }
2429             }
2430             next OUTER;
2431             }
2432              
2433 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2434 0 0       0 # to h:./*.pm to expand correctly
2435 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2436             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2437             $fix_drive_relative_paths = 1;
2438             }
2439 0 0       0 }
2440 0 0       0  
2441 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2442 0         0 if ($tail eq '') {
2443             push @glob, $expr;
2444 0 0       0 next OUTER;
2445 0 0       0 }
2446 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2447 0         0 if (@globdir = _do_glob('d', $head)) {
2448             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2449             next OUTER;
2450 0 0 0     0 }
2451 0         0 }
2452             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2453 0         0 $head .= $pathsep;
2454             }
2455             $expr = $tail;
2456             }
2457 0 0       0  
2458 0 0       0 # If file component has no wildcards, we can avoid opendir
2459 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2460             if ($head eq '.') {
2461 0 0 0     0 $head = '';
2462 0         0 }
2463             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2464 0         0 $head .= $pathsep;
2465 0 0       0 }
2466 0 0       0 $head .= $expr;
2467 0         0 if ($cond eq 'd') {
2468             if (-d $head) {
2469             push @glob, $head;
2470             }
2471 0 0       0 }
2472 0         0 else {
2473             if (-e $head) {
2474             push @glob, $head;
2475 0         0 }
2476             }
2477 0 0       0 next OUTER;
2478 0         0 }
2479 0         0 opendir(*DIR, $head) or next OUTER;
2480             my @leaf = readdir DIR;
2481 0 0       0 closedir DIR;
2482 0         0  
2483             if ($head eq '.') {
2484 0 0 0     0 $head = '';
2485 0         0 }
2486             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2487             $head .= $pathsep;
2488 0         0 }
2489 0         0  
2490 0         0 my $pattern = '';
2491             while ($expr =~ / \G ($q_char) /oxgc) {
2492             my $char = $1;
2493              
2494             # 6.9. Matching Shell Globs as Regular Expressions
2495             # in Chapter 6. Pattern Matching
2496             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2497 0 0       0 # (and so on)
    0          
    0          
2498 0         0  
2499             if ($char eq '*') {
2500             $pattern .= "(?:$your_char)*",
2501 0         0 }
2502             elsif ($char eq '?') {
2503             $pattern .= "(?:$your_char)?", # DOS style
2504             # $pattern .= "(?:$your_char)", # UNIX style
2505 0         0 }
2506             elsif ((my $fc = Elatin8::fc($char)) ne $char) {
2507             $pattern .= $fc;
2508 0         0 }
2509             else {
2510             $pattern .= quotemeta $char;
2511 0     0   0 }
  0         0  
2512             }
2513             my $matchsub = sub { Elatin8::fc($_[0]) =~ /\A $pattern \z/xms };
2514              
2515             # if ($@) {
2516             # print STDERR "$0: $@\n";
2517             # next OUTER;
2518             # }
2519 0         0  
2520 0 0 0     0 INNER:
2521 0         0 for my $leaf (@leaf) {
2522             if ($leaf eq '.' or $leaf eq '..') {
2523 0 0 0     0 next INNER;
2524 0         0 }
2525             if ($cond eq 'd' and not -d "$head$leaf") {
2526             next INNER;
2527 0 0       0 }
2528 0         0  
2529 0         0 if (&$matchsub($leaf)) {
2530             push @matched, "$head$leaf";
2531             next INNER;
2532             }
2533              
2534             # [DOS compatibility special case]
2535 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2536              
2537             if (Elatin8::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2538             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2539 0 0       0 Elatin8::index($pattern,'\\.') != -1 # pattern has a dot.
2540 0         0 ) {
2541 0         0 if (&$matchsub("$leaf.")) {
2542             push @matched, "$head$leaf";
2543             next INNER;
2544             }
2545 0 0       0 }
2546 0         0 }
2547             if (@matched) {
2548             push @glob, @matched;
2549 0 0       0 }
2550 0         0 }
2551 0         0 if ($fix_drive_relative_paths) {
2552             for my $glob (@glob) {
2553             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2554 0         0 }
2555             }
2556             return @glob;
2557             }
2558              
2559             #
2560             # Latin-8 parse line
2561             #
2562 0     0   0 sub _parse_line {
2563              
2564 0         0 my($line) = @_;
2565 0         0  
2566 0         0 $line .= ' ';
2567             my @piece = ();
2568             while ($line =~ /
2569             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2570             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2571 0 0       0 /oxmsg
2572             ) {
2573 0         0 push @piece, defined($1) ? $1 : $2;
2574             }
2575             return @piece;
2576             }
2577              
2578             #
2579             # Latin-8 parse path
2580             #
2581 0     0   0 sub _parse_path {
2582              
2583 0         0 my($path,$pathsep) = @_;
2584 0         0  
2585 0         0 $path .= '/';
2586             my @subpath = ();
2587             while ($path =~ /
2588             ((?: [^\/\\] )+?) [\/\\]
2589 0         0 /oxmsg
2590             ) {
2591             push @subpath, $1;
2592 0         0 }
2593 0         0  
2594 0         0 my $tail = pop @subpath;
2595             my $head = join $pathsep, @subpath;
2596             return $head, $tail;
2597             }
2598              
2599             #
2600             # via File::HomeDir::Windows 1.00
2601             #
2602             sub my_home_MSWin32 {
2603              
2604             # A lot of unix people and unix-derived tools rely on
2605 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2606 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2607             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2608             return $ENV{'HOME'};
2609             }
2610              
2611 0         0 # Do we have a user profile?
2612             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2613             return $ENV{'USERPROFILE'};
2614             }
2615              
2616 0         0 # Some Windows use something like $ENV{'HOME'}
2617             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2618             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2619 0         0 }
2620              
2621             return undef;
2622             }
2623              
2624             #
2625             # via File::HomeDir::Unix 1.00
2626 0     0 0 0 #
2627             sub my_home {
2628 0 0 0     0 my $home;
    0 0        
2629 0         0  
2630             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2631             $home = $ENV{'HOME'};
2632             }
2633              
2634             # This is from the original code, but I'm guessing
2635 0         0 # it means "login directory" and exists on some Unixes.
2636             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2637             $home = $ENV{'LOGDIR'};
2638             }
2639              
2640             ### More-desperate methods
2641              
2642 0         0 # Light desperation on any (Unixish) platform
2643             else {
2644             $home = CORE::eval q{ (getpwuid($<))[7] };
2645             }
2646              
2647 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2648 0         0 # For example, "nobody"-like users might use /nonexistant
2649             if (defined $home and ! -d($home)) {
2650 0         0 $home = undef;
2651             }
2652             return $home;
2653             }
2654              
2655             #
2656             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2657 0     0 0 0 #
2658             sub Elatin8::PREMATCH {
2659             return $`;
2660             }
2661              
2662             #
2663             # ${^MATCH}, $MATCH, $& the string that matched
2664 0     0 0 0 #
2665             sub Elatin8::MATCH {
2666             return $&;
2667             }
2668              
2669             #
2670             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2671 0     0 0 0 #
2672             sub Elatin8::POSTMATCH {
2673             return $';
2674             }
2675              
2676             #
2677             # Latin-8 character to order (with parameter)
2678             #
2679 0 0   0 1 0 sub Latin8::ord(;$) {
2680              
2681 0 0       0 local $_ = shift if @_;
2682 0         0  
2683 0         0 if (/\A ($q_char) /oxms) {
2684 0         0 my @ord = unpack 'C*', $1;
2685 0         0 my $ord = 0;
2686             while (my $o = shift @ord) {
2687 0         0 $ord = $ord * 0x100 + $o;
2688             }
2689             return $ord;
2690 0         0 }
2691             else {
2692             return CORE::ord $_;
2693             }
2694             }
2695              
2696             #
2697             # Latin-8 character to order (without parameter)
2698             #
2699 0 0   0 0 0 sub Latin8::ord_() {
2700 0         0  
2701 0         0 if (/\A ($q_char) /oxms) {
2702 0         0 my @ord = unpack 'C*', $1;
2703 0         0 my $ord = 0;
2704             while (my $o = shift @ord) {
2705 0         0 $ord = $ord * 0x100 + $o;
2706             }
2707             return $ord;
2708 0         0 }
2709             else {
2710             return CORE::ord $_;
2711             }
2712             }
2713              
2714             #
2715             # Latin-8 reverse
2716             #
2717 0 0   0 0 0 sub Latin8::reverse(@) {
2718 0         0  
2719             if (wantarray) {
2720             return CORE::reverse @_;
2721             }
2722             else {
2723              
2724             # One of us once cornered Larry in an elevator and asked him what
2725             # problem he was solving with this, but he looked as far off into
2726             # the distance as he could in an elevator and said, "It seemed like
2727 0         0 # a good idea at the time."
2728              
2729             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2730             }
2731             }
2732              
2733             #
2734             # Latin-8 getc (with parameter, without parameter)
2735             #
2736 0     0 0 0 sub Latin8::getc(;*@) {
2737 0 0       0  
2738 0 0 0     0 my($package) = caller;
2739             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2740 0         0 croak 'Too many arguments for Latin8::getc' if @_ and not wantarray;
  0         0  
2741 0         0  
2742 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2743 0         0 my $getc = '';
2744 0 0       0 for my $length ($length[0] .. $length[-1]) {
2745 0 0       0 $getc .= CORE::getc($fh);
2746 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2747             if ($getc =~ /\A ${Elatin8::dot_s} \z/oxms) {
2748             return wantarray ? ($getc,@_) : $getc;
2749             }
2750 0 0       0 }
2751             }
2752             return wantarray ? ($getc,@_) : $getc;
2753             }
2754              
2755             #
2756             # Latin-8 length by character
2757             #
2758 0 0   0 1 0 sub Latin8::length(;$) {
2759              
2760 0         0 local $_ = shift if @_;
2761 0         0  
2762             local @_ = /\G ($q_char) /oxmsg;
2763             return scalar @_;
2764             }
2765              
2766             #
2767             # Latin-8 substr by character
2768             #
2769             BEGIN {
2770              
2771             # P.232 The lvalue Attribute
2772             # in Chapter 6: Subroutines
2773             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2774              
2775             # P.336 The lvalue Attribute
2776             # in Chapter 7: Subroutines
2777             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2778              
2779             # P.144 8.4 Lvalue subroutines
2780             # in Chapter 8: perlsub: Perl subroutines
2781 206 50 0 206 1 126037 # 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         0  
  0         0  
  0         0  
  0         0  
  0         0  
2782              
2783             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2784             # vv----------------------*******
2785             sub Latin8::substr($$;$$) %s {
2786              
2787             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2788              
2789             # If the substring is beyond either end of the string, substr() returns the undefined
2790             # value and produces a warning. When used as an lvalue, specifying a substring that
2791             # is entirely outside the string raises an exception.
2792             # http://perldoc.perl.org/functions/substr.html
2793              
2794             # A return with no argument returns the scalar value undef in scalar context,
2795             # an empty list () in list context, and (naturally) nothing at all in void
2796             # context.
2797              
2798             my $offset = $_[1];
2799             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2800             return;
2801             }
2802              
2803             # substr($string,$offset,$length,$replacement)
2804             if (@_ == 4) {
2805             my(undef,undef,$length,$replacement) = @_;
2806             my $substr = join '', splice(@char, $offset, $length, $replacement);
2807             $_[0] = join '', @char;
2808              
2809             # return $substr; this doesn't work, don't say "return"
2810             $substr;
2811             }
2812              
2813             # substr($string,$offset,$length)
2814             elsif (@_ == 3) {
2815             my(undef,undef,$length) = @_;
2816             my $octet_offset = 0;
2817             my $octet_length = 0;
2818             if ($offset == 0) {
2819             $octet_offset = 0;
2820             }
2821             elsif ($offset > 0) {
2822             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2823             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2824             }
2825             else {
2826             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2827             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2828             }
2829             if ($length == 0) {
2830             $octet_length = 0;
2831             }
2832             elsif ($length > 0) {
2833             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2834             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2835             }
2836             else {
2837             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
2838             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2839             }
2840             CORE::substr($_[0], $octet_offset, $octet_length);
2841             }
2842              
2843             # substr($string,$offset)
2844             else {
2845             my $octet_offset = 0;
2846             if ($offset == 0) {
2847             $octet_offset = 0;
2848             }
2849             elsif ($offset > 0) {
2850             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2851             }
2852             else {
2853             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2854             }
2855             CORE::substr($_[0], $octet_offset);
2856             }
2857             }
2858             END
2859             }
2860              
2861             #
2862             # Latin-8 index by character
2863             #
2864 0     0 1 0 sub Latin8::index($$;$) {
2865 0 0       0  
2866 0         0 my $index;
2867             if (@_ == 3) {
2868             $index = Elatin8::index($_[0], $_[1], CORE::length(Latin8::substr($_[0], 0, $_[2])));
2869 0         0 }
2870             else {
2871             $index = Elatin8::index($_[0], $_[1]);
2872 0 0       0 }
2873 0         0  
2874             if ($index == -1) {
2875             return -1;
2876 0         0 }
2877             else {
2878             return Latin8::length(CORE::substr $_[0], 0, $index);
2879             }
2880             }
2881              
2882             #
2883             # Latin-8 rindex by character
2884             #
2885 0     0 1 0 sub Latin8::rindex($$;$) {
2886 0 0       0  
2887 0         0 my $rindex;
2888             if (@_ == 3) {
2889             $rindex = Elatin8::rindex($_[0], $_[1], CORE::length(Latin8::substr($_[0], 0, $_[2])));
2890 0         0 }
2891             else {
2892             $rindex = Elatin8::rindex($_[0], $_[1]);
2893 0 0       0 }
2894 0         0  
2895             if ($rindex == -1) {
2896             return -1;
2897 0         0 }
2898             else {
2899             return Latin8::length(CORE::substr $_[0], 0, $rindex);
2900             }
2901             }
2902              
2903 206     206   1565 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  206         446  
  206         16848  
2904             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2905             use vars qw($slash); $slash = 'm//';
2906              
2907             # ord() to ord() or Latin8::ord()
2908             my $function_ord = 'ord';
2909              
2910             # ord to ord or Latin8::ord_
2911             my $function_ord_ = 'ord';
2912              
2913             # reverse to reverse or Latin8::reverse
2914             my $function_reverse = 'reverse';
2915              
2916             # getc to getc or Latin8::getc
2917             my $function_getc = 'getc';
2918              
2919             # P.1023 Appendix W.9 Multibyte Anchoring
2920             # of ISBN 1-56592-224-7 CJKV Information Processing
2921              
2922 206     206   1299 my $anchor = '';
  206     0   379  
  206         6975309  
2923              
2924             use vars qw($nest);
2925              
2926             # regexp of nested parens in qqXX
2927              
2928             # P.340 Matching Nested Constructs with Embedded Code
2929             # in Chapter 7: Perl
2930             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2931              
2932             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2933             [^\\()] |
2934             \( (?{$nest++}) |
2935             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2936             \\ [^c] |
2937             \\c[\x40-\x5F] |
2938             [\x00-\xFF]
2939             }xms;
2940              
2941             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2942             [^\\{}] |
2943             \{ (?{$nest++}) |
2944             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2945             \\ [^c] |
2946             \\c[\x40-\x5F] |
2947             [\x00-\xFF]
2948             }xms;
2949              
2950             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2951             [^\\\[\]] |
2952             \[ (?{$nest++}) |
2953             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2954             \\ [^c] |
2955             \\c[\x40-\x5F] |
2956             [\x00-\xFF]
2957             }xms;
2958              
2959             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2960             [^\\<>] |
2961             \< (?{$nest++}) |
2962             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2963             \\ [^c] |
2964             \\c[\x40-\x5F] |
2965             [\x00-\xFF]
2966             }xms;
2967              
2968             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2969             (?: ::)? (?:
2970             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2971             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2972             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2973             ))
2974             }xms;
2975              
2976             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2977             (?: ::)? (?:
2978             (?>[0-9]+) |
2979             [^a-zA-Z_0-9\[\]] |
2980             ^[A-Z] |
2981             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2982             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2983             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2984             ))
2985             }xms;
2986              
2987             my $qq_substr = qr{(?> Char::substr | Latin8::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2988             }xms;
2989              
2990             # regexp of nested parens in qXX
2991             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2992             [^()] |
2993             \( (?{$nest++}) |
2994             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2995             [\x00-\xFF]
2996             }xms;
2997              
2998             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2999             [^\{\}] |
3000             \{ (?{$nest++}) |
3001             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3002             [\x00-\xFF]
3003             }xms;
3004              
3005             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
3006             [^\[\]] |
3007             \[ (?{$nest++}) |
3008             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3009             [\x00-\xFF]
3010             }xms;
3011              
3012             my $q_angle = qr{(?{local $nest=0}) (?>(?:
3013             [^<>] |
3014             \< (?{$nest++}) |
3015             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
3016             [\x00-\xFF]
3017             }xms;
3018              
3019             my $matched = '';
3020             my $s_matched = '';
3021              
3022             my $tr_variable = ''; # variable of tr///
3023             my $sub_variable = ''; # variable of s///
3024             my $bind_operator = ''; # =~ or !~
3025              
3026             my @heredoc = (); # here document
3027             my @heredoc_delimiter = ();
3028             my $here_script = ''; # here script
3029              
3030             #
3031             # escape Latin-8 script
3032 0 50   206 0 0 #
3033             sub Latin8::escape(;$) {
3034             local($_) = $_[0] if @_;
3035              
3036             # P.359 The Study Function
3037             # in Chapter 7: Perl
3038 206         603 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3039              
3040             study $_; # Yes, I studied study yesterday.
3041              
3042             # while all script
3043              
3044             # 6.14. Matching from Where the Last Pattern Left Off
3045             # in Chapter 6. Pattern Matching
3046             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3047             # (and so on)
3048              
3049             # one member of Tag-team
3050             #
3051             # P.128 Start of match (or end of previous match): \G
3052             # P.130 Advanced Use of \G with Perl
3053             # in Chapter 3: Overview of Regular Expression Features and Flavors
3054             # P.255 Use leading anchors
3055             # P.256 Expose ^ and \G at the front expressions
3056             # in Chapter 6: Crafting an Efficient Expression
3057             # P.315 "Tag-team" matching with /gc
3058             # in Chapter 7: Perl
3059 206         380 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3060 206         347  
3061 206         718 my $e_script = '';
3062             while (not /\G \z/oxgc) { # member
3063             $e_script .= Latin8::escape_token();
3064 75199         107848 }
3065              
3066             return $e_script;
3067             }
3068              
3069             #
3070             # escape Latin-8 token of script
3071             #
3072             sub Latin8::escape_token {
3073              
3074 206     75199 0 2430 # \n output here document
3075              
3076             my $ignore_modules = join('|', qw(
3077             utf8
3078             bytes
3079             charnames
3080             I18N::Japanese
3081             I18N::Collate
3082             I18N::JExt
3083             File::DosGlob
3084             Wild
3085             Wildcard
3086             Japanese
3087             ));
3088              
3089             # another member of Tag-team
3090             #
3091             # P.315 "Tag-team" matching with /gc
3092             # in Chapter 7: Perl
3093 75199 100 100     82932 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 66        
    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          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3094 75199         2621121  
3095 12558 100       14693 if (/\G ( \n ) /oxgc) { # another member (and so on)
3096 12558         20331 my $heredoc = '';
3097             if (scalar(@heredoc_delimiter) >= 1) {
3098 174         215 $slash = 'm//';
3099 174         324  
3100             $heredoc = join '', @heredoc;
3101             @heredoc = ();
3102 174         269  
3103 174         311 # skip here document
3104             for my $heredoc_delimiter (@heredoc_delimiter) {
3105 174         1025 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3106             }
3107 174         322 @heredoc_delimiter = ();
3108              
3109 174         228 $here_script = '';
3110             }
3111             return "\n" . $heredoc;
3112             }
3113 12558         34530  
3114             # ignore space, comment
3115             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3116              
3117             # if (, elsif (, unless (, while (, until (, given (, and when (
3118              
3119             # given, when
3120              
3121             # P.225 The given Statement
3122             # in Chapter 15: Smart Matching and given-when
3123             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3124              
3125             # P.133 The given Statement
3126             # in Chapter 4: Statements and Declarations
3127             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3128 18106         52255  
3129 1401         2038 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3130             $slash = 'm//';
3131             return $1;
3132             }
3133              
3134             # scalar variable ($scalar = ...) =~ tr///;
3135             # scalar variable ($scalar = ...) =~ s///;
3136              
3137             # state
3138              
3139             # P.68 Persistent, Private Variables
3140             # in Chapter 4: Subroutines
3141             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3142              
3143             # P.160 Persistent Lexically Scoped Variables: state
3144             # in Chapter 4: Statements and Declarations
3145             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3146              
3147             # (and so on)
3148 1401         4310  
3149             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3150 86 50       178 my $e_string = e_string($1);
    50          
3151 86         1909  
3152 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3153 0         0 $tr_variable = $e_string . e_string($1);
3154 0         0 $bind_operator = $2;
3155             $slash = 'm//';
3156             return '';
3157 0         0 }
3158 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3159 0         0 $sub_variable = $e_string . e_string($1);
3160 0         0 $bind_operator = $2;
3161             $slash = 'm//';
3162             return '';
3163 0         0 }
3164 86         145 else {
3165             $slash = 'div';
3166             return $e_string;
3167             }
3168             }
3169              
3170 86         251 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
3171 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3172             $slash = 'div';
3173             return q{Elatin8::PREMATCH()};
3174             }
3175              
3176 4         14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
3177 28         47 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3178             $slash = 'div';
3179             return q{Elatin8::MATCH()};
3180             }
3181              
3182 28         101 # $', ${'} --> $', ${'}
3183 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3184             $slash = 'div';
3185             return $1;
3186             }
3187              
3188 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
3189 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3190             $slash = 'div';
3191             return q{Elatin8::POSTMATCH()};
3192             }
3193              
3194             # scalar variable $scalar =~ tr///;
3195             # scalar variable $scalar =~ s///;
3196             # substr() =~ tr///;
3197 3         10 # substr() =~ s///;
3198             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3199 1674 100       3414 my $scalar = e_string($1);
    100          
3200 1674         6010  
3201 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3202 1         2 $tr_variable = $scalar;
3203 1         2 $bind_operator = $1;
3204             $slash = 'm//';
3205             return '';
3206 1         3 }
3207 61         115 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3208 61         133 $sub_variable = $scalar;
3209 61         96 $bind_operator = $1;
3210             $slash = 'm//';
3211             return '';
3212 61         175 }
3213 1612         2186 else {
3214             $slash = 'div';
3215             return $scalar;
3216             }
3217             }
3218              
3219 1612         3980 # end of statement
3220             elsif (/\G ( [,;] ) /oxgc) {
3221             $slash = 'm//';
3222 5031         7249  
3223             # clear tr/// variable
3224             $tr_variable = '';
3225 5031         5640  
3226             # clear s/// variable
3227 5031         5353 $sub_variable = '';
3228              
3229 5031         5303 $bind_operator = '';
3230              
3231             return $1;
3232             }
3233              
3234 5031         15974 # bareword
3235             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3236             return $1;
3237             }
3238              
3239 0         0 # $0 --> $0
3240 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3241             $slash = 'div';
3242             return $1;
3243 2         7 }
3244 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3245             $slash = 'div';
3246             return $1;
3247             }
3248              
3249 0         0 # $$ --> $$
3250 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3251             $slash = 'div';
3252             return $1;
3253             }
3254              
3255             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3256 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3257 4         6 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3258             $slash = 'div';
3259             return e_capture($1);
3260 4         8 }
3261 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3262             $slash = 'div';
3263             return e_capture($1);
3264             }
3265              
3266 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3267 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3268             $slash = 'div';
3269             return e_capture($1.'->'.$2);
3270             }
3271              
3272 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3273 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3274             $slash = 'div';
3275             return e_capture($1.'->'.$2);
3276             }
3277              
3278 0         0 # $$foo
3279 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3280             $slash = 'div';
3281             return e_capture($1);
3282             }
3283              
3284 0         0 # ${ foo }
3285 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3286             $slash = 'div';
3287             return '${' . $1 . '}';
3288             }
3289              
3290 0         0 # ${ ... }
3291 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3292             $slash = 'div';
3293             return e_capture($1);
3294             }
3295              
3296             # variable or function
3297 0         0 # $ @ % & * $ #
3298 42         69 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) {
3299             $slash = 'div';
3300             return $1;
3301             }
3302             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3303 42         128 # $ @ # \ ' " / ? ( ) [ ] < >
3304 62         114 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3305             $slash = 'div';
3306             return $1;
3307             }
3308              
3309 62         195 # while ()
3310             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3311             return $1;
3312             }
3313              
3314             # while () --- glob
3315              
3316             # avoid "Error: Runtime exception" of perl version 5.005_03
3317 0         0  
3318             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3319             return 'while ($_ = Elatin8::glob("' . $1 . '"))';
3320             }
3321              
3322 0         0 # while (glob)
3323             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3324             return 'while ($_ = Elatin8::glob_)';
3325             }
3326              
3327 0         0 # while (glob(WILDCARD))
3328             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3329             return 'while ($_ = Elatin8::glob';
3330             }
3331 0         0  
  248         487  
3332             # doit if, doit unless, doit while, doit until, doit for, doit when
3333             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3334 248         860  
  19         31  
3335 19         63 # subroutines of package Elatin8
  0         0  
3336 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         22  
3337 13         32 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3338 0         0 elsif (/\G \b Latin8::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         174  
3339 114         295 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         4  
3340 2         5 elsif (/\G \b Latin8::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin8::escape'; }
  0         0  
3341 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         3  
3342 2         6 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::chop'; }
  0         0  
3343 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3344 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3345 0         0 elsif (/\G \b Latin8::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin8::index'; }
  2         5  
3346 2         5 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::index'; }
  0         0  
3347 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3348 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3349 0         0 elsif (/\G \b Latin8::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin8::rindex'; }
  1         2  
3350 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::rindex'; }
  0         0  
3351 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::lc'; }
  1         3  
3352 1         4 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::lcfirst'; }
  0         0  
3353 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::uc'; }
  6         7  
3354             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::ucfirst'; }
3355             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::fc'; }
3356 6         18  
  0         0  
3357 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3358 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3359 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3360 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3361 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3362 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3363             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3364 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  
3365 0         0  
  0         0  
3366 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3367 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3368 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3369 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3370 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3371             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3372             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3373 0         0  
  0         0  
3374 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3375 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3376 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3377             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3378 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3379 2         6  
  2         5  
3380 2         5 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         58  
3381 36         96 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3382 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::chr'; }
  8         14  
3383 8         23 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3384 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3385 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin8::glob'; }
  0         0  
3386 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::lc_'; }
  0         0  
3387 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::lcfirst_'; }
  0         0  
3388 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::uc_'; }
  0         0  
3389 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::ucfirst_'; }
  0         0  
3390             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::fc_'; }
3391 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3392 0         0  
  0         0  
3393 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3394 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3395 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::chr_'; }
  0         0  
3396 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3397 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3398 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin8::glob_'; }
  8         18  
3399             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3400             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3401 8         27 # split
3402             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3403 87         167 $slash = 'm//';
3404 87         121  
3405 87         288 my $e = '';
3406             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3407             $e .= $1;
3408             }
3409 85 100       304  
  87 100       5503  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3410             # end of split
3411             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin8::split' . $e; }
3412 2         17  
3413             # split scalar value
3414             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin8::split' . $e . e_string($1); }
3415 1         5  
3416 0         0 # split literal space
3417 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin8::split' . $e . qq {qq$1 $2}; }
3418 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3419 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3420 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3421 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3422 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin8::split' . $e . qq{$1qq$2 $3}; }
3423 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin8::split' . $e . qq {q$1 $2}; }
3424 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3425 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3426 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3427 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3428 10         45 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin8::split' . $e . qq {$1q$2 $3}; }
3429             elsif (/\G ' [ ] ' /oxgc) { return 'Elatin8::split' . $e . qq {' '}; }
3430             elsif (/\G " [ ] " /oxgc) { return 'Elatin8::split' . $e . qq {" "}; }
3431              
3432 0 0       0 # split qq//
  0         0  
3433             elsif (/\G \b (qq) \b /oxgc) {
3434 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3435 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3436 0         0 while (not /\G \z/oxgc) {
3437 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3438 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3439 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3440 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3441 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3442             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3443 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3444             }
3445             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3446             }
3447             }
3448              
3449 0 50       0 # split qr//
  12         402  
3450             elsif (/\G \b (qr) \b /oxgc) {
3451 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3452 12 50       63 else {
  12 50       3285  
    50          
    50          
    50          
    50          
    50          
    50          
3453 0         0 while (not /\G \z/oxgc) {
3454 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3455 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3456 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3457 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3458 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3459 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3460             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3461 12         83 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3462             }
3463             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3464             }
3465             }
3466              
3467 0 0       0 # split q//
  0         0  
3468             elsif (/\G \b (q) \b /oxgc) {
3469 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3470 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3471 0         0 while (not /\G \z/oxgc) {
3472 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3473 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3474 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3475 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3476 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3477             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3478 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3479             }
3480             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3481             }
3482             }
3483              
3484 0 50       0 # split m//
  18         481  
3485             elsif (/\G \b (m) \b /oxgc) {
3486 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3487 18 50       81 else {
  18 50       3702  
    50          
    50          
    50          
    50          
    50          
    50          
3488 0         0 while (not /\G \z/oxgc) {
3489 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3490 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3491 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3492 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3493 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3494 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3495             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3496 18         139 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3497             }
3498             die __FILE__, ": Search pattern not terminated\n";
3499             }
3500             }
3501              
3502 0         0 # split ''
3503 0         0 elsif (/\G (\') /oxgc) {
3504 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3505 0         0 while (not /\G \z/oxgc) {
3506 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3507 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3508             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3509 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3510             }
3511             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3512             }
3513              
3514 0         0 # split ""
3515 0         0 elsif (/\G (\") /oxgc) {
3516 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3517 0         0 while (not /\G \z/oxgc) {
3518 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3519 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3520             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3521 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3522             }
3523             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3524             }
3525              
3526 0         0 # split //
3527 44         112 elsif (/\G (\/) /oxgc) {
3528 44 50       125 my $regexp = '';
  381 50       1393  
    100          
    50          
3529 0         0 while (not /\G \z/oxgc) {
3530 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3531 44         180 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3532             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3533 337         720 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3534             }
3535             die __FILE__, ": Search pattern not terminated\n";
3536             }
3537             }
3538              
3539             # tr/// or y///
3540              
3541             # about [cdsrbB]* (/B modifier)
3542             #
3543             # P.559 appendix C
3544             # of ISBN 4-89052-384-7 Programming perl
3545             # (Japanese title is: Perl puroguramingu)
3546 0         0  
3547             elsif (/\G \b ( tr | y ) \b /oxgc) {
3548             my $ope = $1;
3549 3 50       7  
3550 3         48 # $1 $2 $3 $4 $5 $6
3551 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3552             my @tr = ($tr_variable,$2);
3553             return e_tr(@tr,'',$4,$6);
3554 0         0 }
3555 3         5 else {
3556 3 50       7 my $e = '';
  3 50       218  
    50          
    50          
    50          
    50          
3557             while (not /\G \z/oxgc) {
3558 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3559 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3560 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3561 0         0 while (not /\G \z/oxgc) {
3562 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3563 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3564 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3565 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3566             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3567 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3568             }
3569             die __FILE__, ": Transliteration replacement not terminated\n";
3570 0         0 }
3571 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3572 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3573 0         0 while (not /\G \z/oxgc) {
3574 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3575 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3576 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3577 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3578             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3579 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3580             }
3581             die __FILE__, ": Transliteration replacement not terminated\n";
3582 0         0 }
3583 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3584 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3585 0         0 while (not /\G \z/oxgc) {
3586 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3587 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3588 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3589 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3590             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3591 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3592             }
3593             die __FILE__, ": Transliteration replacement not terminated\n";
3594 0         0 }
3595 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3596 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3597 0         0 while (not /\G \z/oxgc) {
3598 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3599 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3600 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3601 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3602             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3603 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3604             }
3605             die __FILE__, ": Transliteration replacement not terminated\n";
3606             }
3607 0         0 # $1 $2 $3 $4 $5 $6
3608 3         11 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3609             my @tr = ($tr_variable,$2);
3610             return e_tr(@tr,'',$4,$6);
3611 3         8 }
3612             }
3613             die __FILE__, ": Transliteration pattern not terminated\n";
3614             }
3615             }
3616              
3617 0         0 # qq//
3618             elsif (/\G \b (qq) \b /oxgc) {
3619             my $ope = $1;
3620 2180 50       4576  
3621 2180         3746 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3622 0         0 if (/\G (\#) /oxgc) { # qq# #
3623 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3624 0         0 while (not /\G \z/oxgc) {
3625 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3626 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3627             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3628 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3629             }
3630             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3631             }
3632 0         0  
3633 2180         2735 else {
3634 2180 50       4610 my $e = '';
  2180 50       7286  
    100          
    50          
    50          
    0          
3635             while (not /\G \z/oxgc) {
3636             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3637              
3638 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3639 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3640 0         0 my $qq_string = '';
3641 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3642 0         0 while (not /\G \z/oxgc) {
3643 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3644             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3645 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3646 0         0 elsif (/\G (\)) /oxgc) {
3647             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3648 0         0 else { $qq_string .= $1; }
3649             }
3650 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3651             }
3652             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3653             }
3654              
3655 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3656 2150         2667 elsif (/\G (\{) /oxgc) { # qq { }
3657 2150         2718 my $qq_string = '';
3658 2150 100       4027 local $nest = 1;
  84006 50       241689  
    100          
    100          
    50          
3659 722         1801 while (not /\G \z/oxgc) {
3660 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1480  
3661             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3662 1153 100       1864 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         4687  
3663 2150         4006 elsif (/\G (\}) /oxgc) {
3664             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3665 1153         2226 else { $qq_string .= $1; }
3666             }
3667 78828         144785 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3668             }
3669             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3670             }
3671              
3672 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3673 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3674 0         0 my $qq_string = '';
3675 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3676 0         0 while (not /\G \z/oxgc) {
3677 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3678             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3679 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3680 0         0 elsif (/\G (\]) /oxgc) {
3681             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3682 0         0 else { $qq_string .= $1; }
3683             }
3684 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3685             }
3686             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3687             }
3688              
3689 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3690 30         54 elsif (/\G (\<) /oxgc) { # qq < >
3691 30         44 my $qq_string = '';
3692 30 100       98 local $nest = 1;
  1166 50       3785  
    50          
    100          
    50          
3693 22         49 while (not /\G \z/oxgc) {
3694 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3695             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3696 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         61  
3697 30         80 elsif (/\G (\>) /oxgc) {
3698             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3699 0         0 else { $qq_string .= $1; }
3700             }
3701 1114         2096 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3702             }
3703             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3704             }
3705              
3706 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3707 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3708 0         0 my $delimiter = $1;
3709 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3710 0         0 while (not /\G \z/oxgc) {
3711 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3712 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3713             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3714 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3715             }
3716             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3717 0         0 }
3718             }
3719             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3720             }
3721             }
3722              
3723 0         0 # qr//
3724 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3725 0         0 my $ope = $1;
3726             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3727             return e_qr($ope,$1,$3,$2,$4);
3728 0         0 }
3729 0         0 else {
3730 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3731 0         0 while (not /\G \z/oxgc) {
3732 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3733 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3734 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3735 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3736 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3737 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3738             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3739 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3740             }
3741             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3742             }
3743             }
3744              
3745 0         0 # qw//
3746 16 50       44 elsif (/\G \b (qw) \b /oxgc) {
3747 16         83 my $ope = $1;
3748             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3749             return e_qw($ope,$1,$3,$2);
3750 0         0 }
3751 16         27 else {
3752 16 50       66 my $e = '';
  16 50       93  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3753             while (not /\G \z/oxgc) {
3754 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3755 16         47  
3756             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3757 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3758 0         0  
3759             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3760 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3761 0         0  
3762             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3763 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3764 0         0  
3765             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3766 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3767 0         0  
3768             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3769 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3770             }
3771             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3772             }
3773             }
3774              
3775 0         0 # qx//
3776 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3777 0         0 my $ope = $1;
3778             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3779             return e_qq($ope,$1,$3,$2);
3780 0         0 }
3781 0         0 else {
3782 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3783 0         0 while (not /\G \z/oxgc) {
3784 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3785 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3786 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3787 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3788 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3789             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3790 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3791             }
3792             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3793             }
3794             }
3795              
3796 0         0 # q//
3797             elsif (/\G \b (q) \b /oxgc) {
3798             my $ope = $1;
3799              
3800             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3801              
3802             # avoid "Error: Runtime exception" of perl version 5.005_03
3803 410 50       1026 # (and so on)
3804 410         986  
3805 0         0 if (/\G (\#) /oxgc) { # q# #
3806 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3807 0         0 while (not /\G \z/oxgc) {
3808 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3809 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3810             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3811 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3812             }
3813             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3814             }
3815 0         0  
3816 410         662 else {
3817 410 50       1082 my $e = '';
  410 50       1871  
    100          
    50          
    100          
    50          
3818             while (not /\G \z/oxgc) {
3819             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3820              
3821 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3822 0         0 elsif (/\G (\() /oxgc) { # q ( )
3823 0         0 my $q_string = '';
3824 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3825 0         0 while (not /\G \z/oxgc) {
3826 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3827 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3828             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3829 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3830 0         0 elsif (/\G (\)) /oxgc) {
3831             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3832 0         0 else { $q_string .= $1; }
3833             }
3834 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3835             }
3836             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3837             }
3838              
3839 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3840 404         626 elsif (/\G (\{) /oxgc) { # q { }
3841 404         677 my $q_string = '';
3842 404 50       989 local $nest = 1;
  6770 50       23559  
    50          
    100          
    100          
    50          
3843 0         0 while (not /\G \z/oxgc) {
3844 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3845 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         148  
3846             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3847 107 100       194 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         916  
3848 404         993 elsif (/\G (\}) /oxgc) {
3849             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3850 107         206 else { $q_string .= $1; }
3851             }
3852 6152         11230 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3853             }
3854             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3855             }
3856              
3857 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3858 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3859 0         0 my $q_string = '';
3860 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3861 0         0 while (not /\G \z/oxgc) {
3862 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3863 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3864             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3865 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3866 0         0 elsif (/\G (\]) /oxgc) {
3867             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3868 0         0 else { $q_string .= $1; }
3869             }
3870 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3871             }
3872             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873             }
3874              
3875 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3876 5         38 elsif (/\G (\<) /oxgc) { # q < >
3877 5         13 my $q_string = '';
3878 5 50       20 local $nest = 1;
  88 50       372  
    50          
    50          
    100          
    50          
3879 0         0 while (not /\G \z/oxgc) {
3880 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3881 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3882             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3883 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         15  
3884 5         16 elsif (/\G (\>) /oxgc) {
3885             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3886 0         0 else { $q_string .= $1; }
3887             }
3888 83         159 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3889             }
3890             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3891             }
3892              
3893 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3894 1         2 elsif (/\G (\S) /oxgc) { # q * *
3895 1         2 my $delimiter = $1;
3896 1 50       3 my $q_string = '';
  14 50       67  
    100          
    50          
3897 0         0 while (not /\G \z/oxgc) {
3898 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3899 1         11 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3900             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3901 13         24 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3902             }
3903             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3904 0         0 }
3905             }
3906             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3907             }
3908             }
3909              
3910 0         0 # m//
3911 209 50       478 elsif (/\G \b (m) \b /oxgc) {
3912 209         1242 my $ope = $1;
3913             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3914             return e_qr($ope,$1,$3,$2,$4);
3915 0         0 }
3916 209         305 else {
3917 209 50       503 my $e = '';
  209 50       10107  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3918 0         0 while (not /\G \z/oxgc) {
3919 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3920 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3921 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3922 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3923 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3924 10         25 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3925 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3926             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3927 199         617 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3928             }
3929             die __FILE__, ": Search pattern not terminated\n";
3930             }
3931             }
3932              
3933             # s///
3934              
3935             # about [cegimosxpradlunbB]* (/cg modifier)
3936             #
3937             # P.67 Pattern-Matching Operators
3938             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3939 0         0  
3940             elsif (/\G \b (s) \b /oxgc) {
3941             my $ope = $1;
3942 97 100       252  
3943 97         1550 # $1 $2 $3 $4 $5 $6
3944             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3945             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3946 1         5 }
3947 96         170 else {
3948 96 50       273 my $e = '';
  96 50       11158  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3949             while (not /\G \z/oxgc) {
3950 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3951 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3952 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3953             while (not /\G \z/oxgc) {
3954 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3955 0         0 # $1 $2 $3 $4
3956 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965             }
3966             die __FILE__, ": Substitution replacement not terminated\n";
3967 0         0 }
3968 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3969 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3970             while (not /\G \z/oxgc) {
3971 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3972 0         0 # $1 $2 $3 $4
3973 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982             }
3983             die __FILE__, ": Substitution replacement not terminated\n";
3984 0         0 }
3985 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3986 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3987             while (not /\G \z/oxgc) {
3988 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3989 0         0 # $1 $2 $3 $4
3990 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3991 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3992 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3993 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3994 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3995             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3996 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3997             }
3998             die __FILE__, ": Substitution replacement not terminated\n";
3999 0         0 }
4000 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
4001 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4002             while (not /\G \z/oxgc) {
4003 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
4004 0         0 # $1 $2 $3 $4
4005 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4006 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4007 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4008 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4009 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4010 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4011 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4012             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4013 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
4014             }
4015             die __FILE__, ": Substitution replacement not terminated\n";
4016             }
4017 0         0 # $1 $2 $3 $4 $5 $6
4018             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
4019             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4020             }
4021 21         58 # $1 $2 $3 $4 $5 $6
4022             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4023             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
4024             }
4025 0         0 # $1 $2 $3 $4 $5 $6
4026             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4027             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4028             }
4029 0         0 # $1 $2 $3 $4 $5 $6
4030             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4031             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4032 75         310 }
4033             }
4034             die __FILE__, ": Substitution pattern not terminated\n";
4035             }
4036             }
4037 0         0  
4038 0         0 # require ignore module
4039 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4040             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4041             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4042 0         0  
4043 37         325 # use strict; --> use strict; no strict qw(refs);
4044 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4045             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4046             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4047              
4048 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4049 2         20 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4050             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4051             return "use $1; no strict qw(refs);";
4052 0         0 }
4053             else {
4054             return "use $1;";
4055             }
4056 2 0 0     10 }
      0        
4057 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4058             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4059             return "use $1; no strict qw(refs);";
4060 0         0 }
4061             else {
4062             return "use $1;";
4063             }
4064             }
4065 0         0  
4066 2         13 # ignore use module
4067 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4068             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4069             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4070 0         0  
4071 0         0 # ignore no module
4072 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4073             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4074             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4075 0         0  
4076             # use else
4077             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4078 0         0  
4079             # use else
4080             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4081              
4082 2         9 # ''
4083 848         1598 elsif (/\G (?
4084 848 100       2083 my $q_string = '';
  8254 100       23719  
    100          
    50          
4085 4         11 while (not /\G \z/oxgc) {
4086 48         110 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4087 848         1785 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4088             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4089 7354         13776 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4090             }
4091             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4092             }
4093              
4094 0         0 # ""
4095 1852         3283 elsif (/\G (\") /oxgc) {
4096 1852 100       4089 my $qq_string = '';
  35441 100       92137  
    100          
    50          
4097 67         150 while (not /\G \z/oxgc) {
4098 12         34 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4099 1852         3926 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4100             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4101 33510         61390 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4102             }
4103             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4104             }
4105              
4106 0         0 # ``
4107 1         3 elsif (/\G (\`) /oxgc) {
4108 1 50       4 my $qx_string = '';
  19 50       65  
    100          
    50          
4109 0         0 while (not /\G \z/oxgc) {
4110 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4111 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4112             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4113 18         34 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4114             }
4115             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4116             }
4117              
4118 0         0 # // --- not divide operator (num / num), not defined-or
4119 453         1074 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4120 453 50       1241 my $regexp = '';
  4496 50       14056  
    100          
    50          
4121 0         0 while (not /\G \z/oxgc) {
4122 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4123 453         1151 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4124             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4125 4043         7822 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4126             }
4127             die __FILE__, ": Search pattern not terminated\n";
4128             }
4129              
4130 0         0 # ?? --- not conditional operator (condition ? then : else)
4131 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4132 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4133 0         0 while (not /\G \z/oxgc) {
4134 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4135 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4136             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4137 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4138             }
4139             die __FILE__, ": Search pattern not terminated\n";
4140             }
4141 0         0  
  0         0  
4142             # <<>> (a safer ARGV)
4143             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4144 0         0  
  0         0  
4145             # << (bit shift) --- not here document
4146             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4147              
4148 0         0 # <<~'HEREDOC'
4149 6         13 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4150 6         10 $slash = 'm//';
4151             my $here_quote = $1;
4152             my $delimiter = $2;
4153 6 50       7  
4154 6         12 # get here document
4155 6         21 if ($here_script eq '') {
4156             $here_script = CORE::substr $_, pos $_;
4157 6 50       26 $here_script =~ s/.*?\n//oxm;
4158 6         58 }
4159 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4160 6         9 my $heredoc = $1;
4161 6         44 my $indent = $2;
4162 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4163             push @heredoc, $heredoc . qq{\n$delimiter\n};
4164             push @heredoc_delimiter, qq{\\s*$delimiter};
4165 6         9 }
4166             else {
4167 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4168             }
4169             return qq{<<'$delimiter'};
4170             }
4171              
4172             # <<~\HEREDOC
4173              
4174             # P.66 2.6.6. "Here" Documents
4175             # in Chapter 2: Bits and Pieces
4176             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4177              
4178             # P.73 "Here" Documents
4179             # in Chapter 2: Bits and Pieces
4180             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4181 6         22  
4182 3         6 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4183 3         6 $slash = 'm//';
4184             my $here_quote = $1;
4185             my $delimiter = $2;
4186 3 50       5  
4187 3         6 # get here document
4188 3         32 if ($here_script eq '') {
4189             $here_script = CORE::substr $_, pos $_;
4190 3 50       17 $here_script =~ s/.*?\n//oxm;
4191 3         40 }
4192 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4193 3         4 my $heredoc = $1;
4194 3         34 my $indent = $2;
4195 3         9 $heredoc =~ s{^$indent}{}msg; # no /ox
4196             push @heredoc, $heredoc . qq{\n$delimiter\n};
4197             push @heredoc_delimiter, qq{\\s*$delimiter};
4198 3         7 }
4199             else {
4200 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4201             }
4202             return qq{<<\\$delimiter};
4203             }
4204              
4205 3         12 # <<~"HEREDOC"
4206 6         11 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4207 6         11 $slash = 'm//';
4208             my $here_quote = $1;
4209             my $delimiter = $2;
4210 6 50       8  
4211 6         11 # get here document
4212 6         24 if ($here_script eq '') {
4213             $here_script = CORE::substr $_, pos $_;
4214 6 50       28 $here_script =~ s/.*?\n//oxm;
4215 6         64 }
4216 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4217 6         10 my $heredoc = $1;
4218 6         50 my $indent = $2;
4219 6         14 $heredoc =~ s{^$indent}{}msg; # no /ox
4220             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4221             push @heredoc_delimiter, qq{\\s*$delimiter};
4222 6         19 }
4223             else {
4224 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4225             }
4226             return qq{<<"$delimiter"};
4227             }
4228              
4229 6         34 # <<~HEREDOC
4230 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4231 3         6 $slash = 'm//';
4232             my $here_quote = $1;
4233             my $delimiter = $2;
4234 3 50       5  
4235 3         7 # get here document
4236 3         11 if ($here_script eq '') {
4237             $here_script = CORE::substr $_, pos $_;
4238 3 50       27 $here_script =~ s/.*?\n//oxm;
4239 3         43 }
4240 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4241 3         5 my $heredoc = $1;
4242 3         38 my $indent = $2;
4243 3         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4244             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4245             push @heredoc_delimiter, qq{\\s*$delimiter};
4246 3         14 }
4247             else {
4248 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4249             }
4250             return qq{<<$delimiter};
4251             }
4252              
4253 3         12 # <<~`HEREDOC`
4254 6         11 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4255 6         11 $slash = 'm//';
4256             my $here_quote = $1;
4257             my $delimiter = $2;
4258 6 50       21  
4259 6         17 # get here document
4260 6         23 if ($here_script eq '') {
4261             $here_script = CORE::substr $_, pos $_;
4262 6 50       31 $here_script =~ s/.*?\n//oxm;
4263 6         60 }
4264 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4265 6         8 my $heredoc = $1;
4266 6         48 my $indent = $2;
4267 6         14 $heredoc =~ s{^$indent}{}msg; # no /ox
4268             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4269             push @heredoc_delimiter, qq{\\s*$delimiter};
4270 6         12 }
4271             else {
4272 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4273             }
4274             return qq{<<`$delimiter`};
4275             }
4276              
4277 6         24 # <<'HEREDOC'
4278 72         136 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4279 72         138 $slash = 'm//';
4280             my $here_quote = $1;
4281             my $delimiter = $2;
4282 72 50       101  
4283 72         131 # get here document
4284 72         363 if ($here_script eq '') {
4285             $here_script = CORE::substr $_, pos $_;
4286 72 50       429 $here_script =~ s/.*?\n//oxm;
4287 72         507 }
4288 72         225 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4289             push @heredoc, $1 . qq{\n$delimiter\n};
4290             push @heredoc_delimiter, $delimiter;
4291 72         135 }
4292             else {
4293 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4294             }
4295             return $here_quote;
4296             }
4297              
4298             # <<\HEREDOC
4299              
4300             # P.66 2.6.6. "Here" Documents
4301             # in Chapter 2: Bits and Pieces
4302             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4303              
4304             # P.73 "Here" Documents
4305             # in Chapter 2: Bits and Pieces
4306             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4307 72         289  
4308 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4309 0         0 $slash = 'm//';
4310             my $here_quote = $1;
4311             my $delimiter = $2;
4312 0 0       0  
4313 0         0 # get here document
4314 0         0 if ($here_script eq '') {
4315             $here_script = CORE::substr $_, pos $_;
4316 0 0       0 $here_script =~ s/.*?\n//oxm;
4317 0         0 }
4318 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4319             push @heredoc, $1 . qq{\n$delimiter\n};
4320             push @heredoc_delimiter, $delimiter;
4321 0         0 }
4322             else {
4323 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4324             }
4325             return $here_quote;
4326             }
4327              
4328 0         0 # <<"HEREDOC"
4329 36         81 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4330 36         76 $slash = 'm//';
4331             my $here_quote = $1;
4332             my $delimiter = $2;
4333 36 50       428  
4334 36         100 # get here document
4335 36         245 if ($here_script eq '') {
4336             $here_script = CORE::substr $_, pos $_;
4337 36 50       229 $here_script =~ s/.*?\n//oxm;
4338 36         754 }
4339 36         110 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4340             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4341             push @heredoc_delimiter, $delimiter;
4342 36         135 }
4343             else {
4344 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4345             }
4346             return $here_quote;
4347             }
4348              
4349 36         157 # <
4350 42         96 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4351 42         84 $slash = 'm//';
4352             my $here_quote = $1;
4353             my $delimiter = $2;
4354 42 50       73  
4355 42         92 # get here document
4356 42         305 if ($here_script eq '') {
4357             $here_script = CORE::substr $_, pos $_;
4358 42 50       375 $here_script =~ s/.*?\n//oxm;
4359 42         553 }
4360 42         145 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4361             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4362             push @heredoc_delimiter, $delimiter;
4363 42         97 }
4364             else {
4365 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4366             }
4367             return $here_quote;
4368             }
4369              
4370 42         175 # <<`HEREDOC`
4371 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4372 0         0 $slash = 'm//';
4373             my $here_quote = $1;
4374             my $delimiter = $2;
4375 0 0       0  
4376 0         0 # get here document
4377 0         0 if ($here_script eq '') {
4378             $here_script = CORE::substr $_, pos $_;
4379 0 0       0 $here_script =~ s/.*?\n//oxm;
4380 0         0 }
4381 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4382             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4383             push @heredoc_delimiter, $delimiter;
4384 0         0 }
4385             else {
4386 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4387             }
4388             return $here_quote;
4389             }
4390              
4391 0         0 # <<= <=> <= < operator
4392             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4393             return $1;
4394             }
4395              
4396 12         58 #
4397             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4398             return $1;
4399             }
4400              
4401             # --- glob
4402              
4403             # avoid "Error: Runtime exception" of perl version 5.005_03
4404 0         0  
4405             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4406             return 'Elatin8::glob("' . $1 . '")';
4407             }
4408 0         0  
4409             # __DATA__
4410             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4411 0         0  
4412             # __END__
4413             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4414              
4415             # \cD Control-D
4416              
4417             # P.68 2.6.8. Other Literal Tokens
4418             # in Chapter 2: Bits and Pieces
4419             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4420              
4421             # P.76 Other Literal Tokens
4422             # in Chapter 2: Bits and Pieces
4423 204         1400 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4424              
4425             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4426 0         0  
4427             # \cZ Control-Z
4428             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4429              
4430             # any operator before div
4431             elsif (/\G (
4432             -- | \+\+ |
4433 0         0 [\)\}\]]
  5084         9459  
4434              
4435             ) /oxgc) { $slash = 'div'; return $1; }
4436              
4437             # yada-yada or triple-dot operator
4438             elsif (/\G (
4439 5084         21097 \.\.\.
  7         11  
4440              
4441             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4442              
4443             # any operator before m//
4444              
4445             # //, //= (defined-or)
4446              
4447             # P.164 Logical Operators
4448             # in Chapter 10: More Control Structures
4449             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4450              
4451             # P.119 C-Style Logical (Short-Circuit) Operators
4452             # in Chapter 3: Unary and Binary Operators
4453             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4454              
4455             # (and so on)
4456              
4457             # ~~
4458              
4459             # P.221 The Smart Match Operator
4460             # in Chapter 15: Smart Matching and given-when
4461             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4462              
4463             # P.112 Smartmatch Operator
4464             # in Chapter 3: Unary and Binary Operators
4465             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4466              
4467             # (and so on)
4468              
4469             elsif (/\G ((?>
4470              
4471             !~~ | !~ | != | ! |
4472             %= | % |
4473             &&= | && | &= | &\.= | &\. | & |
4474             -= | -> | - |
4475             :(?>\s*)= |
4476             : |
4477             <<>> |
4478             <<= | <=> | <= | < |
4479             == | => | =~ | = |
4480             >>= | >> | >= | > |
4481             \*\*= | \*\* | \*= | \* |
4482             \+= | \+ |
4483             \.\. | \.= | \. |
4484             \/\/= | \/\/ |
4485             \/= | \/ |
4486             \? |
4487             \\ |
4488             \^= | \^\.= | \^\. | \^ |
4489             \b x= |
4490             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4491             ~~ | ~\. | ~ |
4492             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4493             \b(?: print )\b |
4494              
4495 7         23 [,;\(\{\[]
  8882         16057  
4496              
4497             )) /oxgc) { $slash = 'm//'; return $1; }
4498 8882         36480  
  15168         25906  
4499             # other any character
4500             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4501              
4502 15168         61747 # system error
4503             else {
4504             die __FILE__, ": Oops, this shouldn't happen!\n";
4505             }
4506             }
4507              
4508 0     1789 0 0 # escape Latin-8 string
4509 1789         3918 sub e_string {
4510             my($string) = @_;
4511 1789         2411 my $e_string = '';
4512              
4513             local $slash = 'm//';
4514              
4515             # P.1024 Appendix W.10 Multibyte Processing
4516             # of ISBN 1-56592-224-7 CJKV Information Processing
4517 1789         2370 # (and so on)
4518              
4519             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4520 1789 100 66     12777  
4521 1789 50       7117 # without { ... }
4522 1769         3516 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4523             if ($string !~ /<
4524             return $string;
4525             }
4526             }
4527 1769         4082  
4528 20 50       60 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
4529             while ($string !~ /\G \z/oxgc) {
4530             if (0) {
4531             }
4532 237         3610  
4533 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin8::PREMATCH()]}
4534 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4535             $e_string .= q{Elatin8::PREMATCH()};
4536             $slash = 'div';
4537             }
4538              
4539 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin8::MATCH()]}
4540 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4541             $e_string .= q{Elatin8::MATCH()};
4542             $slash = 'div';
4543             }
4544              
4545 0         0 # $', ${'} --> $', ${'}
4546 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4547             $e_string .= $1;
4548             $slash = 'div';
4549             }
4550              
4551 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin8::POSTMATCH()]}
4552 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4553             $e_string .= q{Elatin8::POSTMATCH()};
4554             $slash = 'div';
4555             }
4556              
4557 0         0 # bareword
4558 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4559             $e_string .= $1;
4560             $slash = 'div';
4561             }
4562              
4563 0         0 # $0 --> $0
4564 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4565             $e_string .= $1;
4566             $slash = 'div';
4567 0         0 }
4568 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4569             $e_string .= $1;
4570             $slash = 'div';
4571             }
4572              
4573 0         0 # $$ --> $$
4574 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4575             $e_string .= $1;
4576             $slash = 'div';
4577             }
4578              
4579             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4580 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4581 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4582             $e_string .= e_capture($1);
4583             $slash = 'div';
4584 0         0 }
4585 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4586             $e_string .= e_capture($1);
4587             $slash = 'div';
4588             }
4589              
4590 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4591 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4592             $e_string .= e_capture($1.'->'.$2);
4593             $slash = 'div';
4594             }
4595              
4596 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4597 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4598             $e_string .= e_capture($1.'->'.$2);
4599             $slash = 'div';
4600             }
4601              
4602 0         0 # $$foo
4603 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4604             $e_string .= e_capture($1);
4605             $slash = 'div';
4606             }
4607              
4608 0         0 # ${ foo }
4609 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4610             $e_string .= '${' . $1 . '}';
4611             $slash = 'div';
4612             }
4613              
4614 0         0 # ${ ... }
4615 3         8 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4616             $e_string .= e_capture($1);
4617             $slash = 'div';
4618             }
4619              
4620             # variable or function
4621 3         13 # $ @ % & * $ #
4622 7         23 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) {
4623             $e_string .= $1;
4624             $slash = 'div';
4625             }
4626             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4627 7         21 # $ @ # \ ' " / ? ( ) [ ] < >
4628 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4629             $e_string .= $1;
4630             $slash = 'div';
4631             }
4632              
4633 0         0 # qq//
4634 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4635 0         0 my $ope = $1;
4636             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4637             $e_string .= e_qq($ope,$1,$3,$2);
4638 0         0 }
4639 0         0 else {
4640 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4641 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4642 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4643 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4644 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4645 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4646             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4647 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4648             }
4649             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4650             }
4651             }
4652              
4653 0         0 # qx//
4654 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4655 0         0 my $ope = $1;
4656             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4657             $e_string .= e_qq($ope,$1,$3,$2);
4658 0         0 }
4659 0         0 else {
4660 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4661 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4662 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4663 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4664 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4665 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4666 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4667             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4668 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4669             }
4670             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4671             }
4672             }
4673              
4674 0         0 # q//
4675 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4676 0         0 my $ope = $1;
4677             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4678             $e_string .= e_q($ope,$1,$3,$2);
4679 0         0 }
4680 0         0 else {
4681 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4682 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4683 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4684 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4685 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4686 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4687             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4688 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 * *
4689             }
4690             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4691             }
4692             }
4693 0         0  
4694             # ''
4695             elsif ($string =~ /\G (?
4696 0         0  
4697             # ""
4698             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4699 0         0  
4700             # ``
4701             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4702 0         0  
4703             # other any character
4704             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4705              
4706 227         518 # system error
4707             else {
4708             die __FILE__, ": Oops, this shouldn't happen!\n";
4709             }
4710 0         0 }
4711              
4712             return $e_string;
4713             }
4714              
4715             #
4716             # character class
4717 20     1919 0 74 #
4718             sub character_class {
4719 1919 100       3154 my($char,$modifier) = @_;
4720 1919 100       2804  
4721 52         97 if ($char eq '.') {
4722             if ($modifier =~ /s/) {
4723             return '${Elatin8::dot_s}';
4724 17         36 }
4725             else {
4726             return '${Elatin8::dot}';
4727             }
4728 35         67 }
4729             else {
4730             return Elatin8::classic_character_class($char);
4731             }
4732             }
4733              
4734             #
4735             # escape capture ($1, $2, $3, ...)
4736             #
4737 1867     212 0 3052 sub e_capture {
4738              
4739             return join '', '${', $_[0], '}';
4740             }
4741              
4742             #
4743             # escape transliteration (tr/// or y///)
4744 212     3 0 706 #
4745 3         17 sub e_tr {
4746 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4747             my $e_tr = '';
4748 3         5 $modifier ||= '';
4749              
4750             $slash = 'div';
4751 3         4  
4752             # quote character class 1
4753             $charclass = q_tr($charclass);
4754 3         6  
4755             # quote character class 2
4756             $charclass2 = q_tr($charclass2);
4757 3 50       5  
4758 3 0       14 # /b /B modifier
4759 0         0 if ($modifier =~ tr/bB//d) {
4760             if ($variable eq '') {
4761             $e_tr = qq{tr$charclass$e$charclass2$modifier};
4762 0         0 }
4763             else {
4764             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4765             }
4766 0 100       0 }
4767 3         5 else {
4768             if ($variable eq '') {
4769             $e_tr = qq{Elatin8::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4770 2         7 }
4771             else {
4772             $e_tr = qq{Elatin8::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4773             }
4774             }
4775 1         5  
4776 3         4 # clear tr/// variable
4777             $tr_variable = '';
4778 3         4 $bind_operator = '';
4779              
4780             return $e_tr;
4781             }
4782              
4783             #
4784             # quote for escape transliteration (tr/// or y///)
4785 3     6 0 16 #
4786             sub q_tr {
4787             my($charclass) = @_;
4788 6 50       7  
    0          
    0          
    0          
    0          
    0          
4789 6         13 # quote character class
4790             if ($charclass !~ /'/oxms) {
4791             return e_q('', "'", "'", $charclass); # --> q' '
4792 6         8 }
4793             elsif ($charclass !~ /\//oxms) {
4794             return e_q('q', '/', '/', $charclass); # --> q/ /
4795 0         0 }
4796             elsif ($charclass !~ /\#/oxms) {
4797             return e_q('q', '#', '#', $charclass); # --> q# #
4798 0         0 }
4799             elsif ($charclass !~ /[\<\>]/oxms) {
4800             return e_q('q', '<', '>', $charclass); # --> q< >
4801 0         0 }
4802             elsif ($charclass !~ /[\(\)]/oxms) {
4803             return e_q('q', '(', ')', $charclass); # --> q( )
4804 0         0 }
4805             elsif ($charclass !~ /[\{\}]/oxms) {
4806             return e_q('q', '{', '}', $charclass); # --> q{ }
4807 0         0 }
4808 0 0       0 else {
4809 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4810             if ($charclass !~ /\Q$char\E/xms) {
4811             return e_q('q', $char, $char, $charclass);
4812             }
4813             }
4814 0         0 }
4815              
4816             return e_q('q', '{', '}', $charclass);
4817             }
4818              
4819             #
4820             # escape q string (q//, '')
4821 0     1264 0 0 #
4822             sub e_q {
4823 1264         2731 my($ope,$delimiter,$end_delimiter,$string) = @_;
4824              
4825 1264         1608 $slash = 'div';
4826              
4827             return join '', $ope, $delimiter, $string, $end_delimiter;
4828             }
4829              
4830             #
4831             # escape qq string (qq//, "", qx//, ``)
4832 1264     4114 0 5635 #
4833             sub e_qq {
4834 4114         8472 my($ope,$delimiter,$end_delimiter,$string) = @_;
4835              
4836 4114         5065 $slash = 'div';
4837 4114         4472  
4838             my $left_e = 0;
4839             my $right_e = 0;
4840 4114         4208  
4841             # split regexp
4842             my @char = $string =~ /\G((?>
4843             [^\\\$] |
4844             \\x\{ (?>[0-9A-Fa-f]+) \} |
4845             \\o\{ (?>[0-7]+) \} |
4846             \\N\{ (?>[^0-9\}][^\}]*) \} |
4847             \\ $q_char |
4848             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
4849             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
4850             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
4851             \$ (?>\s* [0-9]+) |
4852             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
4853             \$ \$ (?![\w\{]) |
4854             \$ (?>\s*) \$ (?>\s*) $qq_variable |
4855             $q_char
4856 4114         124764 ))/oxmsg;
4857              
4858             for (my $i=0; $i <= $#char; $i++) {
4859 4114 50 33     12176  
    50 33        
    100          
    100          
    50          
4860 113997         333526 # "\L\u" --> "\u\L"
4861             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
4862             @char[$i,$i+1] = @char[$i+1,$i];
4863             }
4864              
4865 0         0 # "\U\l" --> "\l\U"
4866             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
4867             @char[$i,$i+1] = @char[$i+1,$i];
4868             }
4869              
4870 0         0 # octal escape sequence
4871             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
4872             $char[$i] = Elatin8::octchr($1);
4873             }
4874              
4875 1         2 # hexadecimal escape sequence
4876             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
4877             $char[$i] = Elatin8::hexchr($1);
4878             }
4879              
4880 1         3 # \N{CHARNAME} --> N{CHARNAME}
4881             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4882             $char[$i] = $1;
4883 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
4884              
4885             if (0) {
4886             }
4887              
4888             # \F
4889             #
4890             # P.69 Table 2-6. Translation escapes
4891             # in Chapter 2: Bits and Pieces
4892             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4893             # (and so on)
4894 113997         831193  
4895 0 50       0 # \u \l \U \L \F \Q \E
4896 484         950 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
4897             if ($right_e < $left_e) {
4898             $char[$i] = '\\' . $char[$i];
4899             }
4900             }
4901             elsif ($char[$i] eq '\u') {
4902              
4903             # "STRING @{[ LIST EXPR ]} MORE STRING"
4904              
4905             # P.257 Other Tricks You Can Do with Hard References
4906             # in Chapter 8: References
4907             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4908              
4909             # P.353 Other Tricks You Can Do with Hard References
4910             # in Chapter 8: References
4911             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4912              
4913 0         0 # (and so on)
4914 0         0  
4915             $char[$i] = '@{[Elatin8::ucfirst qq<';
4916             $left_e++;
4917 0         0 }
4918 0         0 elsif ($char[$i] eq '\l') {
4919             $char[$i] = '@{[Elatin8::lcfirst qq<';
4920             $left_e++;
4921 0         0 }
4922 0         0 elsif ($char[$i] eq '\U') {
4923             $char[$i] = '@{[Elatin8::uc qq<';
4924             $left_e++;
4925 0         0 }
4926 0         0 elsif ($char[$i] eq '\L') {
4927             $char[$i] = '@{[Elatin8::lc qq<';
4928             $left_e++;
4929 0         0 }
4930 24         34 elsif ($char[$i] eq '\F') {
4931             $char[$i] = '@{[Elatin8::fc qq<';
4932             $left_e++;
4933 24         46 }
4934 0         0 elsif ($char[$i] eq '\Q') {
4935             $char[$i] = '@{[CORE::quotemeta qq<';
4936             $left_e++;
4937 0 50       0 }
4938 24         36 elsif ($char[$i] eq '\E') {
4939 24         29 if ($right_e < $left_e) {
4940             $char[$i] = '>]}';
4941             $right_e++;
4942 24         45 }
4943             else {
4944             $char[$i] = '';
4945             }
4946 0         0 }
4947 0 0       0 elsif ($char[$i] eq '\Q') {
4948 0         0 while (1) {
4949             if (++$i > $#char) {
4950 0 0       0 last;
4951 0         0 }
4952             if ($char[$i] eq '\E') {
4953             last;
4954             }
4955             }
4956             }
4957             elsif ($char[$i] eq '\E') {
4958             }
4959              
4960             # $0 --> $0
4961             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
4962             }
4963             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
4964             }
4965              
4966             # $$ --> $$
4967             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
4968             }
4969              
4970             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4971 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4972             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
4973             $char[$i] = e_capture($1);
4974 205         352 }
4975             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
4976             $char[$i] = e_capture($1);
4977             }
4978              
4979 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4980             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
4981             $char[$i] = e_capture($1.'->'.$2);
4982             }
4983              
4984 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4985             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
4986             $char[$i] = e_capture($1.'->'.$2);
4987             }
4988              
4989 0         0 # $$foo
4990             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
4991             $char[$i] = e_capture($1);
4992             }
4993              
4994 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
4995             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
4996             $char[$i] = '@{[Elatin8::PREMATCH()]}';
4997             }
4998              
4999 44         110 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5000             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5001             $char[$i] = '@{[Elatin8::MATCH()]}';
5002             }
5003              
5004 45         121 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5005             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5006             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
5007             }
5008              
5009             # ${ foo } --> ${ foo }
5010             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5011             }
5012              
5013 33         81 # ${ ... }
5014             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5015             $char[$i] = e_capture($1);
5016             }
5017             }
5018 0 50       0  
5019 4114         7141 # return string
5020             if ($left_e > $right_e) {
5021 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5022             }
5023             return join '', $ope, $delimiter, @char, $end_delimiter;
5024             }
5025              
5026             #
5027             # escape qw string (qw//)
5028 4114     16 0 30107 #
5029             sub e_qw {
5030 16         124 my($ope,$delimiter,$end_delimiter,$string) = @_;
5031              
5032             $slash = 'div';
5033 16         37  
  16         220  
5034 483 50       696 # choice again delimiter
    0          
    0          
    0          
    0          
5035 16         94 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5036             if (not $octet{$end_delimiter}) {
5037             return join '', $ope, $delimiter, $string, $end_delimiter;
5038 16         112 }
5039             elsif (not $octet{')'}) {
5040             return join '', $ope, '(', $string, ')';
5041 0         0 }
5042             elsif (not $octet{'}'}) {
5043             return join '', $ope, '{', $string, '}';
5044 0         0 }
5045             elsif (not $octet{']'}) {
5046             return join '', $ope, '[', $string, ']';
5047 0         0 }
5048             elsif (not $octet{'>'}) {
5049             return join '', $ope, '<', $string, '>';
5050 0         0 }
5051 0 0       0 else {
5052 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5053             if (not $octet{$char}) {
5054             return join '', $ope, $char, $string, $char;
5055             }
5056             }
5057             }
5058 0         0  
5059 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5060 0         0 my @string = CORE::split(/\s+/, $string);
5061 0         0 for my $string (@string) {
5062 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5063 0         0 for my $octet (@octet) {
5064             if ($octet =~ /\A (['\\]) \z/oxms) {
5065             $octet = '\\' . $1;
5066 0         0 }
5067             }
5068 0         0 $string = join '', @octet;
  0         0  
5069             }
5070             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5071             }
5072              
5073             #
5074             # escape here document (<<"HEREDOC", <
5075 0     93 0 0 #
5076             sub e_heredoc {
5077 93         231 my($string) = @_;
5078              
5079 93         178 $slash = 'm//';
5080              
5081 93         338 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5082 93         163  
5083             my $left_e = 0;
5084             my $right_e = 0;
5085 93         106  
5086             # split regexp
5087             my @char = $string =~ /\G((?>
5088             [^\\\$] |
5089             \\x\{ (?>[0-9A-Fa-f]+) \} |
5090             \\o\{ (?>[0-7]+) \} |
5091             \\N\{ (?>[^0-9\}][^\}]*) \} |
5092             \\ $q_char |
5093             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5094             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5095             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5096             \$ (?>\s* [0-9]+) |
5097             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5098             \$ \$ (?![\w\{]) |
5099             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5100             $q_char
5101 93         8204 ))/oxmsg;
5102              
5103             for (my $i=0; $i <= $#char; $i++) {
5104 93 50 33     415  
    50 33        
    100          
    100          
    50          
5105 3177         9036 # "\L\u" --> "\u\L"
5106             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5107             @char[$i,$i+1] = @char[$i+1,$i];
5108             }
5109              
5110 0         0 # "\U\l" --> "\l\U"
5111             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5112             @char[$i,$i+1] = @char[$i+1,$i];
5113             }
5114              
5115 0         0 # octal escape sequence
5116             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5117             $char[$i] = Elatin8::octchr($1);
5118             }
5119              
5120 1         3 # hexadecimal escape sequence
5121             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5122             $char[$i] = Elatin8::hexchr($1);
5123             }
5124              
5125 1         3 # \N{CHARNAME} --> N{CHARNAME}
5126             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5127             $char[$i] = $1;
5128 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5129              
5130             if (0) {
5131             }
5132 3177         24916  
5133 0 0       0 # \u \l \U \L \F \Q \E
5134 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5135             if ($right_e < $left_e) {
5136             $char[$i] = '\\' . $char[$i];
5137             }
5138 0         0 }
5139 0         0 elsif ($char[$i] eq '\u') {
5140             $char[$i] = '@{[Elatin8::ucfirst qq<';
5141             $left_e++;
5142 0         0 }
5143 0         0 elsif ($char[$i] eq '\l') {
5144             $char[$i] = '@{[Elatin8::lcfirst qq<';
5145             $left_e++;
5146 0         0 }
5147 0         0 elsif ($char[$i] eq '\U') {
5148             $char[$i] = '@{[Elatin8::uc qq<';
5149             $left_e++;
5150 0         0 }
5151 0         0 elsif ($char[$i] eq '\L') {
5152             $char[$i] = '@{[Elatin8::lc qq<';
5153             $left_e++;
5154 0         0 }
5155 0         0 elsif ($char[$i] eq '\F') {
5156             $char[$i] = '@{[Elatin8::fc qq<';
5157             $left_e++;
5158 0         0 }
5159 0         0 elsif ($char[$i] eq '\Q') {
5160             $char[$i] = '@{[CORE::quotemeta qq<';
5161             $left_e++;
5162 0 0       0 }
5163 0         0 elsif ($char[$i] eq '\E') {
5164 0         0 if ($right_e < $left_e) {
5165             $char[$i] = '>]}';
5166             $right_e++;
5167 0         0 }
5168             else {
5169             $char[$i] = '';
5170             }
5171 0         0 }
5172 0 0       0 elsif ($char[$i] eq '\Q') {
5173 0         0 while (1) {
5174             if (++$i > $#char) {
5175 0 0       0 last;
5176 0         0 }
5177             if ($char[$i] eq '\E') {
5178             last;
5179             }
5180             }
5181             }
5182             elsif ($char[$i] eq '\E') {
5183             }
5184              
5185             # $0 --> $0
5186             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5187             }
5188             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5189             }
5190              
5191             # $$ --> $$
5192             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5193             }
5194              
5195             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5196 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5197             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5198             $char[$i] = e_capture($1);
5199 0         0 }
5200             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5201             $char[$i] = e_capture($1);
5202             }
5203              
5204 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5205             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5206             $char[$i] = e_capture($1.'->'.$2);
5207             }
5208              
5209 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5210             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5211             $char[$i] = e_capture($1.'->'.$2);
5212             }
5213              
5214 0         0 # $$foo
5215             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5216             $char[$i] = e_capture($1);
5217             }
5218              
5219 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5220             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5221             $char[$i] = '@{[Elatin8::PREMATCH()]}';
5222             }
5223              
5224 8         46 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5225             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5226             $char[$i] = '@{[Elatin8::MATCH()]}';
5227             }
5228              
5229 8         44 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5230             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5231             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
5232             }
5233              
5234             # ${ foo } --> ${ foo }
5235             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5236             }
5237              
5238 6         30 # ${ ... }
5239             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5240             $char[$i] = e_capture($1);
5241             }
5242             }
5243 0 50       0  
5244 93         193 # return string
5245             if ($left_e > $right_e) {
5246 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5247             }
5248             return join '', @char;
5249             }
5250              
5251             #
5252             # escape regexp (m//, qr//)
5253 93     652 0 720 #
5254 652   100     2790 sub e_qr {
5255             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5256 652         2401 $modifier ||= '';
5257 652 50       1055  
5258 652         1357 $modifier =~ tr/p//d;
5259 0         0 if ($modifier =~ /([adlu])/oxms) {
5260 0 0       0 my $line = 0;
5261 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5262 0         0 if ($filename ne __FILE__) {
5263             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5264             last;
5265 0         0 }
5266             }
5267             die qq{Unsupported modifier "$1" used at line $line.\n};
5268 0         0 }
5269              
5270             $slash = 'div';
5271 652 100       924  
    100          
5272 652         1762 # literal null string pattern
5273 8         12 if ($string eq '') {
5274 8         9 $modifier =~ tr/bB//d;
5275             $modifier =~ tr/i//d;
5276             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5277             }
5278              
5279             # /b /B modifier
5280             elsif ($modifier =~ tr/bB//d) {
5281 8 50       35  
5282 2         8 # choice again delimiter
5283 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5284 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5285 0         0 my %octet = map {$_ => 1} @char;
5286 0         0 if (not $octet{')'}) {
5287             $delimiter = '(';
5288             $end_delimiter = ')';
5289 0         0 }
5290 0         0 elsif (not $octet{'}'}) {
5291             $delimiter = '{';
5292             $end_delimiter = '}';
5293 0         0 }
5294 0         0 elsif (not $octet{']'}) {
5295             $delimiter = '[';
5296             $end_delimiter = ']';
5297 0         0 }
5298 0         0 elsif (not $octet{'>'}) {
5299             $delimiter = '<';
5300             $end_delimiter = '>';
5301 0         0 }
5302 0 0       0 else {
5303 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5304 0         0 if (not $octet{$char}) {
5305 0         0 $delimiter = $char;
5306             $end_delimiter = $char;
5307             last;
5308             }
5309             }
5310             }
5311 0 50 33     0 }
5312 2         11  
5313             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5314             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5315 0         0 }
5316             else {
5317             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5318             }
5319 2 100       10 }
5320 642         1331  
5321             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5322             my $metachar = qr/[\@\\|[\]{^]/oxms;
5323 642         2039  
5324             # split regexp
5325             my @char = $string =~ /\G((?>
5326             [^\\\$\@\[\(] |
5327             \\x (?>[0-9A-Fa-f]{1,2}) |
5328             \\ (?>[0-7]{2,3}) |
5329             \\c [\x40-\x5F] |
5330             \\x\{ (?>[0-9A-Fa-f]+) \} |
5331             \\o\{ (?>[0-7]+) \} |
5332             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5333             \\ $q_char |
5334             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5335             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5336             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5337             [\$\@] $qq_variable |
5338             \$ (?>\s* [0-9]+) |
5339             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5340             \$ \$ (?![\w\{]) |
5341             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5342             \[\^ |
5343             \[\: (?>[a-z]+) :\] |
5344             \[\:\^ (?>[a-z]+) :\] |
5345             \(\? |
5346             $q_char
5347             ))/oxmsg;
5348 642 50       59402  
5349 642         2471 # choice again delimiter
  0         0  
5350 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5351 0         0 my %octet = map {$_ => 1} @char;
5352 0         0 if (not $octet{')'}) {
5353             $delimiter = '(';
5354             $end_delimiter = ')';
5355 0         0 }
5356 0         0 elsif (not $octet{'}'}) {
5357             $delimiter = '{';
5358             $end_delimiter = '}';
5359 0         0 }
5360 0         0 elsif (not $octet{']'}) {
5361             $delimiter = '[';
5362             $end_delimiter = ']';
5363 0         0 }
5364 0         0 elsif (not $octet{'>'}) {
5365             $delimiter = '<';
5366             $end_delimiter = '>';
5367 0         0 }
5368 0 0       0 else {
5369 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5370 0         0 if (not $octet{$char}) {
5371 0         0 $delimiter = $char;
5372             $end_delimiter = $char;
5373             last;
5374             }
5375             }
5376             }
5377 0         0 }
5378 642         912  
5379 642         810 my $left_e = 0;
5380             my $right_e = 0;
5381             for (my $i=0; $i <= $#char; $i++) {
5382 642 50 66     1489  
    50 66        
    100          
    100          
    100          
    100          
5383 1872         8864 # "\L\u" --> "\u\L"
5384             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5385             @char[$i,$i+1] = @char[$i+1,$i];
5386             }
5387              
5388 0         0 # "\U\l" --> "\l\U"
5389             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5390             @char[$i,$i+1] = @char[$i+1,$i];
5391             }
5392              
5393 0         0 # octal escape sequence
5394             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5395             $char[$i] = Elatin8::octchr($1);
5396             }
5397              
5398 1         3 # hexadecimal escape sequence
5399             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5400             $char[$i] = Elatin8::hexchr($1);
5401             }
5402              
5403             # \b{...} --> b\{...}
5404             # \B{...} --> B\{...}
5405             # \N{CHARNAME} --> N\{CHARNAME}
5406             # \p{PROPERTY} --> p\{PROPERTY}
5407 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5408             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5409             $char[$i] = $1 . '\\' . $2;
5410             }
5411              
5412 6         19 # \p, \P, \X --> p, P, X
5413             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5414             $char[$i] = $1;
5415 4 100 100     10 }
    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          
5416              
5417             if (0) {
5418             }
5419 1872         4915  
5420 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5421 6         98 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5422             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)) {
5423             $char[$i] .= join '', splice @char, $i+1, 3;
5424 0         0 }
5425             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)) {
5426             $char[$i] .= join '', splice @char, $i+1, 2;
5427 0         0 }
5428             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)) {
5429             $char[$i] .= join '', splice @char, $i+1, 1;
5430             }
5431             }
5432              
5433 0         0 # open character class [...]
5434             elsif ($char[$i] eq '[') {
5435             my $left = $i;
5436              
5437             # [] make die "Unmatched [] in regexp ...\n"
5438 328 100       406 # (and so on)
5439 328         645  
5440             if ($char[$i+1] eq ']') {
5441             $i++;
5442 3         5 }
5443 328 50       495  
5444 1379         1910 while (1) {
5445             if (++$i > $#char) {
5446 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5447 1379         2076 }
5448             if ($char[$i] eq ']') {
5449             my $right = $i;
5450 328 100       383  
5451 328         1487 # [...]
  30         65  
5452             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5453             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5454 90         142 }
5455             else {
5456             splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
5457 298         940 }
5458 328         521  
5459             $i = $left;
5460             last;
5461             }
5462             }
5463             }
5464              
5465 328         773 # open character class [^...]
5466             elsif ($char[$i] eq '[^') {
5467             my $left = $i;
5468              
5469             # [^] make die "Unmatched [] in regexp ...\n"
5470 74 100       90 # (and so on)
5471 74         155  
5472             if ($char[$i+1] eq ']') {
5473             $i++;
5474 4         7 }
5475 74 50       86  
5476 272         390 while (1) {
5477             if (++$i > $#char) {
5478 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5479 272         465 }
5480             if ($char[$i] eq ']') {
5481             my $right = $i;
5482 74 100       110  
5483 74         353 # [^...]
  30         51  
5484             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5485             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5486 90         148 }
5487             else {
5488             splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5489 44         153 }
5490 74         140  
5491             $i = $left;
5492             last;
5493             }
5494             }
5495             }
5496              
5497 74         176 # rewrite character class or escape character
5498             elsif (my $char = character_class($char[$i],$modifier)) {
5499             $char[$i] = $char;
5500             }
5501              
5502 139 50       327 # /i modifier
5503 20         35 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
5504             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
5505             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
5506 20         31 }
5507             else {
5508             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
5509             }
5510             }
5511              
5512 0 50       0 # \u \l \U \L \F \Q \E
5513 1         3 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5514             if ($right_e < $left_e) {
5515             $char[$i] = '\\' . $char[$i];
5516             }
5517 0         0 }
5518 0         0 elsif ($char[$i] eq '\u') {
5519             $char[$i] = '@{[Elatin8::ucfirst qq<';
5520             $left_e++;
5521 0         0 }
5522 0         0 elsif ($char[$i] eq '\l') {
5523             $char[$i] = '@{[Elatin8::lcfirst qq<';
5524             $left_e++;
5525 0         0 }
5526 1         2 elsif ($char[$i] eq '\U') {
5527             $char[$i] = '@{[Elatin8::uc qq<';
5528             $left_e++;
5529 1         2 }
5530 1         3 elsif ($char[$i] eq '\L') {
5531             $char[$i] = '@{[Elatin8::lc qq<';
5532             $left_e++;
5533 1         3 }
5534 18         30 elsif ($char[$i] eq '\F') {
5535             $char[$i] = '@{[Elatin8::fc qq<';
5536             $left_e++;
5537 18         36 }
5538 1         2 elsif ($char[$i] eq '\Q') {
5539             $char[$i] = '@{[CORE::quotemeta qq<';
5540             $left_e++;
5541 1 50       3 }
5542 21         41 elsif ($char[$i] eq '\E') {
5543 21         25 if ($right_e < $left_e) {
5544             $char[$i] = '>]}';
5545             $right_e++;
5546 21         43 }
5547             else {
5548             $char[$i] = '';
5549             }
5550 0         0 }
5551 0 0       0 elsif ($char[$i] eq '\Q') {
5552 0         0 while (1) {
5553             if (++$i > $#char) {
5554 0 0       0 last;
5555 0         0 }
5556             if ($char[$i] eq '\E') {
5557             last;
5558             }
5559             }
5560             }
5561             elsif ($char[$i] eq '\E') {
5562             }
5563              
5564 0 0       0 # $0 --> $0
5565 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5566             if ($ignorecase) {
5567             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5568             }
5569 0 0       0 }
5570 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5571             if ($ignorecase) {
5572             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5573             }
5574             }
5575              
5576             # $$ --> $$
5577             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5578             }
5579              
5580             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5581 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5582 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5583 0         0 $char[$i] = e_capture($1);
5584             if ($ignorecase) {
5585             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5586             }
5587 0         0 }
5588 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5589 0         0 $char[$i] = e_capture($1);
5590             if ($ignorecase) {
5591             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5592             }
5593             }
5594              
5595 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5596 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) {
5597 0         0 $char[$i] = e_capture($1.'->'.$2);
5598             if ($ignorecase) {
5599             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5600             }
5601             }
5602              
5603 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5604 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) {
5605 0         0 $char[$i] = e_capture($1.'->'.$2);
5606             if ($ignorecase) {
5607             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5608             }
5609             }
5610              
5611 0         0 # $$foo
5612 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5613 0         0 $char[$i] = e_capture($1);
5614             if ($ignorecase) {
5615             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5616             }
5617             }
5618              
5619 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
5620 8         22 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5621             if ($ignorecase) {
5622             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
5623 0         0 }
5624             else {
5625             $char[$i] = '@{[Elatin8::PREMATCH()]}';
5626             }
5627             }
5628              
5629 8 50       20 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
5630 8         20 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5631             if ($ignorecase) {
5632             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
5633 0         0 }
5634             else {
5635             $char[$i] = '@{[Elatin8::MATCH()]}';
5636             }
5637             }
5638              
5639 8 50       22 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
5640 6         14 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5641             if ($ignorecase) {
5642             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
5643 0         0 }
5644             else {
5645             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
5646             }
5647             }
5648              
5649 6 0       16 # ${ foo }
5650 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) {
5651             if ($ignorecase) {
5652             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5653             }
5654             }
5655              
5656 0         0 # ${ ... }
5657 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5658 0         0 $char[$i] = e_capture($1);
5659             if ($ignorecase) {
5660             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5661             }
5662             }
5663              
5664 0         0 # $scalar or @array
5665 21 100       50 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5666 21         52 $char[$i] = e_string($char[$i]);
5667             if ($ignorecase) {
5668             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
5669             }
5670             }
5671              
5672 11 100 33     34 # quote character before ? + * {
    50          
5673             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5674             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
5675 138         881 }
5676 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5677 0         0 my $char = $char[$i-1];
5678             if ($char[$i] eq '{') {
5679             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5680 0         0 }
5681             else {
5682             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5683             }
5684 0         0 }
5685             else {
5686             $char[$i-1] = '(?:' . $char[$i-1] . ')';
5687             }
5688             }
5689             }
5690 127         427  
5691 642 50       1079 # make regexp string
5692 642 0 0     1230 $modifier =~ tr/i//d;
5693 0         0 if ($left_e > $right_e) {
5694             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5695             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5696 0         0 }
5697             else {
5698             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5699 0 50 33     0 }
5700 642         3069 }
5701             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5702             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5703 0         0 }
5704             else {
5705             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5706             }
5707             }
5708              
5709             #
5710             # double quote stuff
5711 642     180 0 4880 #
5712             sub qq_stuff {
5713             my($delimiter,$end_delimiter,$stuff) = @_;
5714 180 100       257  
5715 180         369 # scalar variable or array variable
5716             if ($stuff =~ /\A [\$\@] /oxms) {
5717             return $stuff;
5718             }
5719 100         318  
  80         175  
5720 80         220 # quote by delimiter
5721 80 50       179 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
5722 80 50       147 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5723 80 50       113 next if $char eq $delimiter;
5724 80         131 next if $char eq $end_delimiter;
5725             if (not $octet{$char}) {
5726             return join '', 'qq', $char, $stuff, $char;
5727 80         351 }
5728             }
5729             return join '', 'qq', '<', $stuff, '>';
5730             }
5731              
5732             #
5733             # escape regexp (m'', qr'', and m''b, qr''b)
5734 0     10 0 0 #
5735 10   50     40 sub e_qr_q {
5736             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5737 10         39 $modifier ||= '';
5738 10 50       15  
5739 10         18 $modifier =~ tr/p//d;
5740 0         0 if ($modifier =~ /([adlu])/oxms) {
5741 0 0       0 my $line = 0;
5742 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5743 0         0 if ($filename ne __FILE__) {
5744             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5745             last;
5746 0         0 }
5747             }
5748             die qq{Unsupported modifier "$1" used at line $line.\n};
5749 0         0 }
5750              
5751             $slash = 'div';
5752 10 100       17  
    50          
5753 10         20 # literal null string pattern
5754 8         10 if ($string eq '') {
5755 8         9 $modifier =~ tr/bB//d;
5756             $modifier =~ tr/i//d;
5757             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5758             }
5759              
5760 8         32 # with /b /B modifier
5761             elsif ($modifier =~ tr/bB//d) {
5762             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5763             }
5764              
5765 0         0 # without /b /B modifier
5766             else {
5767             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5768             }
5769             }
5770              
5771             #
5772             # escape regexp (m'', qr'')
5773 2     2 0 7 #
5774             sub e_qr_qt {
5775 2 50       5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5776              
5777             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5778 2         6  
5779             # split regexp
5780             my @char = $string =~ /\G((?>
5781             [^\\\[\$\@\/] |
5782             [\x00-\xFF] |
5783             \[\^ |
5784             \[\: (?>[a-z]+) \:\] |
5785             \[\:\^ (?>[a-z]+) \:\] |
5786             [\$\@\/] |
5787             \\ (?:$q_char) |
5788             (?:$q_char)
5789             ))/oxmsg;
5790 2         62  
5791 2 50 33     9 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
5792             for (my $i=0; $i <= $#char; $i++) {
5793             if (0) {
5794             }
5795 2         15  
5796 0         0 # open character class [...]
5797 0 0       0 elsif ($char[$i] eq '[') {
5798 0         0 my $left = $i;
5799             if ($char[$i+1] eq ']') {
5800 0         0 $i++;
5801 0 0       0 }
5802 0         0 while (1) {
5803             if (++$i > $#char) {
5804 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
5805 0         0 }
5806             if ($char[$i] eq ']') {
5807             my $right = $i;
5808 0         0  
5809             # [...]
5810 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
5811 0         0  
5812             $i = $left;
5813             last;
5814             }
5815             }
5816             }
5817              
5818 0         0 # open character class [^...]
5819 0 0       0 elsif ($char[$i] eq '[^') {
5820 0         0 my $left = $i;
5821             if ($char[$i+1] eq ']') {
5822 0         0 $i++;
5823 0 0       0 }
5824 0         0 while (1) {
5825             if (++$i > $#char) {
5826 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
5827 0         0 }
5828             if ($char[$i] eq ']') {
5829             my $right = $i;
5830 0         0  
5831             # [^...]
5832 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5833 0         0  
5834             $i = $left;
5835             last;
5836             }
5837             }
5838             }
5839              
5840 0         0 # escape $ @ / and \
5841             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5842             $char[$i] = '\\' . $char[$i];
5843             }
5844              
5845 0         0 # rewrite character class or escape character
5846             elsif (my $char = character_class($char[$i],$modifier)) {
5847             $char[$i] = $char;
5848             }
5849              
5850 0 0       0 # /i modifier
5851 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
5852             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
5853             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
5854 0         0 }
5855             else {
5856             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
5857             }
5858             }
5859              
5860 0 0       0 # quote character before ? + * {
5861             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5862             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
5863 0         0 }
5864             else {
5865             $char[$i-1] = '(?:' . $char[$i-1] . ')';
5866             }
5867             }
5868 0         0 }
5869 2         5  
5870             $delimiter = '/';
5871 2         3 $end_delimiter = '/';
5872 2         3  
5873             $modifier =~ tr/i//d;
5874             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5875             }
5876              
5877             #
5878             # escape regexp (m''b, qr''b)
5879 2     0 0 15 #
5880             sub e_qr_qb {
5881             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5882 0         0  
5883             # split regexp
5884             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
5885 0         0  
5886 0 0       0 # unescape character
    0          
5887             for (my $i=0; $i <= $#char; $i++) {
5888             if (0) {
5889             }
5890 0         0  
5891             # remain \\
5892             elsif ($char[$i] eq '\\\\') {
5893             }
5894              
5895 0         0 # escape $ @ / and \
5896             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5897             $char[$i] = '\\' . $char[$i];
5898             }
5899 0         0 }
5900 0         0  
5901 0         0 $delimiter = '/';
5902             $end_delimiter = '/';
5903             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5904             }
5905              
5906             #
5907             # escape regexp (s/here//)
5908 0     76 0 0 #
5909 76   100     203 sub e_s1 {
5910             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5911 76         336 $modifier ||= '';
5912 76 50       114  
5913 76         194 $modifier =~ tr/p//d;
5914 0         0 if ($modifier =~ /([adlu])/oxms) {
5915 0 0       0 my $line = 0;
5916 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5917 0         0 if ($filename ne __FILE__) {
5918             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5919             last;
5920 0         0 }
5921             }
5922             die qq{Unsupported modifier "$1" used at line $line.\n};
5923 0         0 }
5924              
5925             $slash = 'div';
5926 76 100       137  
    50          
5927 76         253 # literal null string pattern
5928 8         9 if ($string eq '') {
5929 8         12 $modifier =~ tr/bB//d;
5930             $modifier =~ tr/i//d;
5931             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5932             }
5933              
5934             # /b /B modifier
5935             elsif ($modifier =~ tr/bB//d) {
5936 8 0       50  
5937 0         0 # choice again delimiter
5938 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5939 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5940 0         0 my %octet = map {$_ => 1} @char;
5941 0         0 if (not $octet{')'}) {
5942             $delimiter = '(';
5943             $end_delimiter = ')';
5944 0         0 }
5945 0         0 elsif (not $octet{'}'}) {
5946             $delimiter = '{';
5947             $end_delimiter = '}';
5948 0         0 }
5949 0         0 elsif (not $octet{']'}) {
5950             $delimiter = '[';
5951             $end_delimiter = ']';
5952 0         0 }
5953 0         0 elsif (not $octet{'>'}) {
5954             $delimiter = '<';
5955             $end_delimiter = '>';
5956 0         0 }
5957 0 0       0 else {
5958 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5959 0         0 if (not $octet{$char}) {
5960 0         0 $delimiter = $char;
5961             $end_delimiter = $char;
5962             last;
5963             }
5964             }
5965             }
5966 0         0 }
5967 0         0  
5968             my $prematch = '';
5969             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5970 0 100       0 }
5971 68         194  
5972             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5973             my $metachar = qr/[\@\\|[\]{^]/oxms;
5974 68         267  
5975             # split regexp
5976             my @char = $string =~ /\G((?>
5977             [^\\\$\@\[\(] |
5978             \\ (?>[1-9][0-9]*) |
5979             \\g (?>\s*) (?>[1-9][0-9]*) |
5980             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
5981             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
5982             \\x (?>[0-9A-Fa-f]{1,2}) |
5983             \\ (?>[0-7]{2,3}) |
5984             \\c [\x40-\x5F] |
5985             \\x\{ (?>[0-9A-Fa-f]+) \} |
5986             \\o\{ (?>[0-7]+) \} |
5987             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5988             \\ $q_char |
5989             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5990             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5991             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5992             [\$\@] $qq_variable |
5993             \$ (?>\s* [0-9]+) |
5994             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5995             \$ \$ (?![\w\{]) |
5996             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5997             \[\^ |
5998             \[\: (?>[a-z]+) :\] |
5999             \[\:\^ (?>[a-z]+) :\] |
6000             \(\? |
6001             $q_char
6002             ))/oxmsg;
6003 68 50       15820  
6004 68         474 # choice again delimiter
  0         0  
6005 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6006 0         0 my %octet = map {$_ => 1} @char;
6007 0         0 if (not $octet{')'}) {
6008             $delimiter = '(';
6009             $end_delimiter = ')';
6010 0         0 }
6011 0         0 elsif (not $octet{'}'}) {
6012             $delimiter = '{';
6013             $end_delimiter = '}';
6014 0         0 }
6015 0         0 elsif (not $octet{']'}) {
6016             $delimiter = '[';
6017             $end_delimiter = ']';
6018 0         0 }
6019 0         0 elsif (not $octet{'>'}) {
6020             $delimiter = '<';
6021             $end_delimiter = '>';
6022 0         0 }
6023 0 0       0 else {
6024 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6025 0         0 if (not $octet{$char}) {
6026 0         0 $delimiter = $char;
6027             $end_delimiter = $char;
6028             last;
6029             }
6030             }
6031             }
6032             }
6033 0         0  
  68         130  
6034             # count '('
6035 253         412 my $parens = grep { $_ eq '(' } @char;
6036 68         113  
6037 68         88 my $left_e = 0;
6038             my $right_e = 0;
6039             for (my $i=0; $i <= $#char; $i++) {
6040 68 50 33     211  
    50 33        
    100          
    100          
    50          
    50          
6041 195         1102 # "\L\u" --> "\u\L"
6042             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6043             @char[$i,$i+1] = @char[$i+1,$i];
6044             }
6045              
6046 0         0 # "\U\l" --> "\l\U"
6047             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6048             @char[$i,$i+1] = @char[$i+1,$i];
6049             }
6050              
6051 0         0 # octal escape sequence
6052             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6053             $char[$i] = Elatin8::octchr($1);
6054             }
6055              
6056 1         3 # hexadecimal escape sequence
6057             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6058             $char[$i] = Elatin8::hexchr($1);
6059             }
6060              
6061             # \b{...} --> b\{...}
6062             # \B{...} --> B\{...}
6063             # \N{CHARNAME} --> N\{CHARNAME}
6064             # \p{PROPERTY} --> p\{PROPERTY}
6065 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6066             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6067             $char[$i] = $1 . '\\' . $2;
6068             }
6069              
6070 0         0 # \p, \P, \X --> p, P, X
6071             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6072             $char[$i] = $1;
6073 0 50 66     0 }
    100 66        
    50 100        
    100          
    100          
    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          
    50          
    50          
    100          
    100          
6074              
6075             if (0) {
6076             }
6077 195         733  
6078 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6079 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6080             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)) {
6081             $char[$i] .= join '', splice @char, $i+1, 3;
6082 0         0 }
6083             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)) {
6084             $char[$i] .= join '', splice @char, $i+1, 2;
6085 0         0 }
6086             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)) {
6087             $char[$i] .= join '', splice @char, $i+1, 1;
6088             }
6089             }
6090              
6091 0         0 # open character class [...]
6092 13 50       22 elsif ($char[$i] eq '[') {
6093 13         31 my $left = $i;
6094             if ($char[$i+1] eq ']') {
6095 0         0 $i++;
6096 13 50       23 }
6097 58         95 while (1) {
6098             if (++$i > $#char) {
6099 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6100 58         117 }
6101             if ($char[$i] eq ']') {
6102             my $right = $i;
6103 13 50       18  
6104 13         71 # [...]
  0         0  
6105             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6106             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6107 0         0 }
6108             else {
6109             splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6110 13         49 }
6111 13         22  
6112             $i = $left;
6113             last;
6114             }
6115             }
6116             }
6117              
6118 13         33 # open character class [^...]
6119 0 0       0 elsif ($char[$i] eq '[^') {
6120 0         0 my $left = $i;
6121             if ($char[$i+1] eq ']') {
6122 0         0 $i++;
6123 0 0       0 }
6124 0         0 while (1) {
6125             if (++$i > $#char) {
6126 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6127 0         0 }
6128             if ($char[$i] eq ']') {
6129             my $right = $i;
6130 0 0       0  
6131 0         0 # [^...]
  0         0  
6132             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6133             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6134 0         0 }
6135             else {
6136             splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6137 0         0 }
6138 0         0  
6139             $i = $left;
6140             last;
6141             }
6142             }
6143             }
6144              
6145 0         0 # rewrite character class or escape character
6146             elsif (my $char = character_class($char[$i],$modifier)) {
6147             $char[$i] = $char;
6148             }
6149              
6150 7 50       13 # /i modifier
6151 3         5 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6152             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6153             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6154 3         4 }
6155             else {
6156             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6157             }
6158             }
6159              
6160 0 0       0 # \u \l \U \L \F \Q \E
6161 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6162             if ($right_e < $left_e) {
6163             $char[$i] = '\\' . $char[$i];
6164             }
6165 0         0 }
6166 0         0 elsif ($char[$i] eq '\u') {
6167             $char[$i] = '@{[Elatin8::ucfirst qq<';
6168             $left_e++;
6169 0         0 }
6170 0         0 elsif ($char[$i] eq '\l') {
6171             $char[$i] = '@{[Elatin8::lcfirst qq<';
6172             $left_e++;
6173 0         0 }
6174 0         0 elsif ($char[$i] eq '\U') {
6175             $char[$i] = '@{[Elatin8::uc qq<';
6176             $left_e++;
6177 0         0 }
6178 0         0 elsif ($char[$i] eq '\L') {
6179             $char[$i] = '@{[Elatin8::lc qq<';
6180             $left_e++;
6181 0         0 }
6182 0         0 elsif ($char[$i] eq '\F') {
6183             $char[$i] = '@{[Elatin8::fc qq<';
6184             $left_e++;
6185 0         0 }
6186 0         0 elsif ($char[$i] eq '\Q') {
6187             $char[$i] = '@{[CORE::quotemeta qq<';
6188             $left_e++;
6189 0 0       0 }
6190 0         0 elsif ($char[$i] eq '\E') {
6191 0         0 if ($right_e < $left_e) {
6192             $char[$i] = '>]}';
6193             $right_e++;
6194 0         0 }
6195             else {
6196             $char[$i] = '';
6197             }
6198 0         0 }
6199 0 0       0 elsif ($char[$i] eq '\Q') {
6200 0         0 while (1) {
6201             if (++$i > $#char) {
6202 0 0       0 last;
6203 0         0 }
6204             if ($char[$i] eq '\E') {
6205             last;
6206             }
6207             }
6208             }
6209             elsif ($char[$i] eq '\E') {
6210             }
6211              
6212             # \0 --> \0
6213             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6214             }
6215              
6216             # \g{N}, \g{-N}
6217              
6218             # P.108 Using Simple Patterns
6219             # in Chapter 7: In the World of Regular Expressions
6220             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6221              
6222             # P.221 Capturing
6223             # in Chapter 5: Pattern Matching
6224             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6225              
6226             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6227             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6228             }
6229              
6230             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6231             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6232             }
6233              
6234             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6235             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6236             }
6237              
6238             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6239             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6240             }
6241              
6242 0 0       0 # $0 --> $0
6243 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6244             if ($ignorecase) {
6245             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6246             }
6247 0 0       0 }
6248 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6249             if ($ignorecase) {
6250             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6251             }
6252             }
6253              
6254             # $$ --> $$
6255             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6256             }
6257              
6258             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6259 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6260 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6261 0         0 $char[$i] = e_capture($1);
6262             if ($ignorecase) {
6263             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6264             }
6265 0         0 }
6266 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6267 0         0 $char[$i] = e_capture($1);
6268             if ($ignorecase) {
6269             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6270             }
6271             }
6272              
6273 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6274 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) {
6275 0         0 $char[$i] = e_capture($1.'->'.$2);
6276             if ($ignorecase) {
6277             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6278             }
6279             }
6280              
6281 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6282 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) {
6283 0         0 $char[$i] = e_capture($1.'->'.$2);
6284             if ($ignorecase) {
6285             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6286             }
6287             }
6288              
6289 0         0 # $$foo
6290 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6291 0         0 $char[$i] = e_capture($1);
6292             if ($ignorecase) {
6293             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6294             }
6295             }
6296              
6297 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
6298 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6299             if ($ignorecase) {
6300             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
6301 0         0 }
6302             else {
6303             $char[$i] = '@{[Elatin8::PREMATCH()]}';
6304             }
6305             }
6306              
6307 4 50       16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
6308 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6309             if ($ignorecase) {
6310             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
6311 0         0 }
6312             else {
6313             $char[$i] = '@{[Elatin8::MATCH()]}';
6314             }
6315             }
6316              
6317 4 50       13 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
6318 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6319             if ($ignorecase) {
6320             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
6321 0         0 }
6322             else {
6323             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
6324             }
6325             }
6326              
6327 3 0       11 # ${ foo }
6328 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) {
6329             if ($ignorecase) {
6330             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6331             }
6332             }
6333              
6334 0         0 # ${ ... }
6335 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6336 0         0 $char[$i] = e_capture($1);
6337             if ($ignorecase) {
6338             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6339             }
6340             }
6341              
6342 0         0 # $scalar or @array
6343 4 50       15 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6344 4         24 $char[$i] = e_string($char[$i]);
6345             if ($ignorecase) {
6346             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
6347             }
6348             }
6349              
6350 0 50       0 # quote character before ? + * {
6351             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6352             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6353 13         58 }
6354             else {
6355             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6356             }
6357             }
6358             }
6359 13         58  
6360 68         142 # make regexp string
6361 68 50       119 my $prematch = '';
6362 68         187 $modifier =~ tr/i//d;
6363             if ($left_e > $right_e) {
6364 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6365             }
6366             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6367             }
6368              
6369             #
6370             # escape regexp (s'here'' or s'here''b)
6371 68     21 0 713 #
6372 21   100     44 sub e_s1_q {
6373             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6374 21         69 $modifier ||= '';
6375 21 50       24  
6376 21         43 $modifier =~ tr/p//d;
6377 0         0 if ($modifier =~ /([adlu])/oxms) {
6378 0 0       0 my $line = 0;
6379 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6380 0         0 if ($filename ne __FILE__) {
6381             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6382             last;
6383 0         0 }
6384             }
6385             die qq{Unsupported modifier "$1" used at line $line.\n};
6386 0         0 }
6387              
6388             $slash = 'div';
6389 21 100       30  
    50          
6390 21         57 # literal null string pattern
6391 8         8 if ($string eq '') {
6392 8         9 $modifier =~ tr/bB//d;
6393             $modifier =~ tr/i//d;
6394             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6395             }
6396              
6397 8         40 # with /b /B modifier
6398             elsif ($modifier =~ tr/bB//d) {
6399             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6400             }
6401              
6402 0         0 # without /b /B modifier
6403             else {
6404             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6405             }
6406             }
6407              
6408             #
6409             # escape regexp (s'here'')
6410 13     13 0 26 #
6411             sub e_s1_qt {
6412 13 50       26 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6413              
6414             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6415 13         25  
6416             # split regexp
6417             my @char = $string =~ /\G((?>
6418             [^\\\[\$\@\/] |
6419             [\x00-\xFF] |
6420             \[\^ |
6421             \[\: (?>[a-z]+) \:\] |
6422             \[\:\^ (?>[a-z]+) \:\] |
6423             [\$\@\/] |
6424             \\ (?:$q_char) |
6425             (?:$q_char)
6426             ))/oxmsg;
6427 13         237  
6428 13 50 33     38 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6429             for (my $i=0; $i <= $#char; $i++) {
6430             if (0) {
6431             }
6432 25         100  
6433 0         0 # open character class [...]
6434 0 0       0 elsif ($char[$i] eq '[') {
6435 0         0 my $left = $i;
6436             if ($char[$i+1] eq ']') {
6437 0         0 $i++;
6438 0 0       0 }
6439 0         0 while (1) {
6440             if (++$i > $#char) {
6441 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6442 0         0 }
6443             if ($char[$i] eq ']') {
6444             my $right = $i;
6445 0         0  
6446             # [...]
6447 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6448 0         0  
6449             $i = $left;
6450             last;
6451             }
6452             }
6453             }
6454              
6455 0         0 # open character class [^...]
6456 0 0       0 elsif ($char[$i] eq '[^') {
6457 0         0 my $left = $i;
6458             if ($char[$i+1] eq ']') {
6459 0         0 $i++;
6460 0 0       0 }
6461 0         0 while (1) {
6462             if (++$i > $#char) {
6463 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6464 0         0 }
6465             if ($char[$i] eq ']') {
6466             my $right = $i;
6467 0         0  
6468             # [^...]
6469 0         0 splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6470 0         0  
6471             $i = $left;
6472             last;
6473             }
6474             }
6475             }
6476              
6477 0         0 # escape $ @ / and \
6478             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6479             $char[$i] = '\\' . $char[$i];
6480             }
6481              
6482 0         0 # rewrite character class or escape character
6483             elsif (my $char = character_class($char[$i],$modifier)) {
6484             $char[$i] = $char;
6485             }
6486              
6487 6 0       11 # /i modifier
6488 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6489             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6490             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6491 0         0 }
6492             else {
6493             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6494             }
6495             }
6496              
6497 0 0       0 # quote character before ? + * {
6498             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6499             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6500 0         0 }
6501             else {
6502             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6503             }
6504             }
6505 0         0 }
6506 13         19  
6507 13         20 $modifier =~ tr/i//d;
6508 13         17 $delimiter = '/';
6509 13         16 $end_delimiter = '/';
6510             my $prematch = '';
6511             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6512             }
6513              
6514             #
6515             # escape regexp (s'here''b)
6516 13     0 0 89 #
6517             sub e_s1_qb {
6518             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6519 0         0  
6520             # split regexp
6521             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6522 0         0  
6523 0 0       0 # unescape character
    0          
6524             for (my $i=0; $i <= $#char; $i++) {
6525             if (0) {
6526             }
6527 0         0  
6528             # remain \\
6529             elsif ($char[$i] eq '\\\\') {
6530             }
6531              
6532 0         0 # escape $ @ / and \
6533             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6534             $char[$i] = '\\' . $char[$i];
6535             }
6536 0         0 }
6537 0         0  
6538 0         0 $delimiter = '/';
6539 0         0 $end_delimiter = '/';
6540             my $prematch = '';
6541             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6542             }
6543              
6544             #
6545             # escape regexp (s''here')
6546 0     16 0 0 #
6547             sub e_s2_q {
6548 16         31 my($ope,$delimiter,$end_delimiter,$string) = @_;
6549              
6550 16         19 $slash = 'div';
6551 16         112  
6552 16 100       42 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
6553             for (my $i=0; $i <= $#char; $i++) {
6554             if (0) {
6555             }
6556 9         29  
6557             # not escape \\
6558             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6559             }
6560              
6561 0         0 # escape $ @ / and \
6562             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6563             $char[$i] = '\\' . $char[$i];
6564             }
6565 5         16 }
6566              
6567             return join '', $ope, $delimiter, @char, $end_delimiter;
6568             }
6569              
6570             #
6571             # escape regexp (s/here/and here/modifier)
6572 16     97 0 44 #
6573 97   100     641 sub e_sub {
6574             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6575 97         392 $modifier ||= '';
6576 97 50       184  
6577 97         280 $modifier =~ tr/p//d;
6578 0         0 if ($modifier =~ /([adlu])/oxms) {
6579 0 0       0 my $line = 0;
6580 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6581 0         0 if ($filename ne __FILE__) {
6582             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6583             last;
6584 0         0 }
6585             }
6586             die qq{Unsupported modifier "$1" used at line $line.\n};
6587 0 100       0 }
6588 97         236  
6589 36         51 if ($variable eq '') {
6590             $variable = '$_';
6591             $bind_operator = ' =~ ';
6592 36         40 }
6593              
6594             $slash = 'div';
6595              
6596             # P.128 Start of match (or end of previous match): \G
6597             # P.130 Advanced Use of \G with Perl
6598             # in Chapter 3: Overview of Regular Expression Features and Flavors
6599             # P.312 Iterative Matching: Scalar Context, with /g
6600             # in Chapter 7: Perl
6601             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6602              
6603             # P.181 Where You Left Off: The \G Assertion
6604             # in Chapter 5: Pattern Matching
6605             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6606              
6607             # P.220 Where You Left Off: The \G Assertion
6608             # in Chapter 5: Pattern Matching
6609 97         149 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6610 97         143  
6611             my $e_modifier = $modifier =~ tr/e//d;
6612 97         164 my $r_modifier = $modifier =~ tr/r//d;
6613 97 50       121  
6614 97         256 my $my = '';
6615 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6616 0         0 $my = $variable;
6617             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6618             $variable =~ s/ = .+ \z//oxms;
6619 0         0 }
6620 97         201  
6621             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6622             $variable_basename =~ s/ \s+ \z//oxms;
6623 97         177  
6624 97 100       129 # quote replacement string
6625 97         207 my $e_replacement = '';
6626 17         27 if ($e_modifier >= 1) {
6627             $e_replacement = e_qq('', '', '', $replacement);
6628             $e_modifier--;
6629 17 100       23 }
6630 80         200 else {
6631             if ($delimiter2 eq "'") {
6632             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6633 16         27 }
6634             else {
6635             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6636             }
6637 64         171 }
6638              
6639             my $sub = '';
6640 97 100       163  
6641 97 100       205 # with /r
6642             if ($r_modifier) {
6643             if (0) {
6644             }
6645 8         17  
6646 0 50       0 # s///gr without multibyte anchoring
6647             elsif ($modifier =~ /g/oxms) {
6648             $sub = sprintf(
6649             # 1 2 3 4 5
6650             q,
6651              
6652             $variable, # 1
6653             ($delimiter1 eq "'") ? # 2
6654             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6655             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6656             $s_matched, # 3
6657             $e_replacement, # 4
6658             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 5
6659             );
6660             }
6661              
6662             # s///r
6663 4         18 else {
6664              
6665 4 50       7 my $prematch = q{$`};
6666              
6667             $sub = sprintf(
6668             # 1 2 3 4 5 6 7
6669             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Elatin8::re_r=%s; %s"%s$Elatin8::re_r$'" } : %s>,
6670              
6671             $variable, # 1
6672             ($delimiter1 eq "'") ? # 2
6673             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6674             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6675             $s_matched, # 3
6676             $e_replacement, # 4
6677             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 5
6678             $prematch, # 6
6679             $variable, # 7
6680             );
6681             }
6682 4 50       12  
6683 8         21 # $var !~ s///r doesn't make sense
6684             if ($bind_operator =~ / !~ /oxms) {
6685             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6686             }
6687             }
6688              
6689 0 100       0 # without /r
6690             else {
6691             if (0) {
6692             }
6693 89         182  
6694 0 100       0 # s///g without multibyte anchoring
    100          
6695             elsif ($modifier =~ /g/oxms) {
6696             $sub = sprintf(
6697             # 1 2 3 4 5 6 7 8
6698             q,
6699              
6700             $variable, # 1
6701             ($delimiter1 eq "'") ? # 2
6702             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6703             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6704             $s_matched, # 3
6705             $e_replacement, # 4
6706             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 5
6707             $variable, # 6
6708             $variable, # 7
6709             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6710             );
6711             }
6712              
6713             # s///
6714 22         72 else {
6715              
6716 67 100       89 my $prematch = q{$`};
    100          
6717              
6718             $sub = sprintf(
6719              
6720             ($bind_operator =~ / =~ /oxms) ?
6721              
6722             # 1 2 3 4 5 6 7 8
6723             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Elatin8::re_r=%s; %s%s="%s$Elatin8::re_r$'"; 1 } : undef> :
6724              
6725             # 1 2 3 4 5 6 7 8
6726             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Elatin8::re_r=%s; %s%s="%s$Elatin8::re_r$'"; undef }>,
6727              
6728             $variable, # 1
6729             $bind_operator, # 2
6730             ($delimiter1 eq "'") ? # 3
6731             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6732             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6733             $s_matched, # 4
6734             $e_replacement, # 5
6735             '$Elatin8::re_r=CORE::eval $Elatin8::re_r; ' x $e_modifier, # 6
6736             $variable, # 7
6737             $prematch, # 8
6738             );
6739             }
6740             }
6741 67 50       337  
6742 97         251 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6743             if ($my ne '') {
6744             $sub = "($my, $sub)[1]";
6745             }
6746 0         0  
6747 97         142 # clear s/// variable
6748             $sub_variable = '';
6749 97         126 $bind_operator = '';
6750              
6751             return $sub;
6752             }
6753              
6754             #
6755             # escape regexp of split qr//
6756 97     74 0 644 #
6757 74   100     307 sub e_split {
6758             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6759 74         344 $modifier ||= '';
6760 74 50       107  
6761 74         258 $modifier =~ tr/p//d;
6762 0         0 if ($modifier =~ /([adlu])/oxms) {
6763 0 0       0 my $line = 0;
6764 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6765 0         0 if ($filename ne __FILE__) {
6766             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6767             last;
6768 0         0 }
6769             }
6770             die qq{Unsupported modifier "$1" used at line $line.\n};
6771 0         0 }
6772              
6773             $slash = 'div';
6774 74 50       112  
6775 74         146 # /b /B modifier
6776             if ($modifier =~ tr/bB//d) {
6777             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6778 0 50       0 }
6779 74         147  
6780             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6781             my $metachar = qr/[\@\\|[\]{^]/oxms;
6782 74         288  
6783             # split regexp
6784             my @char = $string =~ /\G((?>
6785             [^\\\$\@\[\(] |
6786             \\x (?>[0-9A-Fa-f]{1,2}) |
6787             \\ (?>[0-7]{2,3}) |
6788             \\c [\x40-\x5F] |
6789             \\x\{ (?>[0-9A-Fa-f]+) \} |
6790             \\o\{ (?>[0-7]+) \} |
6791             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6792             \\ $q_char |
6793             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6794             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6795             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6796             [\$\@] $qq_variable |
6797             \$ (?>\s* [0-9]+) |
6798             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6799             \$ \$ (?![\w\{]) |
6800             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6801             \[\^ |
6802             \[\: (?>[a-z]+) :\] |
6803             \[\:\^ (?>[a-z]+) :\] |
6804             \(\? |
6805             $q_char
6806 74         8869 ))/oxmsg;
6807 74         242  
6808 74         97 my $left_e = 0;
6809             my $right_e = 0;
6810             for (my $i=0; $i <= $#char; $i++) {
6811 74 50 33     266  
    50 33        
    100          
    100          
    50          
    50          
6812 249         1131 # "\L\u" --> "\u\L"
6813             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6814             @char[$i,$i+1] = @char[$i+1,$i];
6815             }
6816              
6817 0         0 # "\U\l" --> "\l\U"
6818             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6819             @char[$i,$i+1] = @char[$i+1,$i];
6820             }
6821              
6822 0         0 # octal escape sequence
6823             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6824             $char[$i] = Elatin8::octchr($1);
6825             }
6826              
6827 1         3 # hexadecimal escape sequence
6828             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6829             $char[$i] = Elatin8::hexchr($1);
6830             }
6831              
6832             # \b{...} --> b\{...}
6833             # \B{...} --> B\{...}
6834             # \N{CHARNAME} --> N\{CHARNAME}
6835             # \p{PROPERTY} --> p\{PROPERTY}
6836 1         3 # \P{PROPERTY} --> P\{PROPERTY}
6837             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6838             $char[$i] = $1 . '\\' . $2;
6839             }
6840              
6841 0         0 # \p, \P, \X --> p, P, X
6842             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6843             $char[$i] = $1;
6844 0 50 100     0 }
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6845              
6846             if (0) {
6847             }
6848 249         717  
6849 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6850 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6851             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)) {
6852             $char[$i] .= join '', splice @char, $i+1, 3;
6853 0         0 }
6854             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)) {
6855             $char[$i] .= join '', splice @char, $i+1, 2;
6856 0         0 }
6857             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)) {
6858             $char[$i] .= join '', splice @char, $i+1, 1;
6859             }
6860             }
6861              
6862 0         0 # open character class [...]
6863 3 50       5 elsif ($char[$i] eq '[') {
6864 3         8 my $left = $i;
6865             if ($char[$i+1] eq ']') {
6866 0         0 $i++;
6867 3 50       4 }
6868 7         11 while (1) {
6869             if (++$i > $#char) {
6870 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6871 7         10 }
6872             if ($char[$i] eq ']') {
6873             my $right = $i;
6874 3 50       4  
6875 3         15 # [...]
  0         0  
6876             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6877             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6878 0         0 }
6879             else {
6880             splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
6881 3         11 }
6882 3         4  
6883             $i = $left;
6884             last;
6885             }
6886             }
6887             }
6888              
6889 3         7 # open character class [^...]
6890 0 0       0 elsif ($char[$i] eq '[^') {
6891 0         0 my $left = $i;
6892             if ($char[$i+1] eq ']') {
6893 0         0 $i++;
6894 0 0       0 }
6895 0         0 while (1) {
6896             if (++$i > $#char) {
6897 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6898 0         0 }
6899             if ($char[$i] eq ']') {
6900             my $right = $i;
6901 0 0       0  
6902 0         0 # [^...]
  0         0  
6903             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6904             splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin8::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6905 0         0 }
6906             else {
6907             splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6908 0         0 }
6909 0         0  
6910             $i = $left;
6911             last;
6912             }
6913             }
6914             }
6915              
6916 0         0 # rewrite character class or escape character
6917             elsif (my $char = character_class($char[$i],$modifier)) {
6918             $char[$i] = $char;
6919             }
6920              
6921             # P.794 29.2.161. split
6922             # in Chapter 29: Functions
6923             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6924              
6925             # P.951 split
6926             # in Chapter 27: Functions
6927             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6928              
6929             # said "The //m modifier is assumed when you split on the pattern /^/",
6930             # but perl5.008 is not so. Therefore, this software adds //m.
6931             # (and so on)
6932              
6933 1         3 # split(m/^/) --> split(m/^/m)
6934             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
6935             $modifier .= 'm';
6936             }
6937              
6938 7 0       22 # /i modifier
6939 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
6940             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
6941             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
6942 0         0 }
6943             else {
6944             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
6945             }
6946             }
6947              
6948 0 0       0 # \u \l \U \L \F \Q \E
6949 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
6950             if ($right_e < $left_e) {
6951             $char[$i] = '\\' . $char[$i];
6952             }
6953 0         0 }
6954 0         0 elsif ($char[$i] eq '\u') {
6955             $char[$i] = '@{[Elatin8::ucfirst qq<';
6956             $left_e++;
6957 0         0 }
6958 0         0 elsif ($char[$i] eq '\l') {
6959             $char[$i] = '@{[Elatin8::lcfirst qq<';
6960             $left_e++;
6961 0         0 }
6962 0         0 elsif ($char[$i] eq '\U') {
6963             $char[$i] = '@{[Elatin8::uc qq<';
6964             $left_e++;
6965 0         0 }
6966 0         0 elsif ($char[$i] eq '\L') {
6967             $char[$i] = '@{[Elatin8::lc qq<';
6968             $left_e++;
6969 0         0 }
6970 0         0 elsif ($char[$i] eq '\F') {
6971             $char[$i] = '@{[Elatin8::fc qq<';
6972             $left_e++;
6973 0         0 }
6974 0         0 elsif ($char[$i] eq '\Q') {
6975             $char[$i] = '@{[CORE::quotemeta qq<';
6976             $left_e++;
6977 0 0       0 }
6978 0         0 elsif ($char[$i] eq '\E') {
6979 0         0 if ($right_e < $left_e) {
6980             $char[$i] = '>]}';
6981             $right_e++;
6982 0         0 }
6983             else {
6984             $char[$i] = '';
6985             }
6986 0         0 }
6987 0 0       0 elsif ($char[$i] eq '\Q') {
6988 0         0 while (1) {
6989             if (++$i > $#char) {
6990 0 0       0 last;
6991 0         0 }
6992             if ($char[$i] eq '\E') {
6993             last;
6994             }
6995             }
6996             }
6997             elsif ($char[$i] eq '\E') {
6998             }
6999              
7000 0 0       0 # $0 --> $0
7001 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7002             if ($ignorecase) {
7003             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7004             }
7005 0 0       0 }
7006 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7007             if ($ignorecase) {
7008             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7009             }
7010             }
7011              
7012             # $$ --> $$
7013             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7014             }
7015              
7016             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7017 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7018 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7019 0         0 $char[$i] = e_capture($1);
7020             if ($ignorecase) {
7021             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7022             }
7023 0         0 }
7024 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7025 0         0 $char[$i] = e_capture($1);
7026             if ($ignorecase) {
7027             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7028             }
7029             }
7030              
7031 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7032 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) {
7033 0         0 $char[$i] = e_capture($1.'->'.$2);
7034             if ($ignorecase) {
7035             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7036             }
7037             }
7038              
7039 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7040 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) {
7041 0         0 $char[$i] = e_capture($1.'->'.$2);
7042             if ($ignorecase) {
7043             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7044             }
7045             }
7046              
7047 0         0 # $$foo
7048 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7049 0         0 $char[$i] = e_capture($1);
7050             if ($ignorecase) {
7051             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7052             }
7053             }
7054              
7055 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin8::PREMATCH()
7056 12         46 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7057             if ($ignorecase) {
7058             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::PREMATCH())]}';
7059 0         0 }
7060             else {
7061             $char[$i] = '@{[Elatin8::PREMATCH()]}';
7062             }
7063             }
7064              
7065 12 50       57 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin8::MATCH()
7066 12         37 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7067             if ($ignorecase) {
7068             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::MATCH())]}';
7069 0         0 }
7070             else {
7071             $char[$i] = '@{[Elatin8::MATCH()]}';
7072             }
7073             }
7074              
7075 12 50       61 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin8::POSTMATCH()
7076 9         23 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7077             if ($ignorecase) {
7078             $char[$i] = '@{[Elatin8::ignorecase(Elatin8::POSTMATCH())]}';
7079 0         0 }
7080             else {
7081             $char[$i] = '@{[Elatin8::POSTMATCH()]}';
7082             }
7083             }
7084              
7085 9 0       38 # ${ foo }
7086 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) {
7087             if ($ignorecase) {
7088             $char[$i] = '@{[Elatin8::ignorecase(' . $1 . ')]}';
7089             }
7090             }
7091              
7092 0         0 # ${ ... }
7093 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7094 0         0 $char[$i] = e_capture($1);
7095             if ($ignorecase) {
7096             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7097             }
7098             }
7099              
7100 0         0 # $scalar or @array
7101 3 50       9 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7102 3         14 $char[$i] = e_string($char[$i]);
7103             if ($ignorecase) {
7104             $char[$i] = '@{[Elatin8::ignorecase(' . $char[$i] . ')]}';
7105             }
7106             }
7107              
7108 0 50       0 # quote character before ? + * {
7109             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7110             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7111 1         6 }
7112             else {
7113             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7114             }
7115             }
7116             }
7117 0         0  
7118 74 50       148 # make regexp string
7119 74         142 $modifier =~ tr/i//d;
7120             if ($left_e > $right_e) {
7121 0         0 return join '', 'Elatin8::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7122             }
7123             return join '', 'Elatin8::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7124             }
7125              
7126             #
7127             # escape regexp of split qr''
7128 74     0 0 714 #
7129 0   0       sub e_split_q {
7130             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7131 0           $modifier ||= '';
7132 0 0          
7133 0           $modifier =~ tr/p//d;
7134 0           if ($modifier =~ /([adlu])/oxms) {
7135 0 0         my $line = 0;
7136 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7137 0           if ($filename ne __FILE__) {
7138             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7139             last;
7140 0           }
7141             }
7142             die qq{Unsupported modifier "$1" used at line $line.\n};
7143 0           }
7144              
7145             $slash = 'div';
7146 0 0          
7147 0           # /b /B modifier
7148             if ($modifier =~ tr/bB//d) {
7149             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7150 0 0         }
7151              
7152             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7153 0            
7154             # split regexp
7155             my @char = $string =~ /\G((?>
7156             [^\\\[] |
7157             [\x00-\xFF] |
7158             \[\^ |
7159             \[\: (?>[a-z]+) \:\] |
7160             \[\:\^ (?>[a-z]+) \:\] |
7161             \\ (?:$q_char) |
7162             (?:$q_char)
7163             ))/oxmsg;
7164 0            
7165 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7166             for (my $i=0; $i <= $#char; $i++) {
7167             if (0) {
7168             }
7169 0            
7170 0           # open character class [...]
7171 0 0         elsif ($char[$i] eq '[') {
7172 0           my $left = $i;
7173             if ($char[$i+1] eq ']') {
7174 0           $i++;
7175 0 0         }
7176 0           while (1) {
7177             if (++$i > $#char) {
7178 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7179 0           }
7180             if ($char[$i] eq ']') {
7181             my $right = $i;
7182 0            
7183             # [...]
7184 0           splice @char, $left, $right-$left+1, Elatin8::charlist_qr(@char[$left+1..$right-1], $modifier);
7185 0            
7186             $i = $left;
7187             last;
7188             }
7189             }
7190             }
7191              
7192 0           # open character class [^...]
7193 0 0         elsif ($char[$i] eq '[^') {
7194 0           my $left = $i;
7195             if ($char[$i+1] eq ']') {
7196 0           $i++;
7197 0 0         }
7198 0           while (1) {
7199             if (++$i > $#char) {
7200 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7201 0           }
7202             if ($char[$i] eq ']') {
7203             my $right = $i;
7204 0            
7205             # [^...]
7206 0           splice @char, $left, $right-$left+1, Elatin8::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7207 0            
7208             $i = $left;
7209             last;
7210             }
7211             }
7212             }
7213              
7214 0           # rewrite character class or escape character
7215             elsif (my $char = character_class($char[$i],$modifier)) {
7216             $char[$i] = $char;
7217             }
7218              
7219 0           # split(m/^/) --> split(m/^/m)
7220             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7221             $modifier .= 'm';
7222             }
7223              
7224 0 0         # /i modifier
7225 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin8::uc($char[$i]) ne Elatin8::fc($char[$i]))) {
7226             if (CORE::length(Elatin8::fc($char[$i])) == 1) {
7227             $char[$i] = '[' . Elatin8::uc($char[$i]) . Elatin8::fc($char[$i]) . ']';
7228 0           }
7229             else {
7230             $char[$i] = '(?:' . Elatin8::uc($char[$i]) . '|' . Elatin8::fc($char[$i]) . ')';
7231             }
7232             }
7233              
7234 0 0         # quote character before ? + * {
7235             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7236             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7237 0           }
7238             else {
7239             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7240             }
7241             }
7242 0           }
7243 0            
7244             $modifier =~ tr/i//d;
7245             return join '', 'Elatin8::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7246             }
7247              
7248             #
7249             # instead of Carp::carp
7250 0     0 0   #
7251 0           sub carp {
7252             my($package,$filename,$line) = caller(1);
7253             print STDERR "@_ at $filename line $line.\n";
7254             }
7255              
7256             #
7257             # instead of Carp::croak
7258 0     0 0   #
7259 0           sub croak {
7260 0           my($package,$filename,$line) = caller(1);
7261             print STDERR "@_ at $filename line $line.\n";
7262             die "\n";
7263             }
7264              
7265             #
7266             # instead of Carp::cluck
7267 0     0 0   #
7268 0           sub cluck {
7269 0           my $i = 0;
7270 0           my @cluck = ();
7271 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7272             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7273 0           $i++;
7274 0           }
7275 0           print STDERR CORE::reverse @cluck;
7276             print STDERR "\n";
7277             print STDERR @_;
7278             }
7279              
7280             #
7281             # instead of Carp::confess
7282 0     0 0   #
7283 0           sub confess {
7284 0           my $i = 0;
7285 0           my @confess = ();
7286 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7287             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7288 0           $i++;
7289 0           }
7290 0           print STDERR CORE::reverse @confess;
7291 0           print STDERR "\n";
7292             print STDERR @_;
7293             die "\n";
7294             }
7295              
7296             1;
7297              
7298             __END__