Tadashi Okoshi
slash****@users*****
2005年 10月 25日 (火) 04:20:48 JST
Index: affelio_farm/admin/skelton/affelio/extlib/Error.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Error.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Error.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Error.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Error.pm Tue Oct 25 04:20:48 2005 @@ -1,744 +0,0 @@ -# Error.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr****@ti*****>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# Based on my original Error.pm, and Exceptions.pm by Peter Seibel -# <peter****@weblo*****> and adapted by Jesse Glick <jglic****@sig*****>. -# -# but modified ***significantly*** - -package Error; - -use strict; -use vars qw($VERSION); -use 5.004; - -$VERSION = "0.15"; - -use overload ( - '""' => 'stringify', - '0+' => 'value', - 'bool' => sub { return 1; }, - 'fallback' => 1 -); - -$Error::Depth = 0; # Depth to pass to caller() -$Error::Debug = 0; # Generate verbose stack traces - ＠ Error::STACK = (); # Clause stack for try -$Error::THROWN = undef; # last error thrown, a workaround until die $ref works - -my $LAST; # Last error created -my %ERROR; # Last error associated with package - -# Exported subs are defined in Error::subs - -sub import { - shift; - local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; - Error::subs->import(@_); -} - -# I really want to use last for the name of this method, but it is a keyword -# which prevent the syntax last Error - -sub prior { - shift; # ignore - - return $LAST unless @_; - - my $pkg = shift; - return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef - unless ref($pkg); - - my $obj = $pkg; - my $err = undef; - if($obj->isa('HASH')) { - $err = $obj->{'__Error__'} - if exists $obj->{'__Error__'}; - } - elsif($obj->isa('GLOB')) { - $err = ${*$obj}{'__Error__'} - if exists ${*$obj}{'__Error__'}; - } - - $err; -} - -# Return as much information as possible about where the error -# happened. The -stacktrace element only exists if $Error::DEBUG -# was set when the error was created - -sub stacktrace { - my $self = shift; - - return $self->{'-stacktrace'} - if exists $self->{'-stacktrace'}; - - my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; - - $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) - unless($text =~ /\n$/s); - - $text; -} - -# Allow error propagation, ie -# -# $ber->encode(...) or -# return Error->prior($ber)->associate($ldap); - -sub associate { - my $err = shift; - my $obj = shift; - - return unless ref($obj); - - if($obj->isa('HASH')) { - $obj->{'__Error__'} = $err; - } - elsif($obj->isa('GLOB')) { - ${*$obj}{'__Error__'} = $err; - } - $obj = ref($obj); - $ERROR{ ref($obj) } = $err; - - return; -} - -sub new { - my $self = shift; - my($pkg,$file,$line) = caller($Error::Depth); - - my $err = bless { - '-package' => $pkg, - '-file' => $file, - '-line' => $line, - @_ - }, $self; - - $err->associate($err->{'-object'}) - if(exists $err->{'-object'}); - - # To always create a stacktrace would be very inefficient, so - # we only do it if $Error::Debug is set - - if($Error::Debug) { - require Carp; - local $Carp::CarpLevel = $Error::Depth; - my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; - my $trace = Carp::longmess($text); - # Remove try calls from the trace - $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; - $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; - $err->{'-stacktrace'} = $trace - } - - $@ = $LAST = $ERROR{$pkg} = $err; -} - -# Throw an error. this contains some very gory code. - -sub throw { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - # if we are not rethrow-ing then create the object to throw - $self = $self->new(@_) unless ref($self); - - die $Error::THROWN = $self; -} - -# syntactic sugar for -# -# die with Error( ... ); - -sub with { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - $self->new(@_); -} - -# syntactic sugar for -# -# record Error( ... ) and return; - -sub record { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - $self->new(@_); -} - -# catch clause for -# -# try { ... } catch CLASS with { ... } - -sub catch { - my $pkg = shift; - my $code = shift; - my $clauses = shift || {}; - my $catch = $clauses->{'catch'} ||= []; - - unshift @$catch, $pkg, $code; - - $clauses; -} - -# Object query methods - -sub object { - my $self = shift; - exists $self->{'-object'} ? $self->{'-object'} : undef; -} - -sub file { - my $self = shift; - exists $self->{'-file'} ? $self->{'-file'} : undef; -} - -sub line { - my $self = shift; - exists $self->{'-line'} ? $self->{'-line'} : undef; -} - -sub text { - my $self = shift; - exists $self->{'-text'} ? $self->{'-text'} : undef; -} - -# overload methods - -sub stringify { - my $self = shift; - defined $self->{'-text'} ? $self->{'-text'} : "Died"; -} - -sub value { - my $self = shift; - exists $self->{'-value'} ? $self->{'-value'} : undef; -} - -package Error::Simple; - - ＠ Error::Simple::ISA = qw(Error); - -sub new { - my $self = shift; - my $text = "" . shift; - my $value = shift; - my(@args) = (); - - local $Error::Depth = $Error::Depth + 1; - - @args = ( -file => $1, -line => $2) - if($text =~ s/ at (\S+) line (\d+)(\.\n)?$//s); - - push(@args, '-value', 0 + $value) - if defined($value); - - $self->SUPER::new(-text => $text, @args); -} - -sub stringify { - my $self = shift; - my $text = $self->SUPER::stringify; - $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) - unless($text =~ /\n$/s); - $text; -} - -########################################################################## -########################################################################## - -# Inspired by code from Jesse Glick <jglic****@sig*****> and -# Peter Seibel <peter****@weblo*****> - -package Error::subs; - -use Exporter (); -use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); - - ＠ EXPORT_OK = qw(try with finally except otherwise); -%EXPORT_TAGS = (try => \@EXPORT_OK); - - ＠ ISA = qw(Exporter); - -sub run_clauses ($$$\@) { - my($clauses,$err,$wantarray,$result) = @_; - my $code = undef; - - $err = new Error::Simple($err) unless ref($err); - - CATCH: { - - # catch - my $catch; - if(defined($catch = $clauses->{'catch'})) { - my $i = 0; - - CATCHLOOP: - for( ; $i < @$catch ; $i += 2) { - my $pkg = $catch->[$i]; - unless(defined $pkg) { - #except - splice(@$catch,$i,2,$catch->[$i+1]->()); - $i -= 2; - next CATCHLOOP; - } - elsif($err->isa($pkg)) { - $code = $catch->[$i+1]; - while(1) { - my $more = 0; - local($Error::THROWN); - my $ok = eval { - if($wantarray) { - @{$result} = $code->($err,\$more); - } - elsif(defined($wantarray)) { - @{$result} = (); - $result->[0] = $code->($err,\$more); - } - else { - $code->($err,\$more); - } - 1; - }; - if( $ok ) { - next CATCHLOOP if $more; - undef $err; - } - else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - $err = new Error::Simple($err) - unless ref($err); - } - last CATCH; - }; - } - } - } - - # otherwise - my $owise; - if(defined($owise = $clauses->{'otherwise'})) { - my $code = $clauses->{'otherwise'}; - my $more = 0; - my $ok = eval { - if($wantarray) { - @{$result} = $code->($err,\$more); - } - elsif(defined($wantarray)) { - @{$result} = (); - $result->[0] = $code->($err,\$more); - } - else { - $code->($err,\$more); - } - 1; - }; - if( $ok ) { - undef $err; - } - else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - $err = new Error::Simple($err) - unless ref($err); - } - } - } - $err; -} - -sub try (&;$) { - my $try = shift; - my $clauses = @_ ? shift : {}; - my $ok = 0; - my $err = undef; - my @result = (); - - unshift @Error::STACK, $clauses; - - my $wantarray = wantarray(); - - do { - local $Error::THROWN = undef; - - $ok = eval { - if($wantarray) { - @result = $try->(); - } - elsif(defined $wantarray) { - $result[0] = $try->(); - } - else { - $try->(); - } - 1; - }; - - $err = defined($Error::THROWN) ? $Error::THROWN : $@ - unless $ok; - }; - - shift @Error::STACK; - - $err = run_clauses($clauses,$err,wantarray, ＠ result) - unless($ok); - - $clauses->{'finally'}->() - if(defined($clauses->{'finally'})); - - throw $err if defined($err); - - wantarray ? @result : $result[0]; -} - -# Each clause adds a sub to the list of clauses. The finally clause is -# always the last, and the otherwise clause is always added just before -# the finally clause. -# -# All clauses, except the finally clause, add a sub which takes one argument -# this argument will be the error being thrown. The sub will return a code ref -# if that clause can handle that error, otherwise undef is returned. -# -# The otherwise clause adds a sub which unconditionally returns the users -# code reference, this is why it is forced to be last. -# -# The catch clause is defined in Error.pm, as the syntax causes it to -# be called as a method - -sub with (&;$) { - @_ -} - -sub finally (&) { - my $code = shift; - my $clauses = { 'finally' => $code }; - $clauses; -} - -# The except clause is a block which returns a hashref or a list of -# key-value pairs, where the keys are the classes and the values are subs. - -sub except (&;$) { - my $code = shift; - my $clauses = shift || {}; - my $catch = $clauses->{'catch'} ||= []; - - my $sub = sub { - my $ref; - my(@array) = $code->($_[0]); - if(@array == 1 && ref($array[0])) { - $ref = $array[0]; - $ref = [ %$ref ] - if(UNIVERSAL::isa($ref,'HASH')); - } - else { - $ref = \@array; - } - @$ref - }; - - unshift @{$catch}, undef, $sub; - - $clauses; -} - -sub otherwise (&;$) { - my $code = shift; - my $clauses = shift || {}; - - if(exists $clauses->{'otherwise'}) { - require Carp; - Carp::croak("Multiple otherwise clauses"); - } - - $clauses->{'otherwise'} = $code; - - $clauses; -} - -1; -__END__ - -=head1 NAME - -Error - Error/exception handling in an OO-ish way - -=head1 SYNOPSIS - - use Error qw(:try); - - throw Error::Simple( "A simple error"); - - sub xyz { - ... - record Error::Simple("A simple error") - and return; - } - - unlink($file) or throw Error::Simple("$file: $!",$!); - - try { - do_some_stuff(); - die "error!" if $condition; - throw Error::Simple -text => "Oops!" if $other_condition; - } - catch Error::IO with { - my $E = shift; - print STDERR "File ", $E->{'-file'}, " had a problem\n"; - } - except { - my $E = shift; - my $general_handler=sub {send_message $E->{-description}}; - return { - UserException1 => $general_handler, - UserException2 => $general_handler - }; - } - otherwise { - print STDERR "Well I don't know what to say\n"; - } - finally { - close_the_garage_door_already(); # Should be reliable - }; # Don't forget the trailing ; or you might be surprised - -=head1 DESCRIPTION - -The C<Error> package provides two interfaces. Firstly C<Error> provides -a procedural interface to exception handling. Secondly C<Error> is a -base class for errors/exceptions that can either be thrown, for -subsequent catch, or can simply be recorded. - -Errors in the class C<Error> should not be thrown directly, but the -user should throw errors from a sub-class of C<Error>. - -=head1 PROCEDURAL INTERFACE - -C<Error> exports subroutines to perform exception handling. These will -be exported if the C<:try> tag is used in the C<use> line. - -=over 4 - -=item try BLOCK CLAUSES - -C<try> is the main subroutine called by the user. All other subroutines -exported are clauses to the try subroutine. - -The BLOCK will be evaluated and, if no error is throw, try will return -the result of the block. - -C<CLAUSES> are the subroutines below, which describe what to do in the -event of an error being thrown within BLOCK. - -=item catch CLASS with BLOCK - -This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)> -to be caught and handled by evaluating C<BLOCK>. - -C<BLOCK> will be passed two arguments. The first will be the error -being thrown. The second is a reference to a scalar variable. If this -variable is set by the catch block then, on return from the catch -block, try will continue processing as if the catch block was never -found. - -To propagate the error the catch block may call C<$err-E<gt>throw> - -If the scalar reference by the second argument is not set, and the -error is not thrown. Then the current try block will return with the -result from the catch block. - -=item except BLOCK - -When C<try> is looking for a handler, if an except clause is found -C<BLOCK> is evaluated. The return value from this block should be a -HASHREF or a list of key-value pairs, where the keys are class names -and the values are CODE references for the handler of errors of that -type. - -=item otherwise BLOCK - -Catch any error by executing the code in C<BLOCK> - -When evaluated C<BLOCK> will be passed one argument, which will be the -error being processed. - -Only one otherwise block may be specified per try block - -=item finally BLOCK - -Execute the code in C<BLOCK> either after the code in the try block has -successfully completed, or if the try block throws an error then -C<BLOCK> will be executed after the handler has completed. - -If the handler throws an error then the error will be caught, the -finally block will be executed and the error will be re-thrown. - -Only one finally block may be specified per try block - -=back - -=head1 CLASS INTERFACE - -=head2 CONSTRUCTORS - -The C<Error> object is implemented as a HASH. This HASH is initialized -with the arguments that are passed to it's constructor. The elements -that are used by, or are retrievable by the C<Error> class are listed -below, other classes may add to these. - - -file - -line - -text - -value - -object - -If C<-file> or C<-line> are not specified in the constructor arguments -then these will be initialized with the file name and line number where -the constructor was called from. - -If the error is associated with an object then the object should be -passed as the C<-object> argument. This will allow the C<Error> package -to associate the error with the object. - -The C<Error> package remembers the last error created, and also the -last error associated with a package. This could either be the last -error created by a sub in that package, or the last error which passed -an object blessed into that package as the C<-object> argument. - -=over 4 - -=item throw ( [ ARGS ] ) - -Create a new C<Error> object and throw an error, which will be caught -by a surrounding C<try> block, if there is one. Otherwise it will cause -the program to exit. - -C<throw> may also be called on an existing error to re-throw it. - -=item with ( [ ARGS ] ) - -Create a new C<Error> object and returns it. This is defined for -syntactic sugar, eg - - die with Some::Error ( ... ); - -=item record ( [ ARGS ] ) - -Create a new C<Error> object and returns it. This is defined for -syntactic sugar, eg - - record Some::Error ( ... ) - and return; - -=back - -=head2 STATIC METHODS - -=over 4 - -=item prior ( [ PACKAGE ] ) - -Return the last error created, or the last error associated with -C<PACKAGE> - -=back - -=head2 OBJECT METHODS - -=over 4 - -=item stacktrace - -If the variable C<$Error::Debug> was non-zero when the error was -created, then C<stacktrace> returns a string created by calling -C<Carp::longmess>. If the variable was zero the C<stacktrace> returns -the text of the error appended with the filename and line number of -where the error was created, providing the text does not end with a -newline. - -=item object - -The object this error was associated with - -=item file - -The file where the constructor of this error was called from - -=item line - -The line where the constructor of this error was called from - -=item text - -The text of the error - -=back - -=head2 OVERLOAD METHODS - -=over 4 - -=item stringify - -A method that converts the object into a string. This method may simply -return the same as the C<text> method, or it may append more -information. For example the file name and line number. - -By default this method returns the C<-text> argument that was passed to -the constructor, or the string C<"Died"> if none was given. - -=item value - -A method that will return a value that can be associated with the -error. For example if an error was created due to the failure of a -system call, then this may return the numeric value of C<$!> at the -time. - -By default this method returns the C<-value> argument that was passed -to the constructor. - -=back - -=head1 PRE-DEFINED ERROR CLASSES - -=over 4 - -=item Error::Simple - -This class can be used to hold simple error strings and values. It's -constructor takes two arguments. The first is a text value, the second -is a numeric value. These values are what will be returned by the -overload methods. - -If the text value ends with C<at file line 1> as $@ strings do, then -this infomation will be used to set the C<-file> and C<-line> arguments -of the error object. - -This class is used internally if an eval'd block die's with an error -that is a plain string. - -=back - -=head1 KNOWN BUGS - -None, but that does not mean there are not any. - -=head1 AUTHORS - -Graham Barr <gbarr****@pobox*****> - -The code that inspired me to write this was originally written by -Peter Seibel <peter****@weblo*****> and adapted by Jesse Glick -<jglic****@sig*****>. - -=head1 MAINTAINER - -Arun Kumar U <u_arunk****@yahoo*****> - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/Jcode.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Jcode.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Jcode.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Jcode.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Jcode.pm Tue Oct 25 04:20:48 2005 @@ -1,829 +0,0 @@ -# -# $Id: Jcode.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# - -=head1 NAME - -Jcode - Japanese Charset Handler - -=head1 SYNOPSIS - - use Jcode; - # - # traditional - Jcode::convert(\$str, $ocode, $icode, "z"); - # or OOP! - print Jcode->new($str)->h2z->tr($from, $to)->utf8; - -=cut - -=head1 DESCRIPTION - -Jcode.pm supports both object and traditional approach. -With object approach, you can go like; - -$iso_2022_jp = Jcode->new($str)->h2z->jis; - -Which is more elegant than; - -$iso_2022_jp = &jcode::convert(\$str,'jis',jcode::getcode(\str), "z"); - -For those unfamiliar with objects, Jcode.pm still supports getcode() -and convert(). - -=cut - - package Jcode; -use 5.004; -use Carp; -use strict; -use vars qw($RCSID $VERSION $DEBUG); - -$RCSID = q$Id: Jcode.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $; -$VERSION = do { my @r = (q$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; -$DEBUG = 0; - -use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - ＠ ISA = qw(Exporter); - ＠ EXPORT = qw(jcode getcode); - ＠ EXPORT_OK = qw($RCSID $VERSION $DEBUG); -%EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); - - -use vars qw($USE_CACHE $NOXS); - -$USE_CACHE = 1; -$NOXS = 0; - -print $RCSID, "\n" if $DEBUG; - -use Jcode::Constants qw(:all); - -use overload - q("") => sub { ${$_[0]->[0]} }, - q(==) => sub {overload::StrVal($_[0]) eq overload::StrVal($_[1])}, - q(=) => sub { $_[0]->set( $_[1] ) }, - q(.=) => sub { $_[0]->append( $_[1] ) }, - fallback => 1, - ; - -=head1 Methods - -Methods mentioned here all return Jcode object unless otherwise mentioned. - -=over 4 - -=item $j = Jcode-E<gt>new($str [, $icode]); - -Creates Jcode object $j from $str. Input code is automatically checked -unless you explicitly set $icode. For available charset, see L<getcode> -below. - -The object keeps the string in EUC format enternaly. When the object -itself is evaluated, it returns the EUC-converted string so you can -"print $j;" without calling access method if you are using EUC -(thanks to function overload). - -=item Passing Reference - -Instead of scalar value, You can use reference as - - Jcode->new(\$str); - -This saves time a little bit. In exchange of the value of $str being -converted. (In a way, $str is now "tied" to jcode object). - - =item $j-E<gt>set($str [, $icode]); - -Sets $j's internal string to $str. Handy when you use Jcode object repeatedly -(saves time and memory to create object). - - # converts mailbox to SJIS format - my $jconv = new Jcode; -$/ = 00; -while(<>){ - print $jconv->set(\$_)->mime_decode->sjis; -} - -=item $j-E<gt>append($str [, $icode]); - -Appends $str to $j's internal string. - -=back - -=cut - -sub new { - my $class = shift; - my ($thingy, $icode) = @_; - my $r_str = ref $thingy ? $thingy : \$thingy; - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - convert($r_str, 'euc', $icode); - my $self = [ - $r_str, - $icode, - $nmatch, - ]; - carp "Object of class $class created" if $DEBUG >= 2; - bless $self, $class; -} - -sub r_str { $_[0]->[0] } -sub icode { $_[0]->[1] } -sub nmatch { $_[0]->[2] } - -sub set { - my $self = shift; - my ($thingy, $icode) = @_; - my $r_str = ref $thingy ? $thingy : \$thingy; - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - convert($r_str, 'euc', $icode); - $self->[0] = $r_str; - $self->[1] = $icode; - $self->[2] = $nmatch; - return $self; -} - -sub append { - my $self = shift; - my ($thingy, $icode) = @_; - my $r_str = ref $thingy ? $thingy : \$thingy; - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - convert($r_str, 'euc', $icode); - ${$self->[0]} .= $$r_str; - $self->[1] = $icode; - $self->[2] = $nmatch; - return $self; -} - -=over 4 - - =item $j = jcode($str [, $icode]); - -shortcut for Jcode->new() so you can go like; - -$sjis = jcode($str)->sjis; - -=item $euc = $j-E<gt>euc; - -=item $jis = $j-E<gt>jis; - -=item $sjis = $j-E<gt>sjis; - -What you code is what you get :) - -=item $iso_2022_jp = $j-E<gt>iso_2022_jp - -Same as $j->h2z->jis. -Hankaku Kanas are forcibly converted to Zenkaku. - -=back - -=cut - -sub jcode { return Jcode->new(@_) } -sub euc { return ${$_[0]->[0]} } -sub jis { return &euc_jis(${$_[0]->[0]})} -sub sjis { return &euc_sjis(${$_[0]->[0]})} -sub iso_2022_jp{return $_[0]->h2z->jis} - -=over 4 - - =item [@lines =] $jcode-E<gt>jfold([$bytes_per_line, $newline_str]); - -folds lines in jcode string every $bytes_per_line (default: 72) -in a way that does not clobber the multibyte string. -(Sorry, no Kinsoku done!) -with a newline string spified by $newline_str (default: \n). - -=back - -=cut - -sub jfold{ - my $self = shift; - my ($bpl, $nl) = @_; - $bpl ||= 72; - $nl ||= "\n"; - my $r_str = $self->[0]; - my (@lines, $len, $i); - while ($$r_str =~ - m/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff])/sgo) - { - if ($len + length($1) > $bpl){ # fold! - $i++; - $len = 0; - } - $lines[$i] .= $1; - $len += length($1); - } - defined($lines[$i]) or pop @lines; - $$r_str = join($nl, @lines); - return wantarray ? @lines : $self; -} - -=pod - -=over 4 - -=item $length = $jcode-E<gt>jlength(); - -returns character length properly, rather than byte length. - -=back - -=cut - -sub jlength { - my $self = shift; - my $r_str = $self->[0]; - return scalar (my @char = $$r_str =~ m/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff])/sgo); -} - -=head2 Methods that use MIME::Base64 - -To use methods below, you need MIME::Base64. To install, simply - - perl -MCPAN -e 'CPAN::Shell->install("MIME::Base64")' - -=over 4 - - =item $mime_header = $j-E<gt>mime_encode([$lf, $bpl]); - -Converts $str to MIME-Header documented in RFC1522. -When $lf is specified, it uses $lf to fold line (default: \n). - When $bpl is specified, it uses $bpl for the number of bytes (default: 76; -this number must be smaller than 76). - - =item $j-E<gt>mime_decode; - -Decodes MIME-Header in Jcode object. - - You can retrieve the number of matches via $j->nmatch; - -=back - -=cut - -sub mime_encode{ - my $self = shift; - my $r_str = $self->[0]; - my $lf = shift || "\n"; - my $bpl = shift || 76; - - my ($trailing_crlf) = ($$r_str =~ /(\n|\r|\x0d\x0a)$/o); - my $str = _mime_unstructured_header($$r_str, $lf, $bpl); - not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o; - $str; -} - -# -# shamelessly stolen from -# http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 -# - -sub _add_encoded_word { - require MIME::Base64; - my($str, $line, $bpl) = @_; - my $result = ''; - while (length($str)) { - my $target = $str; - $str = ''; - if (length($line) + 22 + - ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl) { - $line =~ s/[ \t\n\r]*$/\n/; - $result .= $line; - $line = ' '; - } - while (1) { - my $iso_2022_jp = jcode($target, 'euc')->iso_2022_jp; - if (my $count = ($iso_2022_jp =~ tr/\x80-\xff//d)){ - $DEBUG and warn $count; - $target = jcode($iso_2022_jp, 'iso_2022_jp')->euc; - } - my $encoded = '=?ISO-2022-JP?B?' . - MIME::Base64::encode_base64($iso_2022_jp, '') - . '?='; - if (length($encoded) + length($line) > $bpl) { - $target =~ - s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o; - $str = $1 . $str; - } else { - $line .= $encoded; - last; - } - } - } - return $result . $line; -} - -sub _mime_unstructured_header { - my ($oldheader, $lf, $bpl) = @_; - my(@words, @wordstmp, $i); - my $header = ''; - $oldheader =~ s/\s+$//; - @wordstmp = split /\s+/, $oldheader; - for ($i = 0; $i < $#wordstmp; $i++) { - if ($wordstmp[$i] !~ /^[\x21-\x7E]+$/ and - $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/) { - $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]"; - } else { - push(@words, $wordstmp[$i]); - } - } - push(@words, $wordstmp[-1]); - for my $word (@words) { - if ($word =~ /^[\x21-\x7E]+$/) { - $header =~ /(?:.*\n)*(.*)/; - if (length($1) + length($word) > $bpl) { - $header .= "$lf $word"; - } else { - $header .= $word; - } - } else { - $header = _add_encoded_word($word, $header, $bpl); - } - $header =~ /(?:.*\n)*(.*)/; - if (length($1) == $bpl) { - $header .= "$lf "; - } else { - $header .= ' '; - } - } - $header =~ s/\n? $/\n/; - $header; -} - -# see http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 -#$lws = '(?:(?:\x0d\x0a)?[ \t])+'; -#$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?='; -#$str =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio; -#$str =~ s/$lws/ /go; $str =~ s/$ew_regex/decode_base64($1)/egio; - -sub mime_decode{ - require MIME::Base64; # not use - my $self = shift; - my $r_str = $self->[0]; - my $re_lws = '(?:(?:\r|\n|\x0d\x0a)?[ \t])+'; - my $re_ew = '=\?[Ii][Ss][Oo]-2022-[Jj][Pp]\?[Bb]\?([A-Za-z0-9+/]+=*)\?='; - $$r_str =~ s/($re_ew)$re_lws(?=$re_ew)/$1/sgo; - $$r_str =~ s/$re_lws/ /go; - $self->[2] = - ($$r_str =~ - s/$re_ew/jis_euc(MIME::Base64::decode_base64($1))/ego - ); - $self; -} - - -=head2 Methods implemented by Jcode::H2Z - -Methods below are actually implemented in Jcode::H2Z. - -=over 4 - - =item $j-E<gt>h2z([$keep_dakuten]); - -Converts X201 kana (Hankaku) to X208 kana (Zenkaku). -When $keep_dakuten is set, it leaves dakuten as is -(That is, "ka + dakuten" is left as is instead of -being converted to "ga") - - You can retrieve the number of matches via $j->nmatch; - -=item $j-E<gt>z2h; - -Converts X208 kana (Zenkaku) to X201 kana (Hankaku). - - You can retrieve the number of matches via $j->nmatch; - -=back - -=cut - -sub h2z { - require Jcode::H2Z; # not use - my $self = shift; - $self->[2] = Jcode::H2Z::h2z($self->[0], @_); - return $self; -} - - -sub z2h { - require Jcode::H2Z; # not use - my $self = shift; - $self->[2] = &Jcode::H2Z::z2h($self->[0], @_); - return $self; -} - - -=head2 Methods implemented in Jcode::Tr - -Methods here are actually implemented in Jcode::Tr. - -=over 4 - - =item $j-E<gt>tr($from, $to); - -Applies tr on Jcode object. $from and $to can contain EUC Japanese. - - You can retrieve the number of matches via $j->nmatch; - -=back - -=cut - -sub tr{ - require Jcode::Tr; # not use - my $self = shift; - $self->[2] = Jcode::Tr::tr($self->[0], @_); - return $self; -} - -# -# load needed module depending on the configuration just once! -# - -use vars qw(%PKG_LOADED); -sub load_module{ - my $pkg = shift; - return $pkg if $PKG_LOADED{$pkg}++; - unless ($NOXS){ - eval qq( require $pkg; ); - unless ($@){ - carp "$pkg loaded." if $DEBUG; - return $pkg; - } - } - $pkg .= "::NoXS"; - eval qq( require $pkg; ); - unless ($@){ - carp "$pkg loaded" if $DEBUG; - }else{ - croak "Loading $pkg failed!"; - } - $pkg; -} - -=head2 Methods implemented in Jcode::Unicode - -If your perl does not support XS (or you can't C<perl Makefile.PL>, -Jcode::Unicode::NoXS will be used. - -See L<Jcode::Unicode> and L<Jcode::Unicode::NoXS> for details - -=over 4 - -=item $ucs2 = $j-E<gt>ucs2; - -Returns UCS2 (Raw Unicode) string. - -=item $ucs2 = $j-E<gt>utf8; - -Returns utf8 String. - -=back - -=cut - -sub ucs2{ - load_module("Jcode::Unicode"); - euc_ucs2(${$_[0]->[0]}); -} - -sub utf8{ - load_module("Jcode::Unicode"); - euc_utf8(${$_[0]->[0]}); -} - -=head2 Instance Variables - -If you need to access instance variables of Jcode object, use access -methods below instead of directly accessing them (That's what OOP -is all about) - -FYI, Jcode uses a ref to array instead of ref to hash (common way) to -optimize speed (Actually you don't have to know as long as you use - access methods instead; Once again, that's OOP) - -=over 4 - -=item $j-E<gt>r_str - -Reference to the EUC-coded String. - -=item $j-E<gt>icode - -Input charcode in recent operation. - -=item $j-E<gt>nmatch - -Number of matches (Used in $j->tr, etc.) - -=back - -=cut - -=head1 Subroutines - -=over 4 - -=item ($code, [$nmatch]) = getcode($str); - -Returns char code of $str. Return codes are as follows - - ascii Ascii (Contains no Japanese Code) - binary Binary (Not Text File) - euc EUC-JP - sjis SHIFT_JIS - jis JIS (ISO-2022-JP) - ucs2 UCS2 (Raw Unicode) - utf8 UTF8 - -When array context is used instead of scaler, it also returns how many -character codes are found. As mentioned above, $str can be \$str -instead. - -B<jcode.pl Users:> This function is 100% upper-conpatible with -jcode::getcode() -- well, almost; - - * When its return value is an array, the order is the opposite; - jcode::getcode() returns $nmatch first. - - * jcode::getcode() returns 'undef' when the number of EUC characters - is equal to that of SJIS. Jcode::getcode() returns EUC. for - Jcode.pm there is no in-betweens. - -=item Jcode::convert($str, [$ocode, $icode, $opt]); - -Converts $str to char code specified by $ocode. When $icode is specified -also, it assumes $icode for input string instead of the one checked by -getcode(). As mentioned above, $str can be \$str instead. - -B<jcode.pl Users:> This function is 100% upper-conpatible with -jcode::convert() ! - -=back - -=cut - -sub getcode { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - - my ($code, $nmatch, $sjis, $euc, $utf8) = ("", 0, 0, 0, 0); - if ($$r_str =~ /$RE{BIN}/o) {# 'binary' - my $ucs2; - $ucs2 += length($1) - while $$r_str =~ /(\x00$RE{ASCII})+/go; - if ($ucs2){ # smells like raw unicode - ($code, $nmatch) = ('ucs2', $ucs2); - }else{ - ($code, $nmatch) = ('binary', 0); - } - } - elsif ($$r_str !~ /[\e\x80-\xff]/o) {# not Japanese - ($code, $nmatch) = ('ascii', 1); - }# 'jis' - elsif ($$r_str =~ - m[ - $RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA} - ]ox) -{ - ($code, $nmatch) = ('jis', 1); -} -else { # should be euc|sjis|utf8 - # use of (?:) by Hiroki Ohzaki <ohzak****@iod*****> - $sjis += length($1) - while $$r_str =~ /((?:$RE{SJIS_C})+)/go; - $euc += length($1) - while $$r_str =~ /((?:$RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212})+)/go; - $utf8 += length($1) - while $$r_str =~ /((?:$RE{UTF8})+)/go; - # $utf8 *= 1.5; # M. Takahashi's suggestion - $nmatch = _max($utf8, $sjis, $euc); - carp ">DEBUG:sjis = $sjis, euc = $euc, utf8 = $utf8" if $DEBUG >= 3; - $code = - ($euc > $sjis and $euc > $utf8) ? 'euc' : - ($sjis > $euc and $sjis > $utf8) ? 'sjis' : - ($utf8 > $euc and $utf8 > $sjis) ? 'utf8' : undef; -} -return wantarray ? ($code, $nmatch) : $code; -} - -sub convert{ - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - my ($ocode, $icode, $opt) = @_; - - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - - return $$r_str if $icode eq $ocode and !defined $opt; # do nothin' - - no strict qw(refs); - my $method; - - # convert to EUC - - load_module("Jcode::Unicode") if $icode =~ /ucs2|utf8/o; - if ($icode and defined &{$method = $icode . "_euc"}){ - carp "Dispatching \&$method" if $DEBUG >= 2; - &{$method}($r_str) ; - } - - # h2z or z2h - - if ($opt){ - my $cmd = ($opt =~ /^z/o) ? "h2z" : ($opt =~ /^h/o) ? "z2h" : undef; - if ($cmd){ - require Jcode::H2Z; - &{'Jcode::H2Z::' . $cmd}($r_str); - } - } - - # convert to $ocode - - load_module("Jcode::Unicode") if $ocode =~ /ucs2|utf8/o; - if ($ocode and defined &{$method = "euc_" . $ocode}){ - carp "Dispatching \&$method" if $DEBUG >= 2; - &{$method}($r_str) ; - } - $$r_str; -} - -# JIS<->EUC - -sub jis_euc { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s( - ($RE{JIS_0212}|$RE{JIS_0208}|$RE{JIS_ASC}|$RE{JIS_KANA}) - ([^\e]*) - ) - { - my ($esc, $str) = ($1, $2); - if ($esc !~ /$RE{JIS_ASC}/o) { - $str =~ tr/\x21-\x7e/\xa1-\xfe/; - if ($esc =~ /$RE{JIS_KANA}/o) { - $str =~ s/([\xa1-\xdf])/\x8e$1/og; - } - elsif ($esc =~ /$RE{JIS_0212}/o) { - $str =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; - } - } - $str; - }geox; - $$r_str; -} - -# -# euc_jis -# -# Based upon the contribution of -# Kazuto Ichimura <ichim****@shima*****> -# optimized by <ohzak****@iod*****> - -sub euc_jis{ - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s{ - ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+) - }{ - my $str = $1; - my $esc = - ( $str =~ tr/\x8E//d ) ? $ESC{KANA} : - ( $str =~ tr/\x8F//d ) ? $ESC{JIS_0212} : - $ESC{JIS_0208}; - $str =~ tr/\xA1-\xFE/\x21-\x7E/; - $esc . $str . $ESC{ASC}; - }geox; - $$r_str =~ - s/\Q$ESC{ASC}\E - (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox; - $$r_str; -} - -# EUC<->SJIS - -my %_S2E = (); -my %_E2S = (); - -sub sjis_euc { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s( - ($RE{SJIS_C}|$RE{SJIS_KANA}) - ) - { - my $str = $1; - unless ($_S2E{$1}){ - my ($c1, $c2) = unpack('CC', $str); - if (0xa1 <= $c1 && $c1 <= 0xdf) { - $c2 = $c1; - $c1 = 0x8e; - } elsif (0x9f <= $c2) { - $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60); - $c2 += 2; - } else { - $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61); - $c2 += 0x60 + ($c2 < 0x7f); - } - $_S2E{$str} = pack('CC', $c1, $c2); - } - $_S2E{$str}; - }geox; - $$r_str; -} - -# - -sub euc_sjis { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s( - ($RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212}) - ) - { - my $str = $1; - unless ($_E2S{$str}){ - my ($c1, $c2) = unpack('CC', $str); - if ($c1 == 0x8e) { # SS2 - $_E2S{$str} = chr($c2); - } elsif ($c1 == 0x8f) { # SS3 - $_E2S{$str} = $CHARCODE{UNDEF_SJIS}; - }else { #SS1 or X0208 - if ($c1 % 2) { - $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); - $c2 -= 0x60 + ($c2 < 0xe0); - } else { - $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); - $c2 -= 2; - } - $_E2S{$str} = pack('CC', $c1, $c2); - } - } - $_E2S{$str}; - }geox; - $$r_str; -} - -# -# Util. Functions -# - -sub _max { - my $result = shift; - for my $n (@_){ - $result = $n if $n > $result; - } - return $result; -} - -1; - -__END__ - -=head1 BUGS - -Unicode support by Jcode is far from efficient! - -=head1 IN FUTURE - -Hopefully Jcode will be superceded by Encode module that is part of -the standard module on Perl 5.7 and up - -=head1 ACKNOWLEDGEMENTS - -This package owes a lot in motivation, design, and code, to the jcode.pl -for Perl4 by Kazumasa Utashiro <utash****@iij*****>. - -Hiroki Ohzaki <ohzak****@iod*****> has helped me polish regexp from the -very first stage of development. - -And folks at Jcode Mailing list <jcode****@ring*****>. Without them, I -couldn't have coded this far. - -=head1 SEE ALSO - -L<Jcode::Unicode> - -L<Jcode::Unicode::NoXS> - -http://www.iana.org/assignments/character-sets - -L<Encode> - -=head1 COPYRIGHT - -Copyright 1999 Dan Kogai <danko****@dan*****> - -This library is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=cut -
