2 package Locale::Maketext::Guts;
3 BEGIN { *zorp = sub { return scalar @_ } unless defined &zorp; }
4 # Just so we're nice and define SOMETHING in "our" package.
6 package Locale::Maketext;
8 use vars qw($USE_LITERALS $GUTSPATH);
12 *DEBUG = sub () {0} unless defined &DEBUG;
18 # This big scary routine compiles an entry.
19 # It returns either a coderef if there's brackety bits in this, or
20 # otherwise a ref to a scalar.
22 my $target = ref($_[0]) || $_[0];
25 my(@c) = (''); # "chunks" -- scratch.
29 my $in_group = 0; # start out outside a group
30 my($m, @params); # scratch
32 while($_[1] =~ # Iterate over chunks.
34 [^\~\[\]]+ # non-~[] stuff
36 ~. # ~[, ~], ~~, ~other
38 \[ # [ presumably opening a group
40 \] # ] presumably closing a group
47 print " \"$1\"\n" if DEBUG > 2;
49 if($1 eq '[' or $1 eq '') { # "[" or end
50 # Whether this is "[" or end, force processing of any
54 $target->_die_pointing($_[1], "Unterminated bracket group");
56 $target->_die_pointing($_[1], "You can't nest bracket groups");
60 print " [end-string]\n" if DEBUG > 2;
64 die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
66 # Now actually processing the preceding literal
68 if($USE_LITERALS and (
70 ? $c[-1] !~ m<[^\x20-\x7E]>s
71 # ASCII very safe chars
72 : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
73 # EBCDIC very safe chars
75 # normal case -- all very safe chars
77 push @code, q{ '} . $c[-1] . "',\n";
78 $c[-1] = ''; # reuse this slot
80 push @code, ' $c[' . $#c . "],\n";
81 push @c, ''; # new chunk
84 # else just ignore the empty string.
87 } elsif($1 eq ']') { # "]"
88 # close group -- go back in-band
92 print " --Closing group [$c[-1]]\n" if DEBUG > 2;
94 # And now process the group...
96 if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
97 DEBUG > 2 and print " -- (Ignoring)\n";
98 $c[-1] = ''; # reset out chink
102 #$c[-1] =~ s/^\s+//s;
103 #$c[-1] =~ s/\s+$//s;
104 ($m,@params) = split(",", $c[-1], -1); # was /\s*,\s*/
106 # A bit of a hack -- we've turned "~,"'s into DELs, so turn
107 # 'em into real commas here.
108 if (ord('A') == 65) { # ASCII, etc
109 foreach($m, @params) { tr/\x7F/,/ }
110 } else { # EBCDIC (1047, 0037, POSIX-BC)
111 # Thanks to Peter Prymmer for the EBCDIC handling
112 foreach($m, @params) { tr/\x07/,/ }
115 # Special-case handling of some method names:
116 if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
117 # Treat [_1,...] as [,_1,...], etc.
121 $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
123 $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
126 # Most common case: a simple, legal-looking method name
128 # 0-length method name means to just interpolate:
130 } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
131 and $m !~ m<(?:^|\:)\d>s
132 # exclude starting a (sub)package or symbol with a digit
134 # Yes, it even supports the demented (and undocumented?)
135 # $obj->Foo::bar(...) syntax.
136 $target->_die_pointing(
137 $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
140 if $m =~ m/^SUPER::/s;
141 # Because for SUPER:: to work, we'd have to compile this into
142 # the right package, and that seems just not worth the bother,
143 # unless someone convinces me otherwise.
145 push @code, ' $_[0]->' . $m . '(';
147 # TODO: implement something? or just too icky to consider?
148 $target->_die_pointing(
150 "Can't use \"$m\" as a method name in bracket group",
155 pop @c; # we don't need that chunk anymore
158 foreach my $p (@params) {
160 # Meaning: all parameters except $_[0]
161 $code[-1] .= ' @_[1 .. $#_], ';
162 # and yes, that does the right thing for all @_ < 3
163 } elsif($p =~ m<^_(-?\d+)$>s) {
165 $code[-1] .= '$_[' . (0 + $1) . '], ';
166 } elsif($USE_LITERALS and (
168 ? $p !~ m<[^\x20-\x7E]>s
169 # ASCII very safe chars
170 : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
171 # EBCDIC very safe chars
173 # Normal case: a literal containing only safe characters
175 $code[-1] .= q{'} . $p . q{', };
177 # Stow it on the chunk-stack, and just refer to that.
179 push @code, ' $c[' . $#c . "], ";
186 $target->_die_pointing($_[1], "Unbalanced ']'");
189 } elsif(substr($1,0,1) ne '~') {
190 # it's stuff not containing "~" or "[" or "]"
191 # i.e., a literal blob
194 } elsif($1 eq '~~') { # "~~"
197 } elsif($1 eq '~[') { # "~["
200 } elsif($1 eq '~]') { # "~]"
203 } elsif($1 eq '~,') { # "~,"
205 # This is a hack, based on the assumption that no-one will actually
206 # want a DEL inside a bracket group. Let's hope that's it's true.
207 if (ord('A') == 65) { # ASCII etc
209 } else { # EBCDIC (cp 1047, 0037, POSIX-BC)
216 } elsif($1 eq '~') { # possible only at string-end, it seems.
220 # It's a "~X" where X is not a special character.
221 # Consider it a literal ~ and X.
228 undef $big_pile; # Well, nevermind that.
230 # It's all literals! Ahwell, that can happen.
231 # So don't bother with the eval. Return a SCALAR reference.
235 die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
236 print scalar(@c), " chunks under closure\n" if DEBUG;
237 if(@code == 0) { # not possible?
238 print "Empty code\n" if DEBUG;
240 } elsif(@code > 1) { # most cases, presumably!
241 unshift @code, "join '',\n";
243 unshift @code, "use strict; sub {\n";
246 print @code if DEBUG;
247 my $sub = eval(join '', @code);
248 die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
252 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
255 # This is used by _compile to throw a fatal error
256 my $target = shift; # class name
257 # ...leaving $_[0] the error-causing text, and $_[1] the error message
259 my $i = index($_[0], "\n");
262 my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
264 $pointy = "^=== near there\n";
265 } else { # we need to space over
266 my $first_tab = index($_[0], "\t");
267 if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
268 # No tabs, or the first tab is harmlessly after where we will point to,
269 # AND we're far enough from the margin that we can draw a proper arrow.
270 $pointy = ('=' x $pos) . "^ near there\n";
272 # tabs screw everything up!
273 $pointy = substr($_[0],0,$pos);
274 $pointy =~ tr/\t //cd;
275 # make everything into whitespace, but preseving tabs
276 $pointy .= "^=== near there\n";
280 my $errmsg = "$_[1], in\:\n$_[0]";
284 $errmsg .= "\n" . $pointy;
285 } elsif($i == (length($_[0]) - 1) ) {
286 # Already has a newline at end.
289 # don't bother with the pointy bit, I guess.
291 Carp::croak( "$errmsg via $target, as used" );