-
-# Time-stamp: "2004-03-30 16:33:31 AST"
-
-require 5;
package Locale::Maketext;
use strict;
use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
- $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
+$USE_LITERALS $MATCH_SUPERS_TIGHTLY);
use Carp ();
use I18N::LangTags 0.30 ();
#--------------------------------------------------------------------------
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
- # define the constant 'DEBUG' at compile-time
+# define the constant 'DEBUG' at compile-time
-$VERSION = "1.10_01";
+$VERSION = '1.12';
@ISA = ();
$MATCH_SUPERS = 1;
$MATCH_SUPERS_TIGHTLY = 1;
$USING_LANGUAGE_TAGS = 1;
- # Turning this off is somewhat of a security risk in that little or no
- # checking will be done on the legality of tokens passed to the
- # eval("use $module_name") in _try_use. If you turn this off, you have
- # to do your own taint checking.
+# Turning this off is somewhat of a security risk in that little or no
+# checking will be done on the legality of tokens passed to the
+# eval("use $module_name") in _try_use. If you turn this off, you have
+# to do your own taint checking.
$USE_LITERALS = 1 unless defined $USE_LITERALS;
- # a hint for compiling bracket-notation things.
+# a hint for compiling bracket-notation things.
my %isa_scan = ();
###########################################################################
sub quant {
- my($handle, $num, @forms) = @_;
+ my($handle, $num, @forms) = @_;
- return $num if @forms == 0; # what should this mean?
- return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
+ return $num if @forms == 0; # what should this mean?
+ return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
- # Normal case:
- # Note that the formatting of $num is preserved.
- return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
- # Most human languages put the number phrase before the qualified phrase.
+ # Normal case:
+ # Note that the formatting of $num is preserved.
+ return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
+ # Most human languages put the number phrase before the qualified phrase.
}
sub numerate {
- # return this lexical item in a form appropriate to this number
- my($handle, $num, @forms) = @_;
- my $s = ($num == 1);
-
- return '' unless @forms;
- if(@forms == 1) { # only the headword form specified
- return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
- } else { # sing and plural were specified
- return $s ? $forms[0] : $forms[1];
- }
+ # return this lexical item in a form appropriate to this number
+ my($handle, $num, @forms) = @_;
+ my $s = ($num == 1);
+
+ return '' unless @forms;
+ if(@forms == 1) { # only the headword form specified
+ return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
+ }
+ else { # sing and plural were specified
+ return $s ? $forms[0] : $forms[1];
+ }
}
#--------------------------------------------------------------------------
sub numf {
- my($handle, $num) = @_[0,1];
- if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
- $num += 0; # Just use normal integer stringification.
- # Specifically, don't let %G turn ten million into 1E+007
- } else {
- $num = CORE::sprintf("%G", $num);
- # "CORE::" is there to avoid confusion with the above sub sprintf.
- }
- while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
- # The initial \d+ gobbles as many digits as it can, and then we
- # backtrack so it un-eats the rightmost three, and then we
- # insert the comma there.
-
- $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
- # This is just a lame hack instead of using Number::Format
- return $num;
+ my($handle, $num) = @_[0,1];
+ if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
+ $num += 0; # Just use normal integer stringification.
+ # Specifically, don't let %G turn ten million into 1E+007
+ }
+ else {
+ $num = CORE::sprintf('%G', $num);
+ # "CORE::" is there to avoid confusion with the above sub sprintf.
+ }
+ while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
+ # The initial \d+ gobbles as many digits as it can, and then we
+ # backtrack so it un-eats the rightmost three, and then we
+ # insert the comma there.
+
+ $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
+ # This is just a lame hack instead of using Number::Format
+ return $num;
}
sub sprintf {
- no integer;
- my($handle, $format, @params) = @_;
- return CORE::sprintf($format, @params);
+ no integer;
+ my($handle, $format, @params) = @_;
+ return CORE::sprintf($format, @params);
# "CORE::" is there to avoid confusion with myself!
}
use integer; # vroom vroom... applies to the whole rest of the module
sub language_tag {
- my $it = ref($_[0]) || $_[0];
- return undef unless $it =~ m/([^':]+)(?:::)?$/s;
- $it = lc($1);
- $it =~ tr<_><->;
- return $it;
+ my $it = ref($_[0]) || $_[0];
+ return undef unless $it =~ m/([^':]+)(?:::)?$/s;
+ $it = lc($1);
+ $it =~ tr<_><->;
+ return $it;
}
sub encoding {
- my $it = $_[0];
- return(
- (ref($it) && $it->{'encoding'})
- || "iso-8859-1" # Latin-1
- );
-}
+ my $it = $_[0];
+ return(
+ (ref($it) && $it->{'encoding'})
+ || 'iso-8859-1' # Latin-1
+ );
+}
#--------------------------------------------------------------------------
#--------------------------------------------------------------------------
sub fail_with { # an actual attribute method!
- my($handle, @params) = @_;
- return unless ref($handle);
- $handle->{'fail'} = $params[0] if @params;
- return $handle->{'fail'};
+ my($handle, @params) = @_;
+ return unless ref($handle);
+ $handle->{'fail'} = $params[0] if @params;
+ return $handle->{'fail'};
}
#--------------------------------------------------------------------------
sub failure_handler_auto {
- # Meant to be used like:
- # $handle->fail_with('failure_handler_auto')
-
- my($handle, $phrase, @params) = @_;
- $handle->{'failure_lex'} ||= {};
- my $lex = $handle->{'failure_lex'};
-
- my $value;
- $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
-
- # Dumbly copied from sub maketext:
- {
- local $SIG{'__DIE__'};
- eval { $value = &$value($handle, @_) };
- }
- # If we make it here, there was an exception thrown in the
- # call to $value, and so scream:
- if($@) {
- my $err = $@;
- # pretty up the error message
- $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
- <\n in bracket code [compiled line $1],>s;
- #$err =~ s/\n?$/\n/s;
- Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
- # Rather unexpected, but suppose that the sub tried calling
- # a method that didn't exist.
- } else {
- return $value;
- }
+ # Meant to be used like:
+ # $handle->fail_with('failure_handler_auto')
+
+ my $handle = shift;
+ my $phrase = shift;
+
+ $handle->{'failure_lex'} ||= {};
+ my $lex = $handle->{'failure_lex'};
+
+ my $value;
+ $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
+
+ # Dumbly copied from sub maketext:
+ return ${$value} if ref($value) eq 'SCALAR';
+ return $value if ref($value) ne 'CODE';
+ {
+ local $SIG{'__DIE__'};
+ eval { $value = &$value($handle, @_) };
+ }
+ # If we make it here, there was an exception thrown in the
+ # call to $value, and so scream:
+ if($@) {
+ my $err = $@;
+ # pretty up the error message
+ $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
+ {\n in bracket code [compiled line $1],}s;
+ #$err =~ s/\n?$/\n/s;
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
+ # Rather unexpected, but suppose that the sub tried calling
+ # a method that didn't exist.
+ }
+ else {
+ return $value;
+ }
}
#==========================================================================
sub new {
- # Nothing fancy!
- my $class = ref($_[0]) || $_[0];
- my $handle = bless {}, $class;
- $handle->init;
- return $handle;
+ # Nothing fancy!
+ my $class = ref($_[0]) || $_[0];
+ my $handle = bless {}, $class;
+ $handle->init;
+ return $handle;
}
sub init { return } # no-op
###########################################################################
sub maketext {
- # Remember, this can fail. Failure is controllable many ways.
- Carp::croak "maketext requires at least one parameter" unless @_ > 1;
-
- my($handle, $phrase) = splice(@_,0,2);
-
- # Don't interefere with $@ in case that's being interpolated into the msg.
- local $@;
-
- # Look up the value:
-
- my $value;
- foreach my $h_r (
- @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
- ) {
- print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
- if(exists $h_r->{$phrase}) {
- print " Found \"$phrase\" in $h_r\n" if DEBUG;
- unless(ref($value = $h_r->{$phrase})) {
- # Nonref means it's not yet compiled. Compile and replace.
- $value = $h_r->{$phrase} = $handle->_compile($value);
- }
- last;
- } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
- # it's an auto lex, and this is an autoable key!
- print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
-
- $value = $h_r->{$phrase} = $handle->_compile($phrase);
- last;
+ # Remember, this can fail. Failure is controllable many ways.
+ Carp::croak 'maketext requires at least one parameter' unless @_ > 1;
+
+ my($handle, $phrase) = splice(@_,0,2);
+ Carp::confess('No handle/phrase') unless (defined($handle) && defined($phrase));
+
+
+ # Don't interefere with $@ in case that's being interpolated into the msg.
+ local $@;
+
+ # Look up the value:
+
+ my $value;
+ foreach my $h_r (
+ @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
+ ) {
+ DEBUG and print "* Looking up \"$phrase\" in $h_r\n";
+ if(exists $h_r->{$phrase}) {
+ DEBUG and print " Found \"$phrase\" in $h_r\n";
+ unless(ref($value = $h_r->{$phrase})) {
+ # Nonref means it's not yet compiled. Compile and replace.
+ $value = $h_r->{$phrase} = $handle->_compile($value);
+ }
+ last;
+ }
+ elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
+ # it's an auto lex, and this is an autoable key!
+ DEBUG and print " Automaking \"$phrase\" into $h_r\n";
+
+ $value = $h_r->{$phrase} = $handle->_compile($phrase);
+ last;
+ }
+ DEBUG>1 and print " Not found in $h_r, nor automakable\n";
+ # else keep looking
}
- print " Not found in $h_r, nor automakable\n" if DEBUG > 1;
- # else keep looking
- }
-
- unless(defined($value)) {
- print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
- " fails.\n" if DEBUG;
- if(ref($handle) and $handle->{'fail'}) {
- print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
- my $fail;
- if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
- return &{$fail}($handle, $phrase, @_);
- # If it ever returns, it should return a good value.
- } else { # It's a method name
- return $handle->$fail($phrase, @_);
- # If it ever returns, it should return a good value.
- }
- } else {
- # All we know how to do is this;
- Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
+
+ unless(defined($value)) {
+ DEBUG and print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, " fails.\n";
+ if(ref($handle) and $handle->{'fail'}) {
+ DEBUG and print "WARNING0: maketext fails looking for <$phrase>\n";
+ my $fail;
+ if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
+ return &{$fail}($handle, $phrase, @_);
+ # If it ever returns, it should return a good value.
+ }
+ else { # It's a method name
+ return $handle->$fail($phrase, @_);
+ # If it ever returns, it should return a good value.
+ }
+ }
+ else {
+ # All we know how to do is this;
+ Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
+ }
+ }
+
+ return $$value if ref($value) eq 'SCALAR';
+ return $value unless ref($value) eq 'CODE';
+
+ {
+ local $SIG{'__DIE__'};
+ eval { $value = &$value($handle, @_) };
+ }
+ # If we make it here, there was an exception thrown in the
+ # call to $value, and so scream:
+ if ($@) {
+ my $err = $@;
+ # pretty up the error message
+ $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
+ {\n in bracket code [compiled line $1],}s;
+ #$err =~ s/\n?$/\n/s;
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
+ # Rather unexpected, but suppose that the sub tried calling
+ # a method that didn't exist.
+ }
+ else {
+ return $value;
}
- }
-
- return $$value if ref($value) eq 'SCALAR';
- return $value unless ref($value) eq 'CODE';
-
- {
- local $SIG{'__DIE__'};
- eval { $value = &$value($handle, @_) };
- }
- # If we make it here, there was an exception thrown in the
- # call to $value, and so scream:
- if($@) {
- my $err = $@;
- # pretty up the error message
- $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
- <\n in bracket code [compiled line $1],>s;
- #$err =~ s/\n?$/\n/s;
- Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
- # Rather unexpected, but suppose that the sub tried calling
- # a method that didn't exist.
- } else {
- return $value;
- }
}
###########################################################################
sub get_handle { # This is a constructor and, yes, it CAN FAIL.
- # Its class argument has to be the base class for the current
- # application's l10n files.
-
- my($base_class, @languages) = @_;
- $base_class = ref($base_class) || $base_class;
- # Complain if they use __PACKAGE__ as a project base class?
-
- if( @languages ) {
- DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- if($USING_LANGUAGE_TAGS) { # An explicit language-list was given!
- @languages =
- map {; $_, I18N::LangTags::alternate_language_tags($_) }
- # Catch alternation
- map I18N::LangTags::locale2language_tag($_),
- # If it's a lg tag, fine, pass thru (untainted)
- # If it's a locale ID, try converting to a lg tag (untainted),
- # otherwise nix it.
- @languages;
- DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
+ # Its class argument has to be the base class for the current
+ # application's l10n files.
+
+ my($base_class, @languages) = @_;
+ $base_class = ref($base_class) || $base_class;
+ # Complain if they use __PACKAGE__ as a project base class?
+
+ if( @languages ) {
+ DEBUG and print 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ if($USING_LANGUAGE_TAGS) { # An explicit language-list was given!
+ @languages =
+ map {; $_, I18N::LangTags::alternate_language_tags($_) }
+ # Catch alternation
+ map I18N::LangTags::locale2language_tag($_),
+ # If it's a lg tag, fine, pass thru (untainted)
+ # If it's a locale ID, try converting to a lg tag (untainted),
+ # otherwise nix it.
+ @languages;
+ DEBUG and print 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+ }
+ else {
+ @languages = $base_class->_ambient_langprefs;
}
- } else {
- @languages = $base_class->_ambient_langprefs;
- }
-
- @languages = $base_class->_langtag_munging(@languages);
-
- my %seen;
- foreach my $module_name ( map { $base_class . "::" . $_ } @languages ) {
- next unless length $module_name; # sanity
- next if $seen{$module_name}++ # Already been here, and it was no-go
- || !&_try_use($module_name); # Try to use() it, but can't it.
- return($module_name->new); # Make it!
- }
-
- return undef; # Fail!
+
+ @languages = $base_class->_langtag_munging(@languages);
+
+ my %seen;
+ foreach my $module_name ( map { $base_class . '::' . $_ } @languages ) {
+ next unless length $module_name; # sanity
+ next if $seen{$module_name}++ # Already been here, and it was no-go
+ || !&_try_use($module_name); # Try to use() it, but can't it.
+ return($module_name->new); # Make it!
+ }
+
+ return undef; # Fail!
}
###########################################################################
sub _langtag_munging {
- my($base_class, @languages) = @_;
-
- # We have all these DEBUG statements because otherwise it's hard as hell
- # to diagnose ifwhen something goes wrong.
-
- DEBUG and print "Lgs1: ", map("<$_>", @languages), "\n";
-
- if($USING_LANGUAGE_TAGS) {
- DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- @languages = $base_class->_add_supers( @languages );
-
- push @languages, I18N::LangTags::panic_languages(@languages);
- DEBUG and print "After adding panic languages:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
-
- push @languages, $base_class->fallback_languages;
- # You are free to override fallback_languages to return empty-list!
- DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
-
- @languages = # final bit of processing to turn them into classname things
- map {
- my $it = $_; # copy
- $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
- $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
- $it;
- } @languages
- ;
- DEBUG and print "Nearing end of munging:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- } else {
- DEBUG and print "Bypassing language-tags.\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- }
-
- DEBUG and print "Before adding fallback classes:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
-
- push @languages, $base_class->fallback_language_classes;
- # You are free to override that to return whatever.
-
- DEBUG and print "Finally:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
-
- return @languages;
+ my($base_class, @languages) = @_;
+
+ # We have all these DEBUG statements because otherwise it's hard as hell
+ # to diagnose ifwhen something goes wrong.
+
+ DEBUG and print 'Lgs1: ', map("<$_>", @languages), "\n";
+
+ if($USING_LANGUAGE_TAGS) {
+ DEBUG and print 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ @languages = $base_class->_add_supers( @languages );
+
+ push @languages, I18N::LangTags::panic_languages(@languages);
+ DEBUG and print "After adding panic languages:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ push @languages, $base_class->fallback_languages;
+ # You are free to override fallback_languages to return empty-list!
+ DEBUG and print 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ @languages = # final bit of processing to turn them into classname things
+ map {
+ my $it = $_; # copy
+ $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
+ $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
+ $it;
+ } @languages
+ ;
+ DEBUG and print "Nearing end of munging:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+ else {
+ DEBUG and print "Bypassing language-tags.\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+
+ DEBUG and print "Before adding fallback classes:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ push @languages, $base_class->fallback_language_classes;
+ # You are free to override that to return whatever.
+
+ DEBUG and print "Finally:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ return @languages;
}
###########################################################################
sub _ambient_langprefs {
- require I18N::LangTags::Detect;
- return I18N::LangTags::Detect::detect();
+ require I18N::LangTags::Detect;
+ return I18N::LangTags::Detect::detect();
}
###########################################################################
sub _add_supers {
- my($base_class, @languages) = @_;
-
- if(!$MATCH_SUPERS) {
- # Nothing
- DEBUG and print "Bypassing any super-matching.\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
-
- } elsif( $MATCH_SUPERS_TIGHTLY ) {
- DEBUG and print "Before adding new supers tightly:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- @languages = I18N::LangTags::implicate_supers( @languages );
- DEBUG and print "After adding new supers tightly:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
-
- } else {
- DEBUG and print "Before adding supers to end:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- @languages = I18N::LangTags::implicate_supers_strictly( @languages );
- DEBUG and print "After adding supers to end:\n",
- " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
- }
-
- return @languages;
+ my($base_class, @languages) = @_;
+
+ if (!$MATCH_SUPERS) {
+ # Nothing
+ DEBUG and print "Bypassing any super-matching.\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ }
+ elsif( $MATCH_SUPERS_TIGHTLY ) {
+ DEBUG and print "Before adding new supers tightly:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ @languages = I18N::LangTags::implicate_supers( @languages );
+ DEBUG and print "After adding new supers tightly:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+
+ }
+ else {
+ DEBUG and print "Before adding supers to end:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ @languages = I18N::LangTags::implicate_supers_strictly( @languages );
+ DEBUG and print "After adding supers to end:\n",
+ ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n";
+ }
+
+ return @languages;
}
###########################################################################
###########################################################################
my %tried = ();
- # memoization of whether we've used this module, or found it unusable.
+# memoization of whether we've used this module, or found it unusable.
sub _try_use { # Basically a wrapper around "require Modulename"
- # "Many men have tried..." "They tried and failed?" "They tried and died."
- return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
-
- my $module = $_[0]; # ASSUME sane module name!
- { no strict 'refs';
- return($tried{$module} = 1)
- if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
- # weird case: we never use'd it, but there it is!
- }
-
- print " About to use $module ...\n" if DEBUG;
- {
- local $SIG{'__DIE__'};
- eval "require $module"; # used to be "use $module", but no point in that.
- }
- if($@) {
- print "Error using $module \: $@\n" if DEBUG > 1;
- return $tried{$module} = 0;
- } else {
- print " OK, $module is used\n" if DEBUG;
- return $tried{$module} = 1;
- }
+ # "Many men have tried..." "They tried and failed?" "They tried and died."
+ return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
+
+ my $module = $_[0]; # ASSUME sane module name!
+ { no strict 'refs';
+ return($tried{$module} = 1)
+ if defined(%{$module . '::Lexicon'}) or defined(@{$module . '::ISA'});
+ # weird case: we never use'd it, but there it is!
+ }
+
+ DEBUG and print " About to use $module ...\n";
+ {
+ local $SIG{'__DIE__'};
+ eval "require $module"; # used to be "use $module", but no point in that.
+ }
+ if($@) {
+ DEBUG and print "Error using $module \: $@\n";
+ return $tried{$module} = 0;
+ }
+ else {
+ DEBUG and print " OK, $module is used\n";
+ return $tried{$module} = 1;
+ }
}
#--------------------------------------------------------------------------
sub _lex_refs { # report the lexicon references for this handle's class
- # returns an arrayREF!
- no strict 'refs';
- my $class = ref($_[0]) || $_[0];
- print "Lex refs lookup on $class\n" if DEBUG > 1;
- return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
-
- my @lex_refs;
- my $seen_r = ref($_[1]) ? $_[1] : {};
-
- if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
- push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
- print "%" . $class . "::Lexicon contains ",
- scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
- }
-
- # Implements depth(height?)-first recursive searching of superclasses.
- # In hindsight, I suppose I could have just used Class::ISA!
- foreach my $superclass (@{$class . "::ISA"}) {
- print " Super-class search into $superclass\n" if DEBUG;
- next if $seen_r->{$superclass}++;
- push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
- }
-
- $isa_scan{$class} = \@lex_refs; # save for next time
- return \@lex_refs;
+ # returns an arrayREF!
+ no strict 'refs';
+ no warnings 'once';
+ my $class = ref($_[0]) || $_[0];
+ DEBUG and print "Lex refs lookup on $class\n";
+ return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
+
+ my @lex_refs;
+ my $seen_r = ref($_[1]) ? $_[1] : {};
+
+ if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
+ push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
+ DEBUG and print '%' . $class . '::Lexicon contains ',
+ scalar(keys %{$class . '::Lexicon'}), " entries\n";
+ }
+
+ # Implements depth(height?)-first recursive searching of superclasses.
+ # In hindsight, I suppose I could have just used Class::ISA!
+ foreach my $superclass (@{$class . '::ISA'}) {
+ DEBUG and print " Super-class search into $superclass\n";
+ next if $seen_r->{$superclass}++;
+ push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
+ }
+
+ $isa_scan{$class} = \@lex_refs; # save for next time
+ return \@lex_refs;
}
sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
-###########################################################################
1;
-
-__END__
-
-HEY YOU! You need some FOOD!
-
-
- ~~ Tangy Moroccan Carrot Salad ~~
-
-* 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
-* 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
-* 1 tablespoon ground cumin
-* 1 tablespoon honey
-* The juice of about a half a big lemon, or of a whole smaller one
-* 1/3 cup olive oil
-* 1 tablespoon of fresh dill, washed and chopped fine
-* Pinch of salt, maybe a pinch of pepper
-
-Cook the carrots in a pot of boiling water until just tender -- roughly
-six minutes. (Just don't let them get mushy!) Drain the carrots.
-
-In a largish bowl, combine the lemon juice, the cumin, the chile
-powder, and the honey. Mix well.
-Add the olive oil and whisk it together well. Add the dill and stir.
-
-Add the warm carrots to the bowl and toss it all to coat the carrots
-well. Season with salt and pepper, to taste.
-
-Serve warm or at room temperature.
-
-The measurements here are very approximate, and you should feel free to
-improvise and experiment. It's a very forgiving recipe. For example,
-you could easily halve or double the amount of cumin, or use chopped mint
-leaves instead of dill, or lime juice instead of lemon, et cetera.
-
-[end]
-
C<("en-US", "sk", "kon", "es-MX", "ja", "i-klingon")>, and for the first class
that succeeds, returns YourProjClass::I<language>->new().
-It runs thru the entire given list of language-tags, and finds no classes
+If it runs thru the entire given list of language-tags, and finds no classes
for those exact terms, it then tries "superordinate" language classes.
So if no "en-US" class (i.e., YourProjClass::en_us)
was found, nor classes for anything else in that list, we then try
sub get_handle_via_config {
my $class = $_[0];
- my $preferred_language = $Config_settings{'language'};
+ my $chosen_language = $Config_settings{'language'};
my $lh;
- if($preferred_language) {
+ if($chosen_language) {
$lh = $class->get_handle($chosen_language)
|| die "No language handle for \"$chosen_language\" or the like";
} else {
This is the most important method in Locale::Maketext:
-$text = $lh->maketext(I<key>, ...parameters for this phrase...);
+ $text = $lh->maketext(I<key>, ...parameters for this phrase...);
This looks in the %Lexicon of the language handle
$lh and all its superclasses, looking
If the value is a scalarref, the scalar is dereferenced and returned
(and any parameters are ignored).
+
If the value is a coderef, we return &$value($lh, ...parameters...).
+
If the value is a string that I<doesn't> look like it's in Bracket Notation,
we return it (after replacing it with a scalarref, in its %Lexicon).
+
If the value I<does> look like it's in Bracket Notation, then we compile
it into a sub, replace the string in the %Lexicon with the new coderef,
and then we return &$new_sub($lh, ...parameters...).
which you then use as the first argument in
the call to YourProjClass->get_handle(...). It should derive
(whether directly or indirectly) from Locale::Maketext.
-It B<doesn't matter> how you name this class, altho assuming this
+It B<doesn't matter> how you name this class, although assuming this
is the localization component of your Super Mega Program,
good names for your project class might be
SuperMegaProgram::Localization, SuperMegaProgram::L10N,
Language classes are what YourProjClass->get_handle will try to load.
It will look for them by taking each language-tag (B<skipping> it
if it doesn't look like a language-tag or locale-tag!), turning it to
-all lowercase, turning and dashes to underscores, and appending it
+all lowercase, turning dashes to underscores, and appending it
to YourProjClass . "::". So this:
$lh = YourProjClass->get_handle(
=item *
-Language classes may derive from other language classes (altho they
+Language classes may derive from other language classes (although they
should have "use I<Thatclassname>" or "use base qw(I<...classes...>)").
They may derive from the project
class. They may derive from some other class altogether. Or via
I almost always use keys that are themselves
valid lexicon values. One notable exception is when the value is
quite long. For example, to get the screenful of data that
-a command-line program might returns when given an unknown switch,
-I often just use a key "_USAGE_MESSAGE". At that point I then go
+a command-line program might return when given an unknown switch,
+I often just use a brief, self-explanatory key such as "_USAGE_MESSAGE". At that point I then go
and immediately to define that lexicon entry in the
ProjectClass::L10N::en lexicon (since English is always my "project
language"):
the lexicons in its superclasses. This is not because these are
special hashes I<per se>, but because you access them via the
C<maketext> method, which looks for entries across all the
-C<%Lexicon>
's in a language class I<and> all its ancestor classes.
+C<%Lexicon>
hashes in a language class I<and> all its ancestor classes.
(This is because the idea of "class data" isn't directly implemented
in Perl, but is instead left to individual class-systems to implement
as they see fit..)
Note that you may have things stored in a lexicon
besides just phrases for output: for example, if your program
takes input from the keyboard, asking a "(Y/N)" question,
-you probably need to know what equivalent of "Y[es]/N[o]" is
+you probably need to know what the equivalent of "Y[es]/N[o]" is
in whatever language. You probably also need to know what
the equivalents of the answers "y" and "n" are. You can
store that information in the lexicon (say, under the keys
Or instead of storing this in the language class's lexicon,
you can (and, in some cases, really should) represent the same bit
-of knowledge as code is a method in the language class. (That
+of knowledge as code in a method in the language class. (That
leaves a tidy distinction between the lexicon as the things we
know how to I<say>, and the rest of the things in the lexicon class
as things that we know how to I<do>.) Consider
=head1 BRACKET NOTATION
Bracket Notation is a crucial feature of Locale::Maketext. I mean
-Bracket Notation to provide a replacement for sprintf formatting.
+Bracket Notation to provide a replacement for the use of sprintf formatting.
Everything you do with Bracket Notation could be done with a sub block,
but bracket notation is meant to be much more concise.
Bracket Notation is a like a miniature "template" system (in the sense
of L<Text::Template|Text::Template>, not in the sense of C++ templates),
-where normal text is passed thru basically as is, but text is special
-regions is specially interpreted. In Bracket Notation, you use brackets
-("[...]" -- not "{...}"!) to note sections that are specially interpreted.
+where normal text is passed thru basically as is, but text in special
+regions is specially interpreted. In Bracket Notation, you use square brackets ("[...]"),
+not curly braces ("{...}") to note sections that are specially interpreted.
For example, here all the areas that are taken literally are underlined with
a "^", and all the in-bracket special regions are underlined with an X:
=item *
An item that is "_I<digits>" or "_-I<digits>" is interpreted as
-$_[I<value>]. I.e., "_1" is becomes with $_[1], and "_-3" is interpreted
+$_[I<value>]. I.e., "_1" becomes with $_[1], and "_-3" is interpreted
as $_[-3] (in which case @_ should have at least three elements in it).
Note that $_[0] is the language handle, and is typically not named
directly.
=item *
-If the first item in a bracket group is empty-string, or "_*"
+If the first item in a bracket group is the empty-string, or "_*"
or "_I<digits>" or "_-I<digits>", then that group is interpreted
as just the interpolation of all its items:
=item *
Otherwise this bracket group is invalid. For example, in the group
-"[!@#,whatever]", the first item C<"!@#"> is neither empty-string,
+"[!@#,whatever]", the first item C<"!@#"> is neither the empty-string,
"_I<number>", "_-I<number>", "_*", nor a valid method name; and so
Locale::Maketext will throw an exception of you try compiling an
expression containing this bracket group.
my $lh = $_[0];
return join '',
"Hoohah ",
- $lh->foo(" _1 ", " bar ", "baz"), #!!!
+ $lh->foo(" _1 ", " bar ", "baz"), # note the <space> in " bar "
"!",
}
I can picture all sorts of circumstances where you just
do not want lookup to be able to fail (since failing
-normally means that maketext throws a C<die>, altho
+normally means that maketext throws a C<die>, although
see the next section for greater control over that). But
here's one circumstance where _AUTO lexicons are meant to
be I<especially> useful:
if(-e $filename) {
go_process_file($filename)
} else {
- print "Couldn't find file \"$filename\"!\n";
+ print qq{Couldn't find file "$filename"!\n};
}
but since you anticipate localizing this, you write:
go_process_file($filename)
} else {
print $lh->maketext(
- "Couldn't find file \"[_1]\"!\n", $filename
+ qq{Couldn't find file "[_1]"!\n}, $filename
);
}
I<key> (because either it starts with a "_", or because none
of its lexicons have C<_AUTO =E<gt> 1,>), then we have
failed to find a normal way to maketext I<key>. What then
-happens in these failure conditions, depends on the $lh object
+happens in these failure conditions, depends on the $lh object's
"fail" attribute.
If the language handle has no "fail" attribute, maketext
If the language handle has a "fail" attribute whose value is a
coderef, then $lh->maketext(I<key>,...params...) gives up and calls:
- return &{$that_subref}($lh, $key, @params);
+ return $that_subref->($lh, $key, @params);
Otherwise, the "fail" attribute's value should be a string denoting
a method name, so that $lh->maketext(I<key>,...params...) can
# Set to nothing (i.e., so failure throws a plain exception)
$lh->fail_with( undef );
- # Simply read:
+ # Get the current value
$handler = $lh->fail_with();
Now, as to what you may want to do with these handlers: Maybe you'd
handler like this:
# Make all lookups fall back onto an English value,
- # but after we log it for later fingerpointing.
+ # but only after we log it for later fingerpointing.
my $lh_backup = ThisProject->get_handle('en');
open(LEX_FAIL_LOG, ">>wherever/lex.log") || die "GNAARGH $!";
sub lex_fail {
unreadable, or some essential resource being inaccessible.
One possibly useful value for the "fail" attribute is the method name
-"failure_handler_auto". This is a method defined in class
+"failure_handler_auto". This is a method defined in the class
Locale::Maketext itself. You set it with:
$lh->fail_with('failure_handler_auto');
return $lh->failure_handler_auto($key, @params);
But failure_handler_auto, instead of dying or anything, compiles
-$key, caching it in $lh->{'failure_lex'}{$key} = $complied,
+$key, caching it in
+
+ $lh->{'failure_lex'}{$key} = $complied
+
and then calls the compiled value, and returns that. (I.e., if
$key looks like bracket notation, $compiled is a sub, and we return
&{$compiled}(@params); but if $key is just a plain string, we just
use Projname::L10N;
my $lh = Projname::L10N->get_handle(...) || die "Language?";
-Assuming your call your class Projname::L10N, create a class
+Assuming you call your class Projname::L10N, create a class
consisting minimally of:
package Projname::L10N;
=item *
-You may at this point want to consider whether the your base class
-(Projname::L10N) that all lexicons inherit from (Projname::L10N::en,
-Projname::L10N::es, etc.) should be an _AUTO lexicon. It may be true
+You may at this point want to consider whether your base class
+(Projname::L10N), from which all lexicons inherit from (Projname::L10N::en,
+Projname::L10N::es, etc.), should be an _AUTO lexicon. It may be true
that in theory, all needed messages will be in each language class;
but in the presumably unlikely or "impossible" case of lookup failure,
you should consider whether your program should throw an exception,
Submit all messages/phrases/etc. to translators.
(You may, in fact, want to start with localizing to I<one> other language
-at first, if you're not sure that you've property abstracted the
+at first, if you're not sure that you've properly abstracted the
language-dependent parts of your code.)
Translators may request clarification of the situation in which a
L<Locale::Maketext::TPJ13|Locale::Maketext::TPJ13> -- my I<The Perl
Journal> article about Maketext. It explains many important concepts
underlying Locale::Maketext's design, and some insight into why
-Maketext is better than the plain old approach of just having
+Maketext is better than the plain old approach of having
message catalogs that are just databases of sprintf formats.
L<File::Findgrep|File::Findgrep> is a sample application/module
Revision history for Perl suite Locale::Maketext
- Time-stamp: "2004-03-30 21:38:07 AST"
+
+2007-11-17
+ * Release 1.12
+
+ Many doc changes from RT.
+
+ Silenced some "used only once" warnings under Perl 5.10.
+
+ $@ is now localized in case it gets interpolated. This was added
+ a while ago, but now there's a test for it, too.
+
+ Added warnings and strict to tests.
+
+ Cleaning up some Perl::Critic gripes.
+
+2007-05-07 Andy Lester
+ * Release 1.11_01
+
+ Fixed perlbug #33938
+ http://rt.perl.org/rt3//Public/Bug/Display.html?id=3393
+
+ Started cleaning up source per Perl::Critic.
+
2005-11-10 Andy Lester
- * Release 1.10:
+ * Release 1.10:
- New maintainer. No changes at all. Bumped up the version number
- and released it so that I can get the RT queue and any future mail.
+ New maintainer. No changes at all. Bumped up the version number
+ and released it so that I can get the RT queue and any future mail.
2004-03-30 Sean M. Burke sburke@cpan.org
- * Release 1.09:
+ * Release 1.09:
- * Moved the language-preference-detecting code into new module
- I18N::LangTags::Detect.
-
- Thanks to Autrijus Tang for catching some errors in the dist!
+ * Moved the language-preference-detecting code into new module
+ I18N::LangTags::Detect.
+
+ Thanks to Autrijus Tang for catching some errors in the dist!
2004-01-19 Sean M. Burke sburke@cpan.org
-
- * Release 1.08:
-
- * Corrected a one-line code bug in v1.07 that accidentally demoted
- all en-* tags in cases of lexicon-groups that had an en.pm but no
- en_*.pm. Thanks to Robert Spier for spotting this. Test added.
- So don't use v1.07!
-
- * Autrijus found some typoes in the TPJ article. Fixed.1
-
+
+ * Release 1.08:
+
+ * Corrected a one-line code bug in v1.07 that accidentally demoted
+ all en-* tags in cases of lexicon-groups that had an en.pm but no
+ en_*.pm. Thanks to Robert Spier for spotting this. Test added.
+ So don't use v1.07!
+
+ * Autrijus found some typoes in the TPJ article. Fixed.
+
2004-01-11 Sean M. Burke sburke@cpan.org
-
- * Release 1.07: Now uses a new and different rule for implicating
- superordinate language tags in accept-language lists. Previously,
- superordinates were just tacked onto the, so "en-US, ja", turned
- into "en-US, ja, en". However, this turned out to be suboptimal
- for many users of RT, a popular system using Maketext. The new
- rule is that a tag implicates superordinate forms right after it,
- unless those tags are explicitly stated elsewhere in the
- accept-languages list. So "en-US ja" becomes "en-US en ja". If
- you want "en" to be really lower, you have to actually state it
- there: "en-US ja en" is left as-is.
-
- The 04super.t and 05super.t tests in t/ have many many examples of
- this, including some strange corner cases.
-
- (In implementing this change, I also refactored some code in
- Maketext.pm, for hopefully improved readability. However,
- the above is the only actual change in behavior.)
-
+
+ * Release 1.07: Now uses a new and different rule for implicating
+ superordinate language tags in accept-language lists. Previously,
+ superordinates were just tacked onto the, so "en-US, ja", turned
+ into "en-US, ja, en". However, this turned out to be suboptimal
+ for many users of RT, a popular system using Maketext. The new
+ rule is that a tag implicates superordinate forms right after it,
+ unless those tags are explicitly stated elsewhere in the
+ accept-languages list. So "en-US ja" becomes "en-US en ja". If
+ you want "en" to be really lower, you have to actually state it
+ there: "en-US ja en" is left as-is.
+
+ The 04super.t and 05super.t tests in t/ have many many examples of
+ this, including some strange corner cases.
+
+ (In implementing this change, I also refactored some code in
+ Maketext.pm, for hopefully improved readability. However,
+ the above is the only actual change in behavior.)
+
2003-06-21 Sean M. Burke sburke@cpan.org
- * Release 1.06: Now has "use utf8" to make the things work
- happily. Some fancy footwork is required to make this work under
- pre-utf8 perl versions.
-
+ * Release 1.06: Now has "use utf8" to make the things work
+ happily. Some fancy footwork is required to make this work under
+ pre-utf8 perl versions.
+
2003-04-18 Sean M. Burke sburke@cpan.org
- * Release 1.05: Different Makefile.PL, same .pm code.
-
- Jesse Vincent, Hugo van der Sanden, and Jarkko Hietaniemi
- encourage me to add this to the makefile:
- ($] < 5.008) ? () : ( INSTALLDIRS => 'perl'),
- so that when you install this on a recent version of perl (5.8 or
- later), the installation will overwrite the Maketext.pm in your
- core library directory. Email me if this produces trouble for any
- of you folks out there, okay?
-
+ * Release 1.05: Different Makefile.PL, same .pm code.
+
+ Jesse Vincent, Hugo van der Sanden, and Jarkko Hietaniemi
+ encourage me to add this to the makefile:
+ ($] < 5.008) ? () : ( INSTALLDIRS => 'perl'),
+ so that when you install this on a recent version of perl (5.8 or
+ later), the installation will overwrite the Maketext.pm in your
+ core library directory. Email me if this produces trouble for any
+ of you folks out there, okay?
+
2003-04-02 Sean M. Burke sburke@cpan.org
- * Release 1.04: Implementing proper HTTP "tag;q=rank" parsing for
- get_handle. This should make all the difference for users/victims
- of the current version of Safari, which uses that syntax as well
- as inserts random languages with low q numbers.
- Thanks to Jesse Vincent and the whole RT junta for finding this.
+ * Release 1.04: Implementing proper HTTP "tag;q=rank" parsing for
+ get_handle. This should make all the difference for users/victims
+ of the current version of Safari, which uses that syntax as well
+ as inserts random languages with low q numbers.
+ Thanks to Jesse Vincent and the whole RT junta for finding this.
+
+ * Added more tests, now in t/
- * Added more tests, now in t/
+ * Lots of typo fixes to Maketext.pm. Thanks to Evan A. Zacks for
+ patient help in finding them all.
- * Lots of typo fixes to Maketext.pm. Thanks to Evan A. Zacks for
- patient help in finding them all.
-
2001-06-21 Sean M. Burke sburke@cpan.org
- * Release 1.03: basically cosmetic tweaks to the docs and the
- test.pl.
-
+ * Release 1.03: basically cosmetic tweaks to the docs and the
+ test.pl.
+
2001-06-20 Sean M. Burke sburke@cpan.org
- * Release 1.02: EBCDIC-compatability changes courtesy of Peter
- Prymmer. Added [*,...] as alias for [quant,...] and [#,...] as an
- alias for [numf,...]. Added some more things to test.pl
-
+ * Release 1.02: EBCDIC-compatability changes courtesy of Peter
+ Prymmer. Added [*,...] as alias for [quant,...] and [#,...] as an
+ alias for [numf,...]. Added some more things to test.pl
+
2001-05-25 Sean M. Burke sburke@cpan.org
- * Release 1.01: total rewrite. Docs are massive now.
- Including TPJ13 article now.
-
+ * Release 1.01: total rewrite. Docs are massive now.
+ Including TPJ13 article now.
+
2000-05-14 Sean M. Burke sburke@cpan.org
- * Release 0.18: only change, regrettably, is a better makefile,
- and it my email address has changed.
+ * Release 0.18: only change, regrettably, is a better makefile,
+ and it my email address has changed.
1999-03-15 Sean M. Burke sburke@netadventure.net
- * Release 0.17: Public alpha release
- Underdocumented.
+ * Release 0.17: Public alpha release
+ Underdocumented.
-
package Locale::Maketext::Guts;
-BEGIN { *zorp = sub { return scalar @_ } unless defined &zorp; }
- # Just so we're nice and define SOMETHING in "our" package.
+
+BEGIN {
+ # Just so we're nice and define SOMETHING in "our" package.
+ *zorp = sub { return scalar @_ } unless defined &zorp;
+}
package Locale::Maketext;
use strict;
use vars qw($USE_LITERALS $GUTSPATH);
BEGIN {
- $GUTSPATH = __FILE__;
- *DEBUG = sub () {0} unless defined &DEBUG;
+ $GUTSPATH = __FILE__;
+ *DEBUG = sub () {0} unless defined &DEBUG;
}
use utf8;
sub _compile {
- # This big scary routine compiles an entry.
- # It returns either a coderef if there's brackety bits in this, or
- # otherwise a ref to a scalar.
-
- my $target = ref($_[0]) || $_[0];
-
- my(@code);
- my(@c) = (''); # "chunks" -- scratch.
- my $call_count = 0;
- my $big_pile = '';
- {
- my $in_group = 0; # start out outside a group
- my($m, @params); # scratch
-
- while($_[1] =~ # Iterate over chunks.
- m<\G(
- [^\~\[\]]+ # non-~[] stuff
- |
- ~. # ~[, ~], ~~, ~other
- |
- \[ # [ presumably opening a group
- |
- \] # ] presumably closing a group
- |
- ~ # terminal ~ ?
- |
- $
- )>xgs
- ) {
- print " \"$1\"\n" if DEBUG > 2;
-
- if($1 eq '[' or $1 eq '') { # "[" or end
- # Whether this is "[" or end, force processing of any
- # preceding literal.
- if($in_group) {
- if($1 eq '') {
- $target->_die_pointing($_[1], "Unterminated bracket group");
- } else {
- $target->_die_pointing($_[1], "You can't nest bracket groups");
- }
- } else {
- if($1 eq '') {
- print " [end-string]\n" if DEBUG > 2;
- } else {
- $in_group = 1;
- }
- die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
- if(length $c[-1]) {
- # Now actually processing the preceding literal
- $big_pile .= $c[-1];
- if($USE_LITERALS and (
- (ord('A') == 65)
- ? $c[-1] !~ m<[^\x20-\x7E]>s
- # ASCII very safe chars
- : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
- # EBCDIC very safe chars
- )) {
- # normal case -- all very safe chars
- $c[-1] =~ s/'/\\'/g;
- push @code, q{ '} . $c[-1] . "',\n";
- $c[-1] = ''; # reuse this slot
- } else {
- push @code, ' $c[' . $#c . "],\n";
- push @c, ''; # new chunk
+ # This big scary routine compiles an entry.
+ # It returns either a coderef if there's brackety bits in this, or
+ # otherwise a ref to a scalar.
+
+ my $target = ref($_[0]) || $_[0];
+
+ my(@code);
+ my(@c) = (''); # "chunks" -- scratch.
+ my $call_count = 0;
+ my $big_pile = '';
+ {
+ my $in_group = 0; # start out outside a group
+ my($m, @params); # scratch
+
+ while($_[1] =~ # Iterate over chunks.
+ m/\G(
+ [^\~\[\]]+ # non-~[] stuff
+ |
+ ~. # ~[, ~], ~~, ~other
+ |
+ \[ # [ presumably opening a group
+ |
+ \] # ] presumably closing a group
+ |
+ ~ # terminal ~ ?
+ |
+ $
+ )/xgs
+ ) {
+ DEBUG>2 and print qq{ "$1"\n};
+
+ if($1 eq '[' or $1 eq '') { # "[" or end
+ # Whether this is "[" or end, force processing of any
+ # preceding literal.
+ if($in_group) {
+ if($1 eq '') {
+ $target->_die_pointing($_[1], 'Unterminated bracket group');
+ }
+ else {
+ $target->_die_pointing($_[1], 'You can\'t nest bracket groups');
+ }
+ }
+ else {
+ if ($1 eq '') {
+ DEBUG>2 and print " [end-string]\n";
+ }
+ else {
+ $in_group = 1;
+ }
+ die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
+ if(length $c[-1]) {
+ # Now actually processing the preceding literal
+ $big_pile .= $c[-1];
+ if($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $c[-1] !~ m/[^\x20-\x7E]/s
+ # ASCII very safe chars
+ : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # normal case -- all very safe chars
+ $c[-1] =~ s/'/\\'/g;
+ push @code, q{ '} . $c[-1] . "',\n";
+ $c[-1] = ''; # reuse this slot
+ }
+ else {
+ push @code, ' $c[' . $#c . "],\n";
+ push @c, ''; # new chunk
+ }
+ }
+ # else just ignore the empty string.
+ }
+
}
- }
- # else just ignore the empty string.
- }
+ elsif($1 eq ']') { # "]"
+ # close group -- go back in-band
+ if($in_group) {
+ $in_group = 0;
+
+ DEBUG>2 and print " --Closing group [$c[-1]]\n";
+
+ # And now process the group...
+
+ if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
+ DEBUG > 2 and print " -- (Ignoring)\n";
+ $c[-1] = ''; # reset out chink
+ next;
+ }
+
+ #$c[-1] =~ s/^\s+//s;
+ #$c[-1] =~ s/\s+$//s;
+ ($m,@params) = split(/,/, $c[-1], -1); # was /\s*,\s*/
+
+ # A bit of a hack -- we've turned "~,"'s into DELs, so turn
+ # 'em into real commas here.
+ if (ord('A') == 65) { # ASCII, etc
+ foreach($m, @params) { tr/\x7F/,/ }
+ }
+ else { # EBCDIC (1047, 0037, POSIX-BC)
+ # Thanks to Peter Prymmer for the EBCDIC handling
+ foreach($m, @params) { tr/\x07/,/ }
+ }
+
+ # Special-case handling of some method names:
+ if($m eq '_*' or $m =~ m/^_(-?\d+)$/s) {
+ # Treat [_1,...] as [,_1,...], etc.
+ unshift @params, $m;
+ $m = '';
+ }
+ elsif($m eq '*') {
+ $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
+ }
+ elsif($m eq '#') {
+ $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
+ }
+
+ # Most common case: a simple, legal-looking method name
+ if($m eq '') {
+ # 0-length method name means to just interpolate:
+ push @code, ' (';
+ }
+ elsif($m =~ /^\w+(?:\:\:\w+)*$/s
+ and $m !~ m/(?:^|\:)\d/s
+ # exclude starting a (sub)package or symbol with a digit
+ ) {
+ # Yes, it even supports the demented (and undocumented?)
+ # $obj->Foo::bar(...) syntax.
+ $target->_die_pointing(
+ $_[1], q{Can't use "SUPER::" in a bracket-group method},
+ 2 + length($c[-1])
+ )
+ if $m =~ m/^SUPER::/s;
+ # Because for SUPER:: to work, we'd have to compile this into
+ # the right package, and that seems just not worth the bother,
+ # unless someone convinces me otherwise.
+
+ push @code, ' $_[0]->' . $m . '(';
+ }
+ else {
+ # TODO: implement something? or just too icky to consider?
+ $target->_die_pointing(
+ $_[1],
+ "Can't use \"$m\" as a method name in bracket group",
+ 2 + length($c[-1])
+ );
+ }
+
+ pop @c; # we don't need that chunk anymore
+ ++$call_count;
+
+ foreach my $p (@params) {
+ if($p eq '_*') {
+ # Meaning: all parameters except $_[0]
+ $code[-1] .= ' @_[1 .. $#_], ';
+ # and yes, that does the right thing for all @_ < 3
+ }
+ elsif($p =~ m/^_(-?\d+)$/s) {
+ # _3 meaning $_[3]
+ $code[-1] .= '$_[' . (0 + $1) . '], ';
+ }
+ elsif($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $p !~ m/[^\x20-\x7E]/s
+ # ASCII very safe chars
+ : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # Normal case: a literal containing only safe characters
+ $p =~ s/'/\\'/g;
+ $code[-1] .= q{'} . $p . q{', };
+ }
+ else {
+ # Stow it on the chunk-stack, and just refer to that.
+ push @c, $p;
+ push @code, ' $c[' . $#c . '], ';
+ }
+ }
+ $code[-1] .= "),\n";
+
+ push @c, '';
+ }
+ else {
+ $target->_die_pointing($_[1], q{Unbalanced ']'});
+ }
- } elsif($1 eq ']') { # "]"
- # close group -- go back in-band
- if($in_group) {
- $in_group = 0;
-
- print " --Closing group [$c[-1]]\n" if DEBUG > 2;
-
- # And now process the group...
-
- if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
- DEBUG > 2 and print " -- (Ignoring)\n";
- $c[-1] = ''; # reset out chink
- next;
- }
-
- #$c[-1] =~ s/^\s+//s;
- #$c[-1] =~ s/\s+$//s;
- ($m,@params) = split(",", $c[-1], -1); # was /\s*,\s*/
-
- # A bit of a hack -- we've turned "~,"'s into DELs, so turn
- # 'em into real commas here.
- if (ord('A') == 65) { # ASCII, etc
- foreach($m, @params) { tr/\x7F/,/ }
- } else { # EBCDIC (1047, 0037, POSIX-BC)
- # Thanks to Peter Prymmer for the EBCDIC handling
- foreach($m, @params) { tr/\x07/,/ }
- }
-
- # Special-case handling of some method names:
- if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
- # Treat [_1,...] as [,_1,...], etc.
- unshift @params, $m;
- $m = '';
- } elsif($m eq '*') {
- $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
- } elsif($m eq '#') {
- $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
- }
-
- # Most common case: a simple, legal-looking method name
- if($m eq '') {
- # 0-length method name means to just interpolate:
- push @code, ' (';
- } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
- and $m !~ m<(?:^|\:)\d>s
- # exclude starting a (sub)package or symbol with a digit
- ) {
- # Yes, it even supports the demented (and undocumented?)
- # $obj->Foo::bar(...) syntax.
- $target->_die_pointing(
- $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
- 2 + length($c[-1])
- )
- if $m =~ m/^SUPER::/s;
- # Because for SUPER:: to work, we'd have to compile this into
- # the right package, and that seems just not worth the bother,
- # unless someone convinces me otherwise.
-
- push @code, ' $_[0]->' . $m . '(';
- } else {
- # TODO: implement something? or just too icky to consider?
- $target->_die_pointing(
- $_[1],
- "Can't use \"$m\" as a method name in bracket group",
- 2 + length($c[-1])
- );
- }
-
- pop @c; # we don't need that chunk anymore
- ++$call_count;
-
- foreach my $p (@params) {
- if($p eq '_*') {
- # Meaning: all parameters except $_[0]
- $code[-1] .= ' @_[1 .. $#_], ';
- # and yes, that does the right thing for all @_ < 3
- } elsif($p =~ m<^_(-?\d+)$>s) {
- # _3 meaning $_[3]
- $code[-1] .= '$_[' . (0 + $1) . '], ';
- } elsif($USE_LITERALS and (
- (ord('A') == 65)
- ? $p !~ m<[^\x20-\x7E]>s
- # ASCII very safe chars
- : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
- # EBCDIC very safe chars
- )) {
- # Normal case: a literal containing only safe characters
- $p =~ s/'/\\'/g;
- $code[-1] .= q{'} . $p . q{', };
- } else {
- # Stow it on the chunk-stack, and just refer to that.
- push @c, $p;
- push @code, ' $c[' . $#c . "], ";
}
- }
- $code[-1] .= "),\n";
+ elsif(substr($1,0,1) ne '~') {
+ # it's stuff not containing "~" or "[" or "]"
+ # i.e., a literal blob
+ $c[-1] .= $1;
- push @c, '';
- } else {
- $target->_die_pointing($_[1], "Unbalanced ']'");
- }
-
- } elsif(substr($1,0,1) ne '~') {
- # it's stuff not containing "~" or "[" or "]"
- # i.e., a literal blob
- $c[-1] .= $1;
-
- } elsif($1 eq '~~') { # "~~"
- $c[-1] .= '~';
-
- } elsif($1 eq '~[') { # "~["
- $c[-1] .= '[';
-
- } elsif($1 eq '~]') { # "~]"
- $c[-1] .= ']';
-
- } elsif($1 eq '~,') { # "~,"
- if($in_group) {
- # This is a hack, based on the assumption that no-one will actually
- # want a DEL inside a bracket group. Let's hope that's it's true.
- if (ord('A') == 65) { # ASCII etc
- $c[-1] .= "\x7F";
- } else { # EBCDIC (cp 1047, 0037, POSIX-BC)
- $c[-1] .= "\x07";
- }
- } else {
- $c[-1] .= '~,';
+ }
+ elsif($1 eq '~~') { # "~~"
+ $c[-1] .= '~';
+
+ }
+ elsif($1 eq '~[') { # "~["
+ $c[-1] .= '[';
+
+ }
+ elsif($1 eq '~]') { # "~]"
+ $c[-1] .= ']';
+
+ }
+ elsif($1 eq '~,') { # "~,"
+ if($in_group) {
+ # This is a hack, based on the assumption that no-one will actually
+ # want a DEL inside a bracket group. Let's hope that's it's true.
+ if (ord('A') == 65) { # ASCII etc
+ $c[-1] .= "\x7F";
+ }
+ else { # EBCDIC (cp 1047, 0037, POSIX-BC)
+ $c[-1] .= "\x07";
+ }
+ }
+ else {
+ $c[-1] .= '~,';
+ }
+
+ }
+ elsif($1 eq '~') { # possible only at string-end, it seems.
+ $c[-1] .= '~';
+
+ }
+ else {
+ # It's a "~X" where X is not a special character.
+ # Consider it a literal ~ and X.
+ $c[-1] .= $1;
+ }
}
-
- } elsif($1 eq '~') { # possible only at string-end, it seems.
- $c[-1] .= '~';
-
- } else {
- # It's a "~X" where X is not a special character.
- # Consider it a literal ~ and X.
- $c[-1] .= $1;
- }
}
- }
-
- if($call_count) {
- undef $big_pile; # Well, nevermind that.
- } else {
- # It's all literals! Ahwell, that can happen.
- # So don't bother with the eval. Return a SCALAR reference.
- return \$big_pile;
- }
-
- die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
- print scalar(@c), " chunks under closure\n" if DEBUG;
- if(@code == 0) { # not possible?
- print "Empty code\n" if DEBUG;
- return \'';
- } elsif(@code > 1) { # most cases, presumably!
- unshift @code, "join '',\n";
- }
- unshift @code, "use strict; sub {\n";
- push @code, "}\n";
-
- print @code if DEBUG;
- my $sub = eval(join '', @code);
- die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
- return $sub;
+
+ if($call_count) {
+ undef $big_pile; # Well, nevermind that.
+ }
+ else {
+ # It's all literals! Ahwell, that can happen.
+ # So don't bother with the eval. Return a SCALAR reference.
+ return \$big_pile;
+ }
+
+ die q{Last chunk isn't null??} if @c and length $c[-1]; # sanity
+ DEBUG and print scalar(@c), " chunks under closure\n";
+ if(@code == 0) { # not possible?
+ DEBUG and print "Empty code\n";
+ return \'';
+ }
+ elsif(@code > 1) { # most cases, presumably!
+ unshift @code, "join '',\n";
+ }
+ unshift @code, "use strict; sub {\n";
+ push @code, "}\n";
+
+ DEBUG and print @code;
+ my $sub = eval(join '', @code);
+ die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
+ return $sub;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _die_pointing {
- # This is used by _compile to throw a fatal error
- my $target = shift; # class name
- # ...leaving $_[0] the error-causing text, and $_[1] the error message
-
- my $i = index($_[0], "\n");
-
- my $pointy;
- my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
- if($pos < 1) {
- $pointy = "^=== near there\n";
- } else { # we need to space over
- my $first_tab = index($_[0], "\t");
- if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
- # No tabs, or the first tab is harmlessly after where we will point to,
- # AND we're far enough from the margin that we can draw a proper arrow.
- $pointy = ('=' x $pos) . "^ near there\n";
- } else {
- # tabs screw everything up!
- $pointy = substr($_[0],0,$pos);
- $pointy =~ tr/\t //cd;
- # make everything into whitespace, but preseving tabs
- $pointy .= "^=== near there\n";
+ # This is used by _compile to throw a fatal error
+ my $target = shift; # class name
+ # ...leaving $_[0] the error-causing text, and $_[1] the error message
+
+ my $i = index($_[0], "\n");
+
+ my $pointy;
+ my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
+ if($pos < 1) {
+ $pointy = "^=== near there\n";
+ }
+ else { # we need to space over
+ my $first_tab = index($_[0], "\t");
+ if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
+ # No tabs, or the first tab is harmlessly after where we will point to,
+ # AND we're far enough from the margin that we can draw a proper arrow.
+ $pointy = ('=' x $pos) . "^ near there\n";
+ }
+ else {
+ # tabs screw everything up!
+ $pointy = substr($_[0],0,$pos);
+ $pointy =~ tr/\t //cd;
+ # make everything into whitespace, but preseving tabs
+ $pointy .= "^=== near there\n";
+ }
+ }
+
+ my $errmsg = "$_[1], in\:\n$_[0]";
+
+ if($i == -1) {
+ # No newline.
+ $errmsg .= "\n" . $pointy;
+ }
+ elsif($i == (length($_[0]) - 1) ) {
+ # Already has a newline at end.
+ $errmsg .= $pointy;
+ }
+ else {
+ # don't bother with the pointy bit, I guess.
}
- }
-
- my $errmsg = "$_[1], in\:\n$_[0]";
-
- if($i == -1) {
- # No newline.
- $errmsg .= "\n" . $pointy;
- } elsif($i == (length($_[0]) - 1) ) {
- # Already has a newline at end.
- $errmsg .= $pointy;
- } else {
- # don't bother with the pointy bit, I guess.
- }
- Carp::croak( "$errmsg via $target, as used" );
+ Carp::croak( "$errmsg via $target, as used" );
}
1;
-
package Locale::Maketext::GutsLoader;
+
use strict;
sub zorp { return scalar @_ }
BEGIN {
- $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__;
- *Locale::Maketext::DEBUG = sub () {0}
- unless defined &Locale::Maketext::DEBUG;
+ $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__;
+ *Locale::Maketext::DEBUG = sub () {0}
+ unless defined &Locale::Maketext::DEBUG;
}
#
Locale::Maketext::DEBUG and print "Requiring Locale::Maketext::Guts...\n";
eval 'require Locale::Maketext::Guts';
-if($@) {
- my $path = $Locale::Maketext::GUTSPATH;
-
- die "Can't load Locale::Maketext::Guts\nAborting" unless $path;
-
- die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting"
- unless -e $path and -f _ and -r _;
-
- open(IN, $path) or die "Can't read-open $path\nAborting";
-
- my $source;
- { local $/; $source = <IN>; }
- close(IN);
- unless( $source =~ s/\b(use utf8)/# $1/ ) {
- Locale::Maketext::DEBUG and
- print "I didn't see 'use utf8' in $path\n";
- }
- eval $source;
- die "Can't compile $path\n...The error I got was:\n$@\nAborting" if $@;
- Locale::Maketext::DEBUG and print "Non-utf8'd Locale::Maketext::Guts fine\n";
-} else {
- Locale::Maketext::DEBUG and print "Loaded Locale::Maketext::Guts fine\n";
+if ($@) {
+ my $path = $Locale::Maketext::GUTSPATH;
+
+ die "Can't load Locale::Maketext::Guts\nAborting" unless $path;
+
+ die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting"
+ unless -e $path and -f _ and -r _;
+
+ open(IN, $path) or die "Can't read-open $path\nAborting";
+
+ my $source;
+ { local $/; $source = <IN>; }
+ close(IN);
+ unless( $source =~ s/\b(use utf8)/# $1/ ) {
+ Locale::Maketext::DEBUG and
+ print "I didn't see 'use utf8' in $path\n";
+ }
+ eval $source;
+ die "Can't compile $path\n...The error I got was:\n$@\nAborting" if $@;
+ Locale::Maketext::DEBUG and print "Non-utf8'd Locale::Maketext::Guts fine\n";
+}
+else {
+ Locale::Maketext::DEBUG and print "Loaded Locale::Maketext::Guts fine\n";
}
1;
-
-
# This document contains text in Perl "POD" format.
# Use a POD viewer like perldoc or perlman to render it.
-# This corrects some typoes in the previous release.
-
=head1 NAME
Locale::Maketext::TPJ13 -- article about software localization
=head1 DESCRIPTION
The following article by Sean M. Burke and Jordan Lachler
-first appeared in I<The Perl
-Journal> #13 and is copyright 1999 The Perl Journal. It appears
+first appeared in I<The Perl Journal> #13
+and is copyright 1999 The Perl Journal. It appears
courtesy of Jon Orwant and The Perl Journal. This document may be
distributed under the same terms as Perl itself.
+#!/usr/bin/perl -Tw
require 5;
-# Time-stamp: "2004-03-30 17:02:53 AST"
-# Summary of, well, things.
+use strict;
-use Test;
-BEGIN {plan tests => 2};
+use Test::More tests => 1;
-ok 1;
-
-use Locale::Maketext;
-
-#chdir "t" if -e "t";
+BEGIN {
+ use_ok( 'Locale::Maketext' );
+}
-{
- my @out;
- push @out,
+my @out;
+push @out,
"\n\nPerl v",
defined($^V) ? sprintf('%vd', $^V) : $],
" under $^O ",
(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
- ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (),
+ ? ('(Win32::BuildNumber ', &Win32::BuildNumber(), ')') : (),
(defined $MacPerl::Version)
- ? ("(MacPerl version $MacPerl::Version)") : (),
+ ? ("(MacPerl version $MacPerl::Version)") : (),
"\n"
- ;
+;
- # Ugly code to walk the symbol tables:
- my %v;
- my @stack = (''); # start out in %::
- my $this;
- my $count = 0;
- my $pref;
- while(@stack) {
+# Ugly code to walk the symbol tables:
+my %v;
+my @stack = (''); # start out in %::
+my $this;
+my $count = 0;
+my $pref;
+while(@stack) {
$this = shift @stack;
- die "Too many packages?" if ++$count > 1000;
+ die 'Too many packages?' if ++$count > 1000;
next if exists $v{$this};
next if $this eq 'main'; # %main:: is %::
- #print "Peeking at $this => ${$this . '::VERSION'}\n";
-
- if(defined ${$this . '::VERSION'} ) {
- $v{$this} = ${$this . '::VERSION'}
- } elsif(
- defined *{$this . '::ISA'} or defined &{$this . '::import'}
- or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"})
- # If it has an ISA, an import, or any subs...
+ no strict 'refs';
+ if ( defined ${$this . '::VERSION'} ) {
+ $v{$this} = ${$this . '::VERSION'}
+ }
+ elsif (
+ defined *{$this . '::ISA'} or defined &{$this . '::import'}
+ or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . '::'})
+ # If it has an ISA, an import, or any subs...
) {
- # It's a class/module with no version.
- $v{$this} = undef;
- } else {
- # It's probably an unpopulated package.
- ## $v{$this} = '...';
+ # It's a class/module with no version.
+ $v{$this} = undef;
+ }
+ else {
+ # It's probably an unpopulated package.
+ ## $v{$this} = '...';
}
-
+
$pref = length($this) ? "$this\::" : '';
push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'};
- #print "Stack: @stack\n";
- }
- push @out, " Modules in memory:\n";
- delete @v{'', '[none]'};
- foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
- $indent = ' ' x (2 + ($p =~ tr/:/:/));
+}
+push @out, " Modules in memory:\n";
+delete @v{'', '[none]'};
+foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
+ my $indent = ' ' x (2 + ($p =~ tr/:/:/));
push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n";
- }
- push @out, sprintf "[at %s (local) / %s (GMT)]\n",
- scalar(gmtime), scalar(localtime);
- my $x = join '', @out;
- $x =~ s/^/#/mg;
- print $x;
}
+push @out, sprintf "[at %s (local) / %s (GMT)]\n", scalar(gmtime), scalar(localtime);
+my $x = join '', @out;
+$x =~ s/^/#/mg;
+print $x;
-print "# Running",
- (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
- "#\n",
-;
+my $ascii = (chr(65) eq 'A') ? 'an ASCII' : 'a non-ASCII';
+print "# Running in $ascii world.\n";
print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n";
print "# \%INC:\n";
foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
- print "# [$x] = [", $INC{$x} || '', "]\n";
+ print "# [$x] = [", $INC{$x} || '', "]\n";
}
-
-ok 1;
-
+#!/usr/bin/perl -Tw
-require 5;
-use Test;
-BEGIN { plan tests => 6; }
-use Locale::Maketext 1.01;
-print "# Hi there...\n";
-ok 1;
+use strict;
+use Test::More tests => 5;
+
+BEGIN {
+ use_ok( 'Locale::Maketext' );
+}
# declare some classes...
{
package Woozle;
- @ISA = ('Locale::Maketext');
+ our @ISA = ('Locale::Maketext');
sub dubbil { return $_[1] * 2 }
sub numerate { return $_[2] . 'en' }
}
{
package Woozle::elx;
- @ISA = ('Woozle');
- %Lexicon = (
+ our @ISA = ('Woozle');
+ our %Lexicon = (
'd2' => 'hum [dubbil,_1]',
'd3' => 'hoo [quant,_1,zaz]',
'd4' => 'hoo [*,_1,zaz]',
keys %Lexicon; # dodges the 'used only once' warning
}
-ok defined( $lh = Woozle->get_handle('elx') ) && ref($lh);
-ok $lh && $lh->maketext('d2', 7), "hum 14" ;
-ok $lh && $lh->maketext('d3', 7), "hoo 7 zazen" ;
-ok $lh && $lh->maketext('d4', 7), "hoo 7 zazen" ;
-
-print "# Byebye!\n";
-ok 1;
+my $lh = Woozle->get_handle('elx');
+isa_ok( $lh, 'Woozle::elx' );
+is( $lh->maketext('d2', 7), 'hum 14' );
+is( $lh->maketext('d3', 7), 'hoo 7 zazen' );
+is( $lh->maketext('d4', 7), 'hoo 7 zazen' );
+#!/usr/bin/perl -Tw
-require 5;
-use Test;
-BEGIN { plan tests => 11; }
-use Locale::Maketext 1.01;
-print "# Hi there...\n";
-ok 1;
+use strict;
+use Test::More tests => 10;
+
+BEGIN {
+ use_ok( 'Locale::Maketext' );
+}
print "# --- Making sure that get_handle works ---\n";
# declare some classes...
{
- package Woozle;
- @ISA = ('Locale::Maketext');
- sub dubbil { return $_[1] * 2 }
- sub numerate { return $_[2] . 'en' }
+ package Woozle;
+ our @ISA = ('Locale::Maketext');
+ sub dubbil { return $_[1] * 2 }
+ sub numerate { return $_[2] . 'en' }
}
{
- package Woozle::eu_mt;
- @ISA = ('Woozle');
- %Lexicon = (
- 'd2' => 'hum [dubbil,_1]',
- 'd3' => 'hoo [quant,_1,zaz]',
- 'd4' => 'hoo [*,_1,zaz]',
- );
- keys %Lexicon; # dodges the 'used only once' warning
+ package Woozle::eu_mt;
+ our @ISA = ('Woozle');
+ our %Lexicon = (
+ 'd2' => 'hum [dubbil,_1]',
+ 'd3' => 'hoo [quant,_1,zaz]',
+ 'd4' => 'hoo [*,_1,zaz]',
+ );
+ keys %Lexicon; # dodges the 'used only once' warning
}
-my $lh;
-print "# Basic sanity:\n";
-ok defined( $lh = Woozle->get_handle('eu-mt') ) && ref($lh);
-ok $lh && $lh->maketext('d2', 7), "hum 14" ;
-
-
+my $lh = Woozle->get_handle('eu-mt');
+isa_ok( $lh, 'Woozle::eu_mt' );
+is( $lh->maketext( 'd2', 7 ), 'hum 14' );
print "# Make sure we can assign to ENV entries\n",
- "# (Otherwise we can't run the subsequent tests)...\n";
+"# (Otherwise we can't run the subsequent tests)...\n";
$ENV{'MYORP'} = 'Zing';
-ok $ENV{'MYORP'}, 'Zing';
+is( $ENV{'MYORP'}, 'Zing' );
$ENV{'SWUZ'} = 'KLORTHO HOOBOY';
-ok $ENV{'SWUZ'}, 'KLORTHO HOOBOY';
+is( $ENV{'SWUZ'}, 'KLORTHO HOOBOY' );
delete $ENV{'MYORP'};
delete $ENV{'SWUZ'};
$ENV{'REQUEST_METHOD'} = '';
$ENV{'LANG'} = 'Eu_MT';
$ENV{'LANGUAGE'} = '';
-ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+$lh = Woozle->get_handle();
+isa_ok( $lh, 'Woozle::eu_mt' );
print "# Test LANGUAGE...\n";
$ENV{'LANG'} = '';
$ENV{'LANGUAGE'} = 'Eu-MT';
-ok defined( $lh = Woozle->get_handle() ) && ref($lh);
+$lh = Woozle->get_handle();
+isa_ok( $lh, 'Woozle::eu_mt' );
print "# Test HTTP_ACCEPT_LANGUAGE...\n";
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'eu-MT';
-ok defined( $lh = Woozle->get_handle() ) && ref($lh);
-$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eu-MT, i-klung';
-ok defined( $lh = Woozle->get_handle() ) && ref($lh);
-$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eU-Mt, i-klung';
-ok defined( $lh = Woozle->get_handle() ) && ref($lh);
-
+$lh = Woozle->get_handle();
+isa_ok( $lh, 'Woozle::eu_mt' );
-print "# Byebye!\n";
-ok 1;
+$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eu-MT, i-klung';
+$lh = Woozle->get_handle();
+isa_ok( $lh, 'Woozle::eu_mt' );
+$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'x-plorp, zaz, eU-Mt, i-klung';
+$lh = Woozle->get_handle();
+isa_ok( $lh, 'Woozle::eu_mt' );
+#!/usr/bin/perl -Tw
+
+use strict;
-require 5;
use Test;
BEGIN { plan tests => 4; }
use Locale::Maketext;
# declare a class...
{
package Woozle;
- @ISA = ('Locale::Maketext');
- %Lexicon = (
+ our @ISA = ('Locale::Maketext');
+ our %Lexicon = (
_AUTO => 1
);
keys %Lexicon; # dodges the 'used only once' warning
print "# Make sure \$@ is localized...\n";
$@ = 'foo';
-ok $lh && $lh->maketext('Eval error: [_1]', $@), "Eval error: foo";
+ok $lh && $lh->maketext('Eval error: [_1]', $@), 'Eval error: foo';
print "# Byebye!\n";
ok 1;
+#!/usr/bin/perl -Tw
-# Time-stamp: "2004-03-30 18:02:24 AST"
-#sub Locale::Maketext::DEBUG () {10}
-use Locale::Maketext;
+use strict;
+use Test::More tests=>19;
-use Test;
-BEGIN { plan tests => 19 };
+BEGIN {
+ use_ok( 'Locale::Maketext' );
+}
print "#\n# Testing non-tight insertion of super-ordinate language tags...\n#\n";
$Locale::Maketext::MATCH_SUPERS_TIGHTLY = 0;
-foreach my $in (@in) {
- $in =~ s/^\s+//s;
- $in =~ s/\s+$//s;
- $in =~ s/#.+//s;
- next unless $in =~ m/\S/;
-
- my(@in, @should);
- {
+foreach my $in ( @in ) {
+ $in =~ s/^\s+//s;
+ $in =~ s/\s+$//s;
+ $in =~ s/#.+//s;
+ next unless $in =~ m/\S/;
+
die "What kind of line is <$in>?!"
- unless $in =~ m/^(.+)=>(.+)$/s;
-
- my($i,$s) = ($1, $2);
- @in = ($i =~ m/(\S+)/g);
- @should = ($s =~ m/(\S+)/g);
- #print "{@in}{@should}\n";
- }
- my @out = Locale::Maketext->_add_supers(
- ("@in" eq 'NIX') ? () : @in
- );
- #print "O: ", join(' ', map "<$_>", @out), "\n";
- @out = 'NIX' unless @out;
+ unless $in =~ m/^(.+)=>(.+)$/s;
-
- if( @out == @should
- and lc( join "\e", @out ) eq lc( join "\e", @should )
- ) {
- print "# Happily got [@out] from [$in]\n";
- ok 1;
- } else {
- ok 0;
- print "#!!Got: [@out]\n",
- "#!! but wanted: [@should]\n",
- "#!! from \"$in\"\n#\n";
- }
-}
+ my ($i,$s) = ($1, $2);
+ my @in = ($i =~ m/(\S+)/g);
+ my @should = ($s =~ m/(\S+)/g);
-print "#\n#\n# Bye-bye!\n";
-ok 1;
+ my @out = Locale::Maketext->_add_supers(
+ ("@in" eq 'NIX') ? () : @in
+ );
+ @out = 'NIX' unless @out;
+ is_deeply( \@out, \@should, "Happily got [@out] from $in" );
+}
+#!/usr/bin/perl -Tw
-#sub Locale::Maketext::DEBUG () {10}
-use Locale::Maketext;
+use strict;
+use Test::More tests => 26;
+
+BEGIN {
+ use_ok( 'Locale::Maketext' );
+}
-use Test;
-BEGIN { plan tests => 26 };
print "#\n# Testing tight insertion of super-ordinate language tags...\n#\n";
my @in = grep m/\S/, split /[\n\r]/, q{
sub uniq { my %seen; return grep(!($seen{$_}++), @_); }
-foreach my $in (@in) {
- $in =~ s/^\s+//s;
- $in =~ s/\s+$//s;
- $in =~ s/#.+//s;
- next unless $in =~ m/\S/;
-
- my(@in, @should);
- {
+foreach my $in ( @in ) {
+ $in =~ s/^\s+//s;
+ $in =~ s/\s+$//s;
+ $in =~ s/#.+//s;
+ next unless $in =~ m/\S/;
+
die "What kind of line is <$in>?!"
- unless $in =~ m/^(.+)=>(.+)$/s;
-
- my($i,$s) = ($1, $2);
- @in = ($i =~ m/(\S+)/g);
- @should = ($s =~ m/(\S+)/g);
- #print "{@in}{@should}\n";
- }
- my @out = uniq( Locale::Maketext->_add_supers(
- ("@in" eq 'NIX') ? () : @in
- ) );
- #print "O: ", join(' ', map "<$_>", @out), "\n";
- @out = 'NIX' unless @out;
-
-
- if( @out == @should
- and lc( join "\e", @out ) eq lc( join "\e", @should )
- ) {
- print "# Happily got [@out] from [$in]\n";
- ok 1;
- } else {
- ok 0;
- print "#!!Got: [@out]\n",
- "#!! but wanted: [@should]\n",
- "#!! from \"$in\"\n#\n";
- }
-}
+ unless $in =~ m/^(.+)=>(.+)$/s;
+
+ my ($i,$s) = ($1, $2);
+ my @in = ($i =~ m/(\S+)/g);
+ my @should = ($s =~ m/(\S+)/g);
-print "#\n#\n# Bye-bye!\n";
-ok 1;
+ my @out = uniq( Locale::Maketext->_add_supers(
+ ("@in" eq 'NIX') ? () : @in
+ ) );
+ @out = 'NIX' unless @out;
+ is_deeply( \@out, \@should, "Happily got [@out] from $in" );
+}
+#!/usr/bin/perl -Tw
-require 5;
use strict;
-use Test;
+use Test::More tests => 3;
-# use a BEGIN block so we print our plan before MyModule is loaded
-BEGIN { plan tests => 3 }
-
-ok 1;
-print "# Locale::Maketext version $Locale::Maketext::VERSION\n";
+BEGIN {
+ use_ok( 'Locale::Maketext' );
+}
-#sub Locale::Maketext::DEBUG () {10};
-use Locale::Maketext ();
-{ package Whunk::L10N; use vars qw(@ISA %Lexicon); @ISA = 'Locale::Maketext';
- %Lexicon = ("hello" => "SROBLR!");
+{
+ package Whunk::L10N;
+ use vars qw(@ISA %Lexicon);
+ @ISA = 'Locale::Maketext';
+ %Lexicon = ('hello' => 'SROBLR!');
}
-{ package Whunk::L10N::en; use vars qw(@ISA %Lexicon); @ISA = 'Whunk::L10N';
- %Lexicon = ("hello" => "HI AND STUFF!");
+
+{
+ package Whunk::L10N::en;
+ use vars qw(@ISA %Lexicon);
+ @ISA = 'Whunk::L10N';
+ %Lexicon = ('hello' => 'HI AND STUFF!');
}
-{ package Whunk::L10N::zh_tw; use vars qw(@ISA %Lexicon); @ISA = 'Whunk::L10N';
- %Lexicon = ("hello" => "NIHAU JOE!");
+
+{
+ package Whunk::L10N::zh_tw;
+ use vars qw(@ISA %Lexicon);
+ @ISA = 'Whunk::L10N';
+ %Lexicon = ('hello' => 'NIHAU JOE!');
}
$ENV{'REQUEST_METHOD'} = 'GET';
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-US, zh-TW';
my $x = Whunk::L10N->get_handle;
+isa_ok( $x, 'Whunk::L10N::en' );
print "# LH object: $x\n";
-ok $x->maketext('hello'), "HI AND STUFF!";
-print "# OK bye\n";
-ok 1;
+is( $x->maketext('hello'), 'HI AND STUFF!' );
+#!/usr/bin/perl -Tw
-require 5;
-use Test;
-BEGIN { plan tests => 4; }
-use Locale::Maketext 1.01;
-print "# Hi there...\n";
-ok 1;
+use strict;
+use Test::More tests => 3;
+BEGIN {
+ use_ok( 'Locale::Maketext', 1.01 );
+}
-print "# --- Making sure that get_handle works with utf8 ---\n";
use utf8;
# declare some classes...
{
- package Woozle;
- @ISA = ('Locale::Maketext');
- sub dubbil { return $_[1] * 2 .chr(2000)}
- sub numerate { return $_[2] . 'en' }
+ package Woozle;
+ our @ISA = ('Locale::Maketext');
+ sub dubbil { return $_[1] * 2 . chr(2000) }
+ sub numerate { return $_[2] . 'en' }
}
{
- package Woozle::eu_mt;
- @ISA = ('Woozle');
- %Lexicon = (
- 'd2' => chr(1000) . 'hum [dubbil,_1]',
- 'd3' => chr(1000) . 'hoo [quant,_1,zaz]',
- 'd4' => chr(1000) . 'hoo [*,_1,zaz]',
- );
- keys %Lexicon; # dodges the 'used only once' warning
+ package Woozle::eu_mt;
+ our @ISA = ('Woozle');
+ our %Lexicon = (
+ 'd2' => chr(1000) . 'hum [dubbil,_1]',
+ 'd3' => chr(1000) . 'hoo [quant,_1,zaz]',
+ 'd4' => chr(1000) . 'hoo [*,_1,zaz]',
+ );
+ keys %Lexicon; # dodges the 'used only once' warning
}
-my $lh;
-print "# Basic sanity:\n";
-ok defined( $lh = Woozle->get_handle('eu-mt') ) && ref($lh);
-ok $lh && $lh->maketext('d2', 7), chr(1000)."hum 14".chr(2000) ;
-
-
-print "# Byebye!\n";
-ok 1;
+my $lh = Woozle->get_handle('eu-mt');
+isa_ok( $lh, 'Woozle::eu_mt' );
+is( $lh->maketext('d2', 7), chr(1000).'hum 14'.chr(2000) );
projects / platform / upstream / perl.git / commitdiff