MIME-Charset-1.013.1/0000755000175100017510000000000014275402653016001 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/t/0000755000175100017510000000000014275402653016244 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/t/01encode.t0000644000175100017510000000427613071307715020034 0ustar hatukanezumihatukanezumiuse strict; use Test; BEGIN { plan tests => 18 } use MIME::Charset qw(:trans); if (&MIME::Charset::USE_ENCODE && $] < 5.008) { require Encode::JP; require Encode::CN; } my ($converted, $charset, $encoding); my $dst = "Perl:\033\$BIBE*\@^CoE*GQJ*=PNO4o\033(B"; my $src = "Perl:\xC9\xC2\xC5\xAA\xC0\xDE\xC3\xEF\xC5\xAA". "\xC7\xD1\xCA\xAA\xBD\xD0\xCE\xCF\xB4\xEF"; # test get encodings for body ($converted, $charset, $encoding) = body_encode($src, "euc-jp"); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "7BIT", $encoding); } else { ok($converted eq $src); ok($charset, "EUC-JP", $charset); ok($encoding, "8BIT", $encoding); } # test get encodings for body with auto-detection of 7-bit ($converted, $charset, $encoding) = body_encode($dst); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "7BIT", $encoding); } else { ok($converted eq $dst); ok($charset, "US-ASCII", $charset); ok($encoding, "7BIT", $encoding); } # test get encodings for header ($converted, $charset, $encoding) = header_encode($src, "euc-jp"); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "B", $encoding); } else { ok($converted eq $src); ok($charset, "EUC-JP", $charset); ok($encoding, "B", $encoding); } # test get encodings for header with auto-detection of 7-bit ($converted, $charset, $encoding) = header_encode($dst); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "B", $encoding); } else { ok($converted eq $dst); ok($charset, "US-ASCII", $charset); ok($encoding, undef, $encoding); } $src = "~{<:Ky2;S{#,NpJ)l6HK!#~}~"; ($converted, $charset, $encoding) = header_encode($src, "hz-gb-2312"); ok($converted eq $src); ok($charset, "HZ-GB-2312", $charset); ok($encoding, "B", $encoding); $src = "This doesn't contain non-ASCII."; ($converted, $charset, $encoding) = header_encode($src, "hz-gb-2312"); ok($converted eq $src); ok($charset, "US-ASCII", $charset); ok($encoding, undef, $encoding); MIME-Charset-1.013.1/t/03ooinfo.t0000644000175100017510000000112713071307715020062 0ustar hatukanezumihatukanezumiuse strict; use Test; BEGIN { plan tests => 4 } use MIME::Charset qw(:info); my $obj; $obj = MIME::Charset->new("iso-8859-2"); ok($obj->body_encoding, "Q", $obj->body_encoding); $obj = MIME::Charset->new("ANSI X3.4-1968"); ok($obj->canonical_charset, "US-ASCII", $obj->canonical_charset); $obj = MIME::Charset->new("utf-8"); ok($obj->header_encoding, "S", $obj->header_encoding); $obj = MIME::Charset->new("shift_jis"); if (MIME::Charset::USE_ENCODE) { ok($obj->output_charset, "ISO-2022-JP", $obj->output_charset); } else { ok($obj->output_charset, "SHIFT_JIS", $obj->output_charset); } MIME-Charset-1.013.1/t/02enclen.t0000644000175100017510000000055313071307715020036 0ustar hatukanezumihatukanezumiuse strict; use Test; BEGIN { plan tests => 3 } use MIME::Charset qw(:trans); my $s = "Perl: \xe8\xa8\x80\xe8\xaa\x9e"; ok(encoded_header_len($s,"b","utf-8"), 28, encoded_header_len($s,"b","utf-8")); ok(encoded_header_len($s,"q","utf-8"), 38, encoded_header_len($s,"q","utf-8")); ok(encoded_header_len($s,"s","utf-8"), 28, encoded_header_len($s,"s","utf-8")); MIME-Charset-1.013.1/t/01ooencode.t0000644000175100017510000000445413071307715020370 0ustar hatukanezumihatukanezumiuse strict; use Test; BEGIN { plan tests => 18 } use MIME::Charset qw(:trans); if (&MIME::Charset::USE_ENCODE && $] < 5.008) { require Encode::JP; require Encode::CN; } my ($converted, $charset, $encoding); my $dst = "Perl:\033\$BIBE*\@^CoE*GQJ*=PNO4o\033(B"; my $src = "Perl:\xC9\xC2\xC5\xAA\xC0\xDE\xC3\xEF\xC5\xAA". "\xC7\xD1\xCA\xAA\xBD\xD0\xCE\xCF\xB4\xEF"; my $obj = MIME::Charset->new("euc-jp"); my $null = MIME::Charset->new(undef); # test get encodings for body ($converted, $charset, $encoding) = $obj->body_encode($src); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "7BIT", $encoding); } else { ok($converted eq $src); ok($charset, "EUC-JP", $charset); ok($encoding, "8BIT", $encoding); } # test get encodings for body with auto-detection of 7-bit ($converted, $charset, $encoding) = $null->body_encode($dst); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "7BIT", $encoding); } else { ok($converted eq $dst); ok($charset, "US-ASCII", $charset); ok($encoding, "7BIT", $encoding); } # test get encodings for header ($converted, $charset, $encoding) = $obj->header_encode($src); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "B", $encoding); } else { ok($converted eq $src); ok($charset, "EUC-JP", $charset); ok($encoding, "B", $encoding); } # test get encodings for header with auto-detection of 7-bit ($converted, $charset, $encoding) = $null->header_encode($dst); if (MIME::Charset::USE_ENCODE) { ok($converted eq $dst); ok($charset, "ISO-2022-JP", $charset); ok($encoding, "B", $encoding); } else { ok($converted eq $dst); ok($charset, "US-ASCII", $charset); ok($encoding, undef, $encoding); } $obj = MIME::Charset->new("hz-gb-2312"); $src = "~{<:Ky2;S{#,NpJ)l6HK!#~}~"; ($converted, $charset, $encoding) = $obj->header_encode($src); ok($converted eq $src); ok($charset, "HZ-GB-2312", $charset); ok($encoding, "B", $encoding); $src = "This doesn't contain non-ASCII."; ($converted, $charset, $encoding) = $obj->header_encode($src); ok($converted eq $src); ok($charset, "US-ASCII", $charset); ok($encoding, undef, $encoding); MIME-Charset-1.013.1/t/06utf.t0000644000175100017510000000260613071307715017375 0ustar hatukanezumihatukanezumiuse strict; use Test::More; BEGIN { if ($] < 5.007003) { plan skip_all => 'Unicode/multibyte support is not enabled'; } else { plan tests => 16; } } use MIME::Charset; my $utf16 = MIME::Charset->new('utf-16'); my $utf16be = MIME::Charset->new('utf-16be'); my $utf16le = MIME::Charset->new('utf-16le'); ok($utf16->decode("\xD8\x08\xDF\x45") eq "\x{12345}"); ok($utf16be->decode("\xD8\x08\xDF\x45") eq "\x{12345}"); ok($utf16->decode("\xFE\xFF\xD8\x08\xDF\x45") eq "\x{12345}"); ok($utf16le->decode("\x08\xD8\x45\xDF") eq "\x{12345}"); ok($utf16->decode("\xFF\xFE\x08\xD8\x45\xDF") eq "\x{12345}"); ok($utf16->encode("\x{12345}") eq "\xFE\xFF\xD8\x08\xDF\x45"); ok($utf16be->encode("\x{12345}") eq "\xD8\x08\xDF\x45"); ok($utf16le->encode("\x{12345}") eq "\x08\xD8\x45\xDF"); my $utf32 = MIME::Charset->new('utf-32'); my $utf32be = MIME::Charset->new('utf-32be'); my $utf32le = MIME::Charset->new('utf-32le'); ok($utf32->decode("\x00\x01\x23\x45") eq "\x{12345}"); ok($utf32be->decode("\x00\x01\x23\x45") eq "\x{12345}"); ok($utf32->decode("\0\0\xFE\xFF\x00\x01\x23\x45") eq "\x{12345}"); ok($utf32le->decode("\x45\x23\x01\x00") eq "\x{12345}"); ok($utf32->decode("\xFF\xFE\0\0\x45\x23\x01\x00") eq "\x{12345}"); ok($utf32->encode("\x{12345}") eq "\0\0\xFE\xFF\x00\x01\x23\x45"); ok($utf32be->encode("\x{12345}") eq "\x00\x01\x23\x45"); ok($utf32le->encode("\x{12345}") eq "\x45\x23\x01\x00"); MIME-Charset-1.013.1/t/02ooenclen.t0000644000175100017510000000071213071307715020371 0ustar hatukanezumihatukanezumiuse strict; use Test; BEGIN { plan tests => 4 } use MIME::Charset qw(:trans); my $s = "Perl: \xe8\xa8\x80\xe8\xaa\x9e"; my $obj = MIME::Charset->new("utf-8"); ok($obj->encoded_header_len($s), 28, $obj->encoded_header_len($s)); ok($obj->encoded_header_len($s,"b"), 28, $obj->encoded_header_len($s,"b")); ok($obj->encoded_header_len($s,"q"), 38, $obj->encoded_header_len($s,"q")); ok($obj->encoded_header_len($s,"s"), 28, $obj->encoded_header_len($s,"s")); MIME-Charset-1.013.1/t/04alias.t0000644000175100017510000000173514274352275017677 0ustar hatukanezumihatukanezumiuse strict; use Test::More; BEGIN { if ($] < 5.007003) { plan tests => 29; } else { if ($] < 5.008) { # Perl 5.7.3 + Encode 0.04 require Encode::CN; } plan tests => 34; } } my @names = qw( US-ASCII ISO-8859-1 ISO-8859-2 ISO-8859-3 ISO-8859-4 ISO-8859-5 ISO-8859-6 ISO-8859-7 ISO-8859-8 ISO-8859-9 ISO-8859-10 SHIFT_JIS EUC-JP ISO-2022-KR EUC-KR ISO-2022-JP ISO-2022-JP-2 ISO-8859-6-I ISO-8859-6-E ISO-8859-8-E ISO-8859-8-I GB2312 BIG5 KOI8-R UTF-8 UTF-16 UTF-32 HZ-GB-2312 TIS-620 ); use MIME::Charset qw(:info); foreach my $name (@names) { my $obj = MIME::Charset->new($name); is($obj->as_string, $name, $name); if (&MIME::Charset::USE_ENCODE and grep {$name eq $_} ('HZ-GB-2312', 'ISO-8859-8-I', 'TIS-620', 'UTF-16', 'UTF-32')) { is($obj->decoder ? 'defined' : undef, 'defined', "$name available"); diag("$name is decoded by '".$obj->decoder->name."' encoding") if $obj->decoder; } } MIME-Charset-1.013.1/t/pod.t0000644000175100017510000000043513071307715017211 0ustar hatukanezumihatukanezumiuse strict; use Test::More; if ($] < 5.007003 ) { plan skip_all => "Perl 5.7.3 or later required for testing utf-8 POD"; } else { eval "use Test::Pod 1.00"; if ($@) { plan skip_all => "Test::Pod 1.00 or later required for testing POD"; } } all_pod_files_ok(); MIME-Charset-1.013.1/t/03info.t0000644000175100017510000000100013071307715017512 0ustar hatukanezumihatukanezumiuse strict; use Test; BEGIN { plan tests => 4 } use MIME::Charset qw(:info); ok(body_encoding("iso-8859-2"), "Q", body_encoding("iso-8859-2")); ok(canonical_charset("ANSI X3.4-1968"), "US-ASCII", canonical_charset("ANSI X3.4-1968")); ok(header_encoding("utf-8"), "S", header_encoding("utf-8")); if (MIME::Charset::USE_ENCODE) { ok(output_charset("shift_jis"), "ISO-2022-JP", output_charset("shift_jis")); } else { ok(output_charset("shift_jis"), "SHIFT_JIS", output_charset("shift_jis")); } MIME-Charset-1.013.1/t/05jp.t0000644000175100017510000000455513071307715017214 0ustar hatukanezumihatukanezumiuse strict; use Test::More; eval "use Encode::EUCJPASCII"; if ($@) { plan skip_all => "Encode::EUCJPASCII required"; } else { plan tests => 18; } use MIME::Charset qw(:trans); my ($converted, $charset, $encoding); my $src = "\x5C\x7E\xA1\xB1\xA1\xBD\xA1\xC0\xA1\xC1\xA1\xC2\xA1\xDD\xA1\xEF\xA1\xF1\xA1\xF2\xA2\xCC\xA1\xC1\x8F\xA2\xC3"; my $dst = "\x5c\x7e\e\x24\x42\x21\x31\x21\x3d\x21\x40\x21\x41\x21\x42\x21\x5d\x21\x6f\x21\x71\x21\x72\x22\x4c\x21\x41\e\x24\x28\x44\x22\x43\e\x28\x42"; # test get encodings for body ($converted, $charset, $encoding) = body_encode($src, "euc-jp"); if (MIME::Charset::USE_ENCODE) { is($converted, $dst); is($charset, "ISO-2022-JP"); is($encoding, "7BIT"); } else { is($converted, $src); is($charset, "EUC-JP"); is($encoding, "8BIT"); } # test get encodings for body with auto-detection of 7-bit ($converted, $charset, $encoding) = body_encode($dst); if (MIME::Charset::USE_ENCODE) { is($converted, $dst); is($charset, "ISO-2022-JP"); is($encoding, "7BIT"); } else { is($converted, $dst); is($charset, "US-ASCII"); is($encoding, "7BIT"); } # test get encodings for header ($converted, $charset, $encoding) = header_encode($src, "euc-jp"); if (MIME::Charset::USE_ENCODE) { is($converted, $dst); is($charset, "ISO-2022-JP"); is($encoding, "B"); } else { is($converted, $src); is($charset, "EUC-JP"); is($encoding, "B"); } # test get encodings for header with auto-detection of 7-bit ($converted, $charset, $encoding) = header_encode($dst); if (MIME::Charset::USE_ENCODE) { is($converted, $dst); is($charset, "ISO-2022-JP"); is($encoding, "B"); } else { is($converted, $dst); is($charset, "US-ASCII"); is($encoding, undef); } $src = $dst; # test get encodings for body ($converted, $charset, $encoding) = body_encode($src, "iso-2022-jp"); if (MIME::Charset::USE_ENCODE) { is($converted, $dst); is($charset, "ISO-2022-JP"); is($encoding, "7BIT"); } else { is($converted, $src); is($charset, "ISO-2022-JP"); is($encoding, "7BIT"); } # test get encodings for header ($converted, $charset, $encoding) = header_encode($src, "iso-2022-jp"); if (MIME::Charset::USE_ENCODE) { is($converted, $dst); is($charset, "ISO-2022-JP"); is($encoding, "B"); } else { is($converted, $src); is($charset, "ISO-2022-JP"); is($encoding, "B"); } MIME-Charset-1.013.1/inc/0000755000175100017510000000000014275402653016552 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/inc/Module/0000755000175100017510000000000014275402653017777 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/inc/Module/Install/0000755000175100017510000000000014275402653021405 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/inc/Module/Install/Makefile.pm0000644000175100017510000002703213071307715023460 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 MIME-Charset-1.013.1/inc/Module/Install/WriteAll.pm0000644000175100017510000000237613071307715023472 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; MIME-Charset-1.013.1/inc/Module/Install/Fetch.pm0000644000175100017510000000462713071307715023001 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; MIME-Charset-1.013.1/inc/Module/Install/Win32.pm0000644000175100017510000000340313071307715022641 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; MIME-Charset-1.013.1/inc/Module/Install/AutoInstall.pm0000644000175100017510000000363213071307715024202 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; MIME-Charset-1.013.1/inc/Module/Install/Include.pm0000644000175100017510000000101513071307715023317 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; MIME-Charset-1.013.1/inc/Module/Install/Can.pm0000644000175100017510000000333313071307715022442 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 MIME-Charset-1.013.1/inc/Module/Install/Metadata.pm0000644000175100017510000004312313071307715023462 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; MIME-Charset-1.013.1/inc/Module/Install/Base.pm0000644000175100017510000000214713071307715022615 0ustar hatukanezumihatukanezumi#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 MIME-Charset-1.013.1/inc/Module/Install.pm0000644000175100017510000003013513071307715021741 0ustar hatukanezumihatukanezumi#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.01'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2011 Adam Kennedy. MIME-Charset-1.013.1/inc/Module/AutoInstall.pm0000644000175100017510000005423113071307715022575 0ustar hatukanezumihatukanezumi#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 MIME-Charset-1.013.1/COPYING0000644000175100017510000004325413071307715017040 0ustar hatukanezumihatukanezumi GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. MIME-Charset-1.013.1/lib/0000755000175100017510000000000014275402653016547 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/lib/MIME/0000755000175100017510000000000014275402653017276 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/lib/MIME/Charset/0000755000175100017510000000000014275402653020667 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/lib/MIME/Charset/UTF.pm0000644000175100017510000000224413071307715021661 0ustar hatukanezumihatukanezumi#-*- perl -*- #-*- encoding: utf-8 -*- package MIME::Charset::UTF; use strict; use Carp qw(croak); use Encode::Encoding; use vars qw(@ISA $VERSION); @ISA = qw(Encode::Encoding); $VERSION = '1.010'; __PACKAGE__->Define('x-utf16auto'); __PACKAGE__->Define('x-utf32auto'); sub perlio_ok { 0 } sub decode { my ($self, $octets, $check) = @_; if ($self->name =~ /16/) { if ($octets =~ /\A\xFE\xFF/ or $octets =~ /\A\xFF\xFE/) { return Encode::find_encoding('UTF-16')->decode($_[1], $_[2]); } else { return Encode::find_encoding('UTF-16BE')->decode($_[1], $_[2]); } } elsif ($self->name =~ /32/) { if ($octets =~ /\A\0\0\xFE\xFF/ or $octets =~ /\A\xFF\xFE\0\0/) { return Encode::find_encoding('UTF-32')->decode($_[1], $_[2]); } else { return Encode::find_encoding('UTF-32BE')->decode($_[1], $_[2]); } } else { croak 'bug in logic. Ask developer'; } } sub encode { my $self = $_[0]; if ($self->name =~ /16/) { return Encode::find_encoding('UTF-16')->encode($_[1], $_[2]); } elsif ($self->name =~ /32/) { return Encode::find_encoding('UTF-32')->encode($_[1], $_[2]); } else { croak 'bug in logic. Ask developer'; } } MIME-Charset-1.013.1/lib/MIME/Charset/Defaults.pm.sample0000644000175100017510000000131713071307715024252 0ustar hatukanezumihatukanezumi#-*- perl -*- package MIME::Charset; =head1 NAME MIME::Charset::Defaults - Configuration for MIME::Charset =head1 SYNOPSIS Edit this file and place it on MIME/Charset/Defaults.pm to activate custom settings. =head1 DESCRIPTION Following settings are available. =over 4 =item Detect7bit =item Replacement =item Mapping =back =head1 SEE ALSO L =cut #--------------------------------------------------------------------------# # Add your own settings below. #--------------------------------------------------------------------------# ## Default settings on current release are: # $Config->{Detect7bit} = 'YES'; # $Config->{Replacement} = 'DEFAULT'; # $Config->{Mapping} = 'EXTENDED'; 1; MIME-Charset-1.013.1/lib/MIME/Charset/_Compat.pm0000644000175100017510000000625313071307715022611 0ustar hatukanezumihatukanezumi package MIME::Charset::_Compat; use 5.004; use strict; use Carp qw(croak); use vars qw($VERSION); $VERSION = "1.003.1"; sub FB_CROAK { 0x1; } sub FB_PERLQQ { 0x100; } sub FB_HTMLCREF { 0x200; } sub FB_XMLCREF { 0x400; } sub encode { $_[1]; } sub decode { $_[1]; } sub from_to { if ((lc($_[2]) eq "us-ascii" or lc($_[1]) eq "us-ascii") and $_[0] =~ s/[^\x01-\x7e]/?/g and $_[3] == 1) { croak "Non-ASCII characters"; } $_[0]; } sub is_utf8 { 0; } sub resolve_alias { my $cset = lc(shift); if ($cset eq "8bit" or $cset !~ /\S/) { return undef; } elsif ($cset eq '_unicode_') { return $cset; } else { # Taken from Encode-2.24. my %Winlatin2cp = ( 'latin1' => 1252, 'latin2' => 1250, 'cyrillic' => 1251, 'greek' => 1253, 'turkish' => 1254, 'hebrew' => 1255, 'arabic' => 1256, 'baltic' => 1257, 'vietnamese' => 1258, ); my @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 ); $cset =~ s/^(\S+)[\s_]+(.*)$/$1-$2/i; $cset =~ s/^UTF-8$/utf8/i; $cset =~ s/^.*\bhk(?:scs)?[-_]?big5$/big5-hkscs/i; $cset =~ s/^.*\bbig5-?hk(?:scs)?$/big5-hkscs/i; $cset =~ s/^.*\btca[-_]?big5$/big5-eten/i; $cset =~ s/^.*\bbig5-?et(?:en)?$/big5-eten/i; $cset =~ s/^.*\bbig-?5$/big5-eten/i; $cset =~ s/^.*\bks_c_5601-1987$/cp949/i; $cset =~ s/^.*(?:x-)?windows-949$/cp949/i; $cset =~ s/^.*(?:x-)?uhc$/cp949/i; $cset =~ s/^.*\bkr.*euc$/euc-kr/i; $cset =~ s/^.*\beuc.*kr$/euc-kr/i; $cset =~ s/^.*\bsjis$/shiftjis/i; $cset =~ s/^.*\bshift.*jis$/shiftjis/i; $cset =~ s/^.*\bujis$/euc-jp/i; $cset =~ s/^.*\bjp.*euc$/euc-jp/i; $cset =~ s/^.*\beuc.*jp$/euc-jp/i; $cset =~ s/^.*\bjis$/7bit-jis/i; $cset =~ s/^.*\bGB[-_ ]?2312(?!-?raw).*$/euc-cn/i; $cset =~ s/^gbk$/cp936/i; $cset =~ s/^.*\bcn.*euc$/euc-cn/i; $cset =~ s/^.*\beuc.*cn$/euc-cn/i; $cset =~ s/^.*\bkoi8[-\s_]*([ru])$/koi8-$1/i; $cset =~ s/^mac_(.*)$/mac$1/i; $cset =~ s/^.*\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/cp$1/i; $cset =~ s/^tis620$/iso-8859-11/i; $cset =~ s/^thai$/iso-8859-11/i; $cset =~ s/^hebrew$/iso-8859-8/i; $cset =~ s/^greek$/iso-8859-7/i; $cset =~ s/^arabic$/iso-8859-6/i; $cset =~ s/^cyrillic$/iso-8859-5/i; $cset =~ s/^ascii$/US-ascii/i; if ($cset =~ /^.*\bwin(latin[12]|cyrillic|baltic|greek|turkish| hebrew|arabic|baltic|vietnamese)$/ix) { $cset = "cp" . $Winlatin2cp{lc($1)}; } if ($cset =~ /^.*\b(?:iso[-_]?)?latin[-_]?(\d+)$/i) { $cset = defined $Latin2iso[$1] ? "iso-8859-$Latin2iso[$1]" : undef; } $cset =~ s/^(.+)\@euro$/$1/i; $cset =~ s/^.*\bANSI[-_]?X3\.4[-_]?1968$/ascii/i; $cset =~ s/^.*\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/${1}8/i; $cset =~ s/^.*\biso8859(\d+)$/iso-8859-$1/i; $cset =~ s/^.*\biso[-_]?(\d+)[-_](\d+)$/iso-$1-$2/i; $cset =~ s/^.*\bISO[-_]?646[-_]?US$/ascii/i; $cset =~ s/^C$/ascii/i; $cset =~ s/^(?:US-?)ascii$/ascii/i; $cset =~ s/^UTF(16|32)$/UTF-$1/i; $cset =~ s/^UTF(16|32)-?LE$/UTF-$1LE/i; $cset =~ s/^UTF(16|32)-?BE$/UTF-$1BE/i; $cset =~ s/^iso-10646-1$/UCS-2BE/i; $cset =~ s/^UCS-?4-?(BE|LE)?$/uc("UTF-32$1")/ie; $cset =~ s/^UCS-?2-?(BE)?$/UCS-2BE/i; $cset =~ s/^UCS-?2-?LE$/UCS-2LE/i; $cset =~ s/^UTF-?7$/UTF-7/i; $cset =~ s/^(.*)$/\L$1/; return $cset; } } 1; MIME-Charset-1.013.1/lib/MIME/Charset.pm0000644000175100017510000011033314275401371021222 0ustar hatukanezumihatukanezumi#-*- perl -*- package MIME::Charset; use 5.005; =head1 NAME MIME::Charset - Charset Information for MIME =head1 SYNOPSIS use MIME::Charset: $charset = MIME::Charset->new("euc-jp"); Getting charset information: $benc = $charset->body_encoding; # e.g. "Q" $cset = $charset->as_string; # e.g. "US-ASCII" $henc = $charset->header_encoding; # e.g. "S" $cset = $charset->output_charset; # e.g. "ISO-2022-JP" Translating text data: ($text, $charset, $encoding) = $charset->header_encode( "\xc9\xc2\xc5\xaa\xc0\xde\xc3\xef\xc5\xaa". "\xc7\xd1\xca\xaa\xbd\xd0\xce\xcf\xb4\xef", Charset => 'euc-jp'); # ...returns e.g. (, "ISO-2022-JP", "B"). ($text, $charset, $encoding) = $charset->body_encode( "Collectioneur path\xe9tiquement ". "\xe9clectique de d\xe9chets", Charset => 'latin1'); # ...returns e.g. (, "ISO-8859-1", "QUOTED-PRINTABLE"). $len = $charset->encoded_header_len( "Perl\xe8\xa8\x80\xe8\xaa\x9e", Charset => 'utf-8', Encoding => "b"); # ...returns e.g. 28. Manipulating module defaults: MIME::Charset::alias("csEUCKR", "euc-kr"); MIME::Charset::default("iso-8859-1"); MIME::Charset::fallback("us-ascii"); Non-OO functions (may be deprecated in near future): use MIME::Charset qw(:info); $benc = body_encoding("iso-8859-2"); # "Q" $cset = canonical_charset("ANSI X3.4-1968"); # "US-ASCII" $henc = header_encoding("utf-8"); # "S" $cset = output_charset("shift_jis"); # "ISO-2022-JP" use MIME::Charset qw(:trans); ($text, $charset, $encoding) = header_encode( "\xc9\xc2\xc5\xaa\xc0\xde\xc3\xef\xc5\xaa". "\xc7\xd1\xca\xaa\xbd\xd0\xce\xcf\xb4\xef", "euc-jp"); # ...returns (, "ISO-2022-JP", "B"); ($text, $charset, $encoding) = body_encode( "Collectioneur path\xe9tiquement ". "\xe9clectique de d\xe9chets", "latin1"); # ...returns (, "ISO-8859-1", "QUOTED-PRINTABLE"); $len = encoded_header_len( "Perl\xe8\xa8\x80\xe8\xaa\x9e", "b", "utf-8"); # 28 =head1 DESCRIPTION MIME::Charset provides information about character sets used for MIME messages on Internet. =head2 Definitions The B is ``character set'' used in MIME to refer to a method of converting a sequence of octets into a sequence of characters. It includes both concepts of ``coded character set'' (CCS) and ``character encoding scheme'' (CES) of ISO/IEC. The B is that used in MIME to refer to a method of representing a body part or a header body as sequence(s) of printable US-ASCII characters. =cut use strict; use vars qw(@ISA $VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS $Config); use Exporter; @ISA = qw(Exporter); @EXPORT = qw(body_encoding canonical_charset header_encoding output_charset body_encode encoded_header_len header_encode); @EXPORT_OK = qw(alias default fallback recommended); %EXPORT_TAGS = ( "info" => [qw(body_encoding header_encoding canonical_charset output_charset)], "trans" =>[ qw(body_encode encoded_header_len header_encode)], ); use Carp qw(croak); use constant USE_ENCODE => ($] >= 5.007003)? 'Encode': ''; my @ENCODE_SUBS = qw(FB_CROAK FB_PERLQQ FB_HTMLCREF FB_XMLCREF is_utf8 resolve_alias); if (USE_ENCODE) { eval "use ".USE_ENCODE." \@ENCODE_SUBS;"; if ($@) { # Perl 5.7.3 + Encode 0.40 eval "use ".USE_ENCODE." qw(is_utf8);"; require MIME::Charset::_Compat; for my $sub (@ENCODE_SUBS) { no strict "refs"; *{$sub} = \&{"MIME::Charset::_Compat::$sub"} unless $sub eq 'is_utf8'; } } } else { require MIME::Charset::_Compat; for my $sub (@ENCODE_SUBS) { no strict "refs"; *{$sub} = \&{"MIME::Charset::_Compat::$sub"}; } } $VERSION = '1.013.1'; ######## Private Attributes ######## my $DEFAULT_CHARSET = 'US-ASCII'; my $FALLBACK_CHARSET = 'UTF-8'; # This table was initially borrowed from Python email package. my %CHARSETS = (# input header enc body enc output conv 'DIN_66003' => ['Q', undef, undef], 'ISO-8859-1' => ['Q', 'Q', undef], 'ISO-8859-2' => ['Q', 'Q', undef], 'ISO-8859-3' => ['Q', 'Q', undef], 'ISO-8859-4' => ['Q', 'Q', undef], # ISO-8859-5 is Cyrillic, and not especially used # ISO-8859-6 is Arabic, also not particularly used # ISO-8859-7 is Greek, 'Q' will not make it readable # ISO-8859-8 is Hebrew, 'Q' will not make it readable 'ISO-8859-9' => ['Q', 'Q', undef], 'ISO-8859-10' => ['Q', 'Q', undef], # ISO-8859-11 is Thai, 'Q' will not make it readable 'ISO-8859-13' => ['Q', 'Q', undef], 'ISO-8859-14' => ['Q', 'Q', undef], 'ISO-8859-15' => ['Q', 'Q', undef], 'ISO-8859-16' => ['Q', 'Q', undef], 'WINDOWS-1252' => ['Q', 'Q', undef], 'VISCII' => ['Q', 'Q', undef], 'US-ASCII' => [undef, undef, undef], 'BIG5' => ['B', 'B', undef], 'GB2312' => ['B', 'B', undef], 'HZ-GB-2312' => ['B', undef, undef], 'EUC-JP' => ['B', undef, 'ISO-2022-JP'], 'SHIFT_JIS' => ['B', undef, 'ISO-2022-JP'], 'ISO-2022-JP' => ['B', undef, undef], 'ISO-2022-JP-1' => ['B', undef, undef], 'ISO-2022-JP-2' => ['B', undef, undef], 'EUC-JISX0213' => ['B', undef, 'ISO-2022-JP-3'], 'SHIFT_JISX0213' => ['B', undef, 'ISO-2022-JP-3'], 'ISO-2022-JP-3' => ['B', undef, undef], 'EUC-JIS-2004' => ['B', undef, 'ISO-2022-JP-2004'], 'SHIFT_JIS-2004' => ['B', undef, 'ISO-2022-JP-2004'], 'ISO-2022-JP-2004' => ['B', undef, undef], 'KOI8-R' => ['B', 'B', undef], 'TIS-620' => ['B', 'B', undef], # cf. Mew 'UTF-16' => ['B', 'B', undef], 'UTF-16BE' => ['B', 'B', undef], 'UTF-16LE' => ['B', 'B', undef], 'UTF-32' => ['B', 'B', undef], 'UTF-32BE' => ['B', 'B', undef], 'UTF-32LE' => ['B', 'B', undef], 'UTF-7' => ['Q', undef, undef], 'UTF-8' => ['S', 'S', undef], 'GSM03.38' => [undef, undef, undef], # not for MIME # We're making this one up to represent raw unencoded 8bit '8BIT' => [undef, 'B', 'ISO-8859-1'], ); # Fix some unexpected or unpreferred names returned by # Encode::resolve_alias() or used by somebodies else. my %CHARSET_ALIASES = (# unpreferred preferred "ASCII" => "US-ASCII", "BIG5-ETEN" => "BIG5", "CP1250" => "WINDOWS-1250", "CP1251" => "WINDOWS-1251", "CP1252" => "WINDOWS-1252", "CP1253" => "WINDOWS-1253", "CP1254" => "WINDOWS-1254", "CP1255" => "WINDOWS-1255", "CP1256" => "WINDOWS-1256", "CP1257" => "WINDOWS-1257", "CP1258" => "WINDOWS-1258", "CP874" => "WINDOWS-874", "CP936" => "GBK", "CP949" => "KS_C_5601-1987", "DIN66003" => "DIN_66003", "EUC-CN" => "GB2312", "HZ" => "HZ-GB-2312", # RFC 1842 "KS_C_5601" => "KS_C_5601-1987", "SHIFTJIS" => "SHIFT_JIS", "SHIFTJISX0213" => "SHIFT_JISX0213", "TIS620" => "TIS-620", # IANA MIBenum 2259 "UNICODE-1-1-UTF-7" => "UTF-7", # RFC 1642 (obs.) "UTF8" => "UTF-8", "UTF-8-STRICT" => "UTF-8", # Perl internal use "GSM0338" => "GSM03.38", # not for MIME ); # Some vendors encode characters beyond standardized mappings using extended # encoders. Some other standard encoders need additional encode modules. my %ENCODERS = ( 'EXTENDED' => { 'ISO-8859-1' => [['cp1252'], ], # Encode::Byte 'ISO-8859-2' => [['cp1250'], ], # Encode::Byte 'ISO-8859-5' => [['cp1251'], ], # Encode::Byte 'ISO-8859-6' => [ ['cp1256'], # Encode::Byte # ['cp1006'], # ditto, for Farsi ], 'ISO-8859-6-I'=>[['cp1256'], ], # ditto 'ISO-8859-7' => [['cp1253'], ], # Encode::Byte 'ISO-8859-8' => [['cp1255'], ], # Encode::Byte 'ISO-8859-8-I'=>[['cp1255'], ], # ditto 'ISO-8859-9' => [['cp1254'], ], # Encode::Byte 'ISO-8859-13'=> [['cp1257'], ], # Encode::Byte 'GB2312' => [ ['gb18030', 'Encode::HanExtra'], ['cp936'], # Encode::CN ], 'EUC-JP' => [ ['eucJP-ascii', 'Encode::EUCJPASCII'], # ['cp51932', 'Encode::EUCJPMS'], ], 'ISO-2022-JP'=> [ ['x-iso2022jp-ascii', 'Encode::EUCJPASCII'], # ['iso-2022-jp-ms','Encode::ISO2022JPMS'], # ['cp50220', 'Encode::EUCJPMS'], # ['cp50221', 'Encode::EUCJPMS'], ['iso-2022-jp-1'], # Encode::JP (note*) ], 'SHIFT_JIS' => [ ['cp932'], # Encode::JP ], 'EUC-JISX0213' => [['euc-jis-2004', 'Encode::JISX0213'], ], 'ISO-2022-JP-3' => [['iso-2022-jp-2004', 'Encode::JISX0213'], ], 'SHIFT_JISX0213'=> [['shift_jis-2004', 'Encode::ShiftJIS2004'], ], 'EUC-KR' => [['cp949'], ], # Encode::KR 'BIG5' => [ # ['big5plus', 'Encode::HanExtra'], # ['big5-2003', 'Encode::HanExtra'], ['cp950'], # Encode::TW # ['big5-1984', 'Encode::HanExtra'], ], 'TIS-620' => [['cp874'], ], # Encode::Byte 'UTF-8' => [['utf8'], ], # Special name on Perl }, 'STANDARD' => { 'DIN_66003' => [['din66003', 'Endode::DIN66003'], ], 'ISO-8859-6-E' => [['iso-8859-6'],],# Encode::Byte 'ISO-8859-6-I' => [['iso-8859-6'],],# ditto 'ISO-8859-8-E' => [['iso-8859-8'],],# Encode::Byte 'ISO-8859-8-I' => [['iso-8859-8'],],# ditto 'GB18030' => [['gb18030', 'Encode::HanExtra'], ], 'ISO-2022-JP-2' => [['iso-2022-jp-2','Encode::ISO2022JP2'], ], 'EUC-JISX0213' => [['euc-jisx0213', 'Encode::JISX0213'], ], 'ISO-2022-JP-3' => [['iso-2022-jp-3', 'Encode::JISX0213'], ], 'EUC-JIS-2004' => [['euc-jis-2004', 'Encode::JISX0213'], ], 'ISO-2022-JP-2004' => [['iso-2022-jp-2004', 'Encode::JISX0213'], ], 'SHIFT_JIS-2004'=> [['shift_jis-2004', 'Encode::ShiftJIS2004'], ], 'EUC-TW' => [['euc-tw', 'Encode::HanExtra'], ], 'HZ-GB-2312' => [['hz'], ], # Encode::CN 'TIS-620' => [['tis620'], ], # (note*) 'UTF-16' => [['x-utf16auto', 'MIME::Charset::UTF'],], 'UTF-32' => [['x-utf32auto', 'MIME::Charset::UTF'],], 'GSM03.38' => [['gsm0338'], ], # Encode::GSM0338 # (note*) ISO-8859-11 was not registered by IANA. # L treats it as canonical name of ``tis-?620''. }, ); # ISO-2022-* escape sequences etc. to detect charset from unencoded data. my @ESCAPE_SEQS = ( # ISO-2022-* sequences # escape seq, possible charset # Following sequences are commonly used. ["\033\$\@", "ISO-2022-JP"], # RFC 1468 ["\033\$B", "ISO-2022-JP"], # ditto ["\033(J", "ISO-2022-JP"], # ditto ["\033(I", "ISO-2022-JP"], # ditto (nonstandard) ["\033\$(D", "ISO-2022-JP"], # RFC 2237 (note*) # Following sequences are less commonly used. ["\033.A", "ISO-2022-JP-2"], # RFC 1554 ["\033.F", "ISO-2022-JP-2"], # ditto ["\033\$(C", "ISO-2022-JP-2"], # ditto ["\033\$(O", "ISO-2022-JP-3"], # JIS X 0213:2000 ["\033\$(P", "ISO-2022-JP-2004"], # JIS X 0213:2000/2004 ["\033\$(Q", "ISO-2022-JP-2004"], # JIS X 0213:2004 ["\033\$)C", "ISO-2022-KR"], # RFC 1557 ["\033\$)A", "ISO-2022-CN"], # RFC 1922 ["\033\$A", "ISO-2022-CN"], # ditto (nonstandard) ["\033\$)G", "ISO-2022-CN"], # ditto ["\033\$*H", "ISO-2022-CN"], # ditto # Other sequences will be used with appropriate charset # parameters, or hardly used. # note*: This RFC defines ISO-2022-JP-1, superset of # ISO-2022-JP. But that charset name is rarely used. # OTOH many of encoders for ISO-2022-JP recognize this # sequence so that comatibility with EUC-JP will be # guaranteed. # Singlebyte 7-bit sequences # escape seq, possible charset ["\033e", "GSM03.38"], # ESTI GSM 03.38 (note*) ["\033\012", "GSM03.38"], # ditto ["\033<", "GSM03.38"], # ditto ["\033/", "GSM03.38"], # ditto ["\033>", "GSM03.38"], # ditto ["\033\024", "GSM03.38"], # ditto ["\033(", "GSM03.38"], # ditto ["\033\@", "GSM03.38"], # ditto ["\033)", "GSM03.38"], # ditto ["\033=", "GSM03.38"], # ditto # note*: This is not used for MIME message. ); ######## Public Configuration Attributes ######## $Config = { Detect7bit => 'YES', Mapping => 'EXTENDED', Replacement => 'DEFAULT', }; local @INC = @INC; pop @INC if $INC[-1] eq '.'; eval { require MIME::Charset::Defaults; }; ######## Private Constants ######## my $NON7BITRE = qr{ [^\x01-\x7e] }x; my $NONASCIIRE = qr{ [^\x09\x0a\x0d\x20\x21-\x7e] }x; my $ISO2022RE = qr{ ISO-2022-.+ }ix; my $ASCIITRANSRE = qr{ HZ-GB-2312 | UTF-7 }ix; ######## Public Functions ######## =head2 Constructor =over =item $charset = MIME::Charset->new([CHARSET [, OPTS]]) Create charset object. OPTS may accept following key-value pair. B: When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), conversion will not be performed. So this option do not have any effects. =over 4 =item Mapping => MAPTYPE Whether to extend mappings actually used for charset names or not. C<"EXTENDED"> uses extended mappings. C<"STANDARD"> uses standardized strict mappings. Default is C<"EXTENDED">. =back =cut sub new { my $class = shift; my $charset = shift; return bless {}, $class unless $charset; return bless {}, $class if 75 < length $charset; # w/a for CPAN RT #65796. my %params = @_; my $mapping = uc($params{'Mapping'} || $Config->{Mapping}); if ($charset =~ /\bhz.?gb.?2312$/i) { # workaround: "HZ-GB-2312" mistakenly treated as "EUC-CN" by Encode # (2.12). $charset = "HZ-GB-2312"; } elsif ($charset =~ /\btis-?620$/i) { # workaround: "TIS620" treated as ISO-8859-11 by Encode. # And "TIS-620" not known by some versions of Encode (cf. # CPAN RT #20781). $charset = "TIS-620"; } elsif ($charset =~ /\biso[-_]8859[-_]8[-_]i$/i) { # workaround: "ISO-8859-8-I" is treated as an alias of "ISO-8859-8" # by Encode (3.19): See the note in # https://encoding.spec.whatwg.org/#legacy-single-byte-encodings # However we'll treat these as separate names for compatibility. $charset = "ISO-8859-8-I"; } else { $charset = resolve_alias($charset) || $charset } $charset = $CHARSET_ALIASES{uc($charset)} || uc($charset); my ($henc, $benc, $outcset); my $spec = $CHARSETS{$charset}; if ($spec) { ($henc, $benc, $outcset) = ($$spec[0], $$spec[1], USE_ENCODE? $$spec[2]: undef); } else { ($henc, $benc, $outcset) = ('S', 'B', undef); } my ($decoder, $encoder); if (USE_ENCODE) { $decoder = _find_encoder($charset, $mapping); $encoder = _find_encoder($outcset, $mapping); } else { $decoder = $encoder = undef; } bless { InputCharset => $charset, Decoder => $decoder, HeaderEncoding => $henc, BodyEncoding => $benc, OutputCharset => ($outcset || $charset), Encoder => ($encoder || $decoder), }, $class; } my %encoder_cache = (); sub _find_encoder($$) { my $charset = uc(shift || ""); return undef unless $charset; my $mapping = uc(shift); my ($spec, $name, $module, $encoder); local($@); $encoder = $encoder_cache{$charset, $mapping}; return $encoder if ref $encoder; foreach my $m (('EXTENDED', 'STANDARD')) { next if $m eq 'EXTENDED' and $mapping ne 'EXTENDED'; $spec = $ENCODERS{$m}->{$charset}; next unless $spec; foreach my $s (@{$spec}) { ($name, $module) = @{$s}; if ($module) { next unless eval "require $module;"; } $encoder = Encode::find_encoding($name); last if ref $encoder; } last if ref $encoder; } $encoder ||= Encode::find_encoding($charset); $encoder_cache{$charset, $mapping} = $encoder if $encoder; return $encoder; } =back =head2 Getting Information of Charsets =over =item $charset->body_encoding =item body_encoding CHARSET Get recommended transfer-encoding of CHARSET for message body. Returned value will be one of C<"B"> (BASE64), C<"Q"> (QUOTED-PRINTABLE), C<"S"> (shorter one of either) or C (might not be transfer-encoded; either 7BIT or 8BIT). This may not be same as encoding for message header. =cut sub body_encoding($) { my $self = shift; return undef unless $self; $self = __PACKAGE__->new($self) unless ref $self; $self->{BodyEncoding}; } =item $charset->as_string =item canonical_charset CHARSET Get canonical name for charset. =cut sub canonical_charset($) { my $self = shift; return undef unless $self; $self = __PACKAGE__->new($self) unless ref $self; $self->{InputCharset}; } sub as_string($) { my $self = shift; $self->{InputCharset}; } =item $charset->decoder Get L<"Encode::Encoding"> object to decode strings to Unicode by charset. If charset is not specified or not known by this module, undef will be returned. =cut sub decoder($) { my $self = shift; $self->{Decoder}; } =item $charset->dup Get a copy of charset object. =cut sub dup($) { my $self = shift; my $obj = __PACKAGE__->new(undef); %{$obj} = %{$self}; $obj; } =item $charset->encoder([CHARSET]) Get L<"Encode::Encoding"> object to encode Unicode string using compatible charset recommended to be used for messages on Internet. If optional CHARSET is specified, replace encoder (and output charset name) of $charset object with those of CHARSET, therefore, $charset object will be a converter between original charset and new CHARSET. =cut sub encoder($$;) { my $self = shift; my $charset = shift; if ($charset) { $charset = __PACKAGE__->new($charset) unless ref $charset; $self->{OutputCharset} = $charset->{InputCharset}; $self->{Encoder} = $charset->{Decoder}; $self->{BodyEncoding} = $charset->{BodyEncoding}; $self->{HeaderEncoding} = $charset->{HeaderEncoding}; } $self->{Encoder}; } =item $charset->header_encoding =item header_encoding CHARSET Get recommended encoding scheme of CHARSET for message header. Returned value will be one of C<"B">, C<"Q">, C<"S"> (shorter one of either) or C (might not be encoded). This may not be same as encoding for message body. =cut sub header_encoding($) { my $self = shift; return undef unless $self; $self = __PACKAGE__->new($self) unless ref $self; $self->{HeaderEncoding}; } =item $charset->output_charset =item output_charset CHARSET Get a charset which is compatible with given CHARSET and is recommended to be used for MIME messages on Internet (if it is known by this module). When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), this function will simply return the result of L<"canonical_charset">. =cut sub output_charset($) { my $self = shift; return undef unless $self; $self = __PACKAGE__->new($self) unless ref $self; $self->{OutputCharset}; } =back =head2 Translating Text Data =over =item $charset->body_encode(STRING [, OPTS]) =item body_encode STRING, CHARSET [, OPTS] Get converted (if needed) data of STRING and recommended transfer-encoding of that data for message body. CHARSET is the charset by which STRING is encoded. OPTS may accept following key-value pairs. B: When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), conversion will not be performed. So these options do not have any effects. =over 4 =item Detect7bit => YESNO Try auto-detecting 7-bit charset when CHARSET is not given. Default is C<"YES">. =item Replacement => REPLACEMENT Specifies error handling scheme. See L<"Error Handling">. =back 3-item list of (I, I, I) will be returned. I will be either C<"BASE64">, C<"QUOTED-PRINTABLE">, C<"7BIT"> or C<"8BIT">. If I could not be determined and I contains non-ASCII byte(s), I will be C and I will be C<"BASE64">. I will be C<"US-ASCII"> if and only if string does not contain any non-ASCII bytes. =cut sub body_encode { my $self = shift; my $text; if (ref $self) { $text = shift; } else { $text = $self; $self = __PACKAGE__->new(shift); } my ($encoded, $charset) = $self->_text_encode($text, @_); return ($encoded, undef, 'BASE64') unless $charset and $charset->{InputCharset}; my $cset = $charset->{OutputCharset}; # Determine transfer-encoding. my $enc = $charset->{BodyEncoding}; if (!$enc and $encoded !~ /\x00/) { # Eliminate hostile NUL character. if ($encoded =~ $NON7BITRE) { # String contains 8bit char(s). $enc = '8BIT'; } elsif ($cset =~ /^($ISO2022RE|$ASCIITRANSRE)$/) { # 7BIT. $enc = '7BIT'; } else { # Pure ASCII. $enc = '7BIT'; $cset = 'US-ASCII'; } } elsif ($enc eq 'S') { $enc = _resolve_S($encoded, 1); } elsif ($enc eq 'B') { $enc = 'BASE64'; } elsif ($enc eq 'Q') { $enc = 'QUOTED-PRINTABLE'; } else { $enc = 'BASE64'; } return ($encoded, $cset, $enc); } =item $charset->decode(STRING [,CHECK]) Decode STRING to Unicode. B: When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), this function will die. =cut sub decode($$$;) { my $self = shift; my $s = shift; my $check = shift || 0; $self->{Decoder}->decode($s, $check); } =item detect_7bit_charset STRING Guess 7-bit charset that may encode a string STRING. If STRING contains any 8-bit bytes, C will be returned. Otherwise, Default Charset will be returned for unknown charset. =cut sub detect_7bit_charset($) { return $DEFAULT_CHARSET unless &USE_ENCODE; my $s = shift; return $DEFAULT_CHARSET unless $s; # Non-7bit string return undef if $s =~ $NON7BITRE; # Try to detect 7-bit escape sequences. foreach (@ESCAPE_SEQS) { my ($seq, $cset) = @$_; if (index($s, $seq) >= 0) { my $decoder = __PACKAGE__->new($cset); next unless $decoder->{Decoder}; eval { my $dummy = $s; $decoder->decode($dummy, FB_CROAK()); }; if ($@) { next; } return $decoder->{InputCharset}; } } # How about HZ, VIQR, UTF-7, ...? return $DEFAULT_CHARSET; } sub _detect_7bit_charset { detect_7bit_charset(@_); } =item $charset->encode(STRING [, CHECK]) Encode STRING (Unicode or non-Unicode) using compatible charset recommended to be used for messages on Internet (if this module knows it). Note that string will be decoded to Unicode then encoded even if compatible charset was equal to original charset. B: When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), this function will die. =cut sub encode($$$;) { my $self = shift; my $s = shift; my $check = shift || 0; unless (is_utf8($s) or $s =~ /[^\x00-\xFF]/) { $s = $self->{Decoder}->decode($s, ($check & 0x1)? FB_CROAK(): 0); } my $enc = $self->{Encoder}->encode($s, $check); Encode::_utf8_off($enc) if is_utf8($enc); # workaround for RT #35120 $enc; } =item $charset->encoded_header_len(STRING [, ENCODING]) =item encoded_header_len STRING, ENCODING, CHARSET Get length of encoded STRING for message header (without folding). ENCODING may be one of C<"B">, C<"Q"> or C<"S"> (shorter one of either C<"B"> or C<"Q">). =cut sub encoded_header_len($$$;) { my $self = shift; my ($encoding, $s); if (ref $self) { $s = shift; $encoding = uc(shift || $self->{HeaderEncoding}); } else { $s = $self; $encoding = uc(shift); $self = shift; $self = __PACKAGE__->new($self) unless ref $self; } #FIXME:$encoding === undef my $enclen; if ($encoding eq 'Q') { $enclen = _enclen_Q($s); } elsif ($encoding eq 'S' and _resolve_S($s) eq 'Q') { $enclen = _enclen_Q($s); } else { # "B" $enclen = _enclen_B($s); } length($self->{OutputCharset})+$enclen+7; } sub _enclen_B($) { int((length(shift) + 2) / 3) * 4; } sub _enclen_Q($;$) { my $s = shift; my $in_body = shift; my @o; if ($in_body) { @o = ($s =~ m{([^-\t\r\n !*+/0-9A-Za-z])}go); } else { @o = ($s =~ m{([^- !*+/0-9A-Za-z])}gos); } length($s) + scalar(@o) * 2; } sub _resolve_S($;$) { my $s = shift; my $in_body = shift; my $e; if ($in_body) { $e = scalar(() = $s =~ m{[^-\t\r\n !*+/0-9A-Za-z]}g); return (length($s) + 8 < $e * 6) ? 'BASE64' : 'QUOTED-PRINTABLE'; } else { $e = scalar(() = $s =~ m{[^- !*+/0-9A-Za-z]}g); return (length($s) + 8 < $e * 6) ? 'B' : 'Q'; } } =item $charset->header_encode(STRING [, OPTS]) =item header_encode STRING, CHARSET [, OPTS] Get converted (if needed) data of STRING and recommended encoding scheme of that data for message headers. CHARSET is the charset by which STRING is encoded. OPTS may accept following key-value pairs. B: When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), conversion will not be performed. So these options do not have any effects. =over 4 =item Detect7bit => YESNO Try auto-detecting 7-bit charset when CHARSET is not given. Default is C<"YES">. =item Replacement => REPLACEMENT Specifies error handling scheme. See L<"Error Handling">. =back 3-item list of (I, I, I) will be returned. I will be either C<"B">, C<"Q"> or C (might not be encoded). If I could not be determined and I contains non-ASCII byte(s), I will be C<"8BIT"> (this is I charset name but a special value to represent unencodable data) and I will be C (should not be encoded). I will be C<"US-ASCII"> if and only if string does not contain any non-ASCII bytes. =cut sub header_encode { my $self = shift; my $text; if (ref $self) { $text = shift; } else { $text = $self; $self = __PACKAGE__->new(shift); } my ($encoded, $charset) = $self->_text_encode($text, @_); return ($encoded, '8BIT', undef) unless $charset and $charset->{InputCharset}; my $cset = $charset->{OutputCharset}; # Determine encoding scheme. my $enc = $charset->{HeaderEncoding}; if (!$enc and $encoded !~ $NON7BITRE) { unless ($cset =~ /^($ISO2022RE|$ASCIITRANSRE)$/) { # 7BIT. $cset = 'US-ASCII'; } } elsif ($enc eq 'S') { $enc = _resolve_S($encoded); } elsif ($enc !~ /^[BQ]$/) { $enc = 'B'; } return ($encoded, $cset, $enc); } sub _text_encode { my $charset = shift; my $s = shift; my %params = @_; my $replacement = uc($params{'Replacement'} || $Config->{Replacement}); my $detect7bit = uc($params{'Detect7bit'} || $Config->{Detect7bit}); my $encoding = $params{'Encoding'} || (exists $params{'Encoding'}? undef: 'A'); # undocumented if (!$encoding or $encoding ne 'A') { # no 7-bit auto-detection $detect7bit = 'NO'; } unless ($charset->{InputCharset}) { if ($s =~ $NON7BITRE) { return ($s, undef); } elsif ($detect7bit ne "NO") { $charset = __PACKAGE__->new(&detect_7bit_charset($s)); } else { $charset = __PACKAGE__->new($DEFAULT_CHARSET, Mapping => 'STANDARD'); } } if (!$encoding or $encoding ne 'A') { # no conversion $charset = $charset->dup; $charset->encoder($charset); $charset->{HeaderEncoding} = $encoding; $charset->{BodyEncoding} = $encoding; } my $check = ($replacement and $replacement =~ /^\d+$/)? $replacement: { 'CROAK' => FB_CROAK(), 'STRICT' => FB_CROAK(), 'FALLBACK' => FB_CROAK(), # special 'PERLQQ' => FB_PERLQQ(), 'HTMLCREF' => FB_HTMLCREF(), 'XMLCREF' => FB_XMLCREF(), }->{$replacement || ""} || 0; # Encode data by output charset if required. If failed, fallback to # fallback charset. my $encoded; if (is_utf8($s) or $s =~ /[^\x00-\xFF]/ or ($charset->{InputCharset} || "") ne ($charset->{OutputCharset} || "")) { if ($check & 0x1) { # CROAK or FALLBACK eval { $encoded = $s; $encoded = $charset->encode($encoded, FB_CROAK()); }; if ($@) { if ($replacement eq "FALLBACK" and $FALLBACK_CHARSET) { my $cset = __PACKAGE__->new($FALLBACK_CHARSET, Mapping => 'STANDARD'); # croak unknown charset croak "unknown charset ``$FALLBACK_CHARSET''" unless $cset->{Decoder}; # charset translation $charset = $charset->dup; $charset->encoder($cset); $encoded = $s; $encoded = $charset->encode($encoded, 0); # replace input & output charsets with fallback charset $cset->encoder($cset); $charset = $cset; } else { $@ =~ s/ at .+$//; croak $@; } } } else { $encoded = $s; $encoded = $charset->encode($encoded, $check); } } else { $encoded = $s; } if ($encoded !~ /$NONASCIIRE/) { # maybe ASCII # check ``ASCII transformation'' charsets if ($charset->{OutputCharset} =~ /^($ASCIITRANSRE)$/) { my $u = $encoded; if (USE_ENCODE) { $u = $charset->encoder->decode($encoded); # dec. by output } elsif ($encoded =~ /[+~]/) { # workaround for pre-Encode env. $u = "x$u"; } if ($u eq $encoded) { $charset = $charset->dup; $charset->encoder($DEFAULT_CHARSET); } } elsif ($charset->{OutputCharset} ne "US-ASCII") { $charset = $charset->dup; $charset->encoder($DEFAULT_CHARSET); } } return ($encoded, $charset); } =item $charset->undecode(STRING [,CHECK]) Encode Unicode string STRING to byte string by input charset of $charset. This is equivalent to C<$charset-Edecoder-Eencode()>. B: When Unicode/multibyte support is disabled (see L<"USE_ENCODE">), this function will die. =cut sub undecode($$$;) { my $self = shift; my $s = shift; my $check = shift || 0; my $enc = $self->{Decoder}->encode($s, $check); Encode::_utf8_off($enc); # workaround for RT #35120 $enc; } =back =head2 Manipulating Module Defaults =over =item alias ALIAS [, CHARSET] Get/set charset alias for canonical names determined by L<"canonical_charset">. If CHARSET is given and isn't false, ALIAS will be assigned as an alias of CHARSET. Otherwise, alias won't be changed. In both cases, current charset name that ALIAS is assigned will be returned. =cut sub alias ($;$) { my $alias = uc(shift); my $charset = uc(shift); return $CHARSET_ALIASES{$alias} unless $charset; $CHARSET_ALIASES{$alias} = $charset; return $charset; } =item default [CHARSET] Get/set default charset. B is used by this module when charset context is unknown. Modules using this module are recommended to use this charset when charset context is unknown or implicit default is expected. By default, it is C<"US-ASCII">. If CHARSET is given and isn't false, it will be set to default charset. Otherwise, default charset won't be changed. In both cases, current default charset will be returned. B: Default charset I be changed. =cut sub default(;$) { my $charset = &canonical_charset(shift); if ($charset) { croak "Unknown charset '$charset'" unless resolve_alias($charset); $DEFAULT_CHARSET = $charset; } return $DEFAULT_CHARSET; } =item fallback [CHARSET] Get/set fallback charset. B is used by this module when conversion by given charset is failed and C<"FALLBACK"> error handling scheme is specified. Modules using this module may use this charset as last resort of charset for conversion. By default, it is C<"UTF-8">. If CHARSET is given and isn't false, it will be set to fallback charset. If CHARSET is C<"NONE">, fallback charset will be undefined. Otherwise, fallback charset won't be changed. In any cases, current fallback charset will be returned. B: It I useful that C<"US-ASCII"> is specified as fallback charset, since result of conversion will be readable without charset information. =cut sub fallback(;$) { my $charset = &canonical_charset(shift); if ($charset eq "NONE") { $FALLBACK_CHARSET = undef; } elsif ($charset) { croak "Unknown charset '$charset'" unless resolve_alias($charset); $FALLBACK_CHARSET = $charset; } return $FALLBACK_CHARSET; } =item recommended CHARSET [, HEADERENC, BODYENC [, ENCCHARSET]] Get/set charset profiles. If optional arguments are given and any of them are not false, profiles for CHARSET will be set by those arguments. Otherwise, profiles won't be changed. In both cases, current profiles for CHARSET will be returned as 3-item list of (HEADERENC, BODYENC, ENCCHARSET). HEADERENC is recommended encoding scheme for message header. It may be one of C<"B">, C<"Q">, C<"S"> (shorter one of either) or C (might not be encoded). BODYENC is recommended transfer-encoding for message body. It may be one of C<"B">, C<"Q">, C<"S"> (shorter one of either) or C (might not be transfer-encoded). ENCCHARSET is a charset which is compatible with given CHARSET and is recommended to be used for MIME messages on Internet. If conversion is not needed (or this module doesn't know appropriate charset), ENCCHARSET is C. B: This function in the future releases can accept more optional arguments (for example, properties to handle character widths, line folding behavior, ...). So format of returned value may probably be changed. Use L<"header_encoding">, L<"body_encoding"> or L<"output_charset"> to get particular profile. =cut sub recommended ($;$;$;$) { my $charset = &canonical_charset(shift); my $henc = uc(shift) || undef; my $benc = uc(shift) || undef; my $cset = &canonical_charset(shift); croak "CHARSET is not specified" unless $charset; croak "Unknown header encoding" unless !$henc or $henc =~ /^[BQS]$/; croak "Unknown body encoding" unless !$benc or $benc =~ /^[BQ]$/; if ($henc or $benc or $cset) { $cset = undef if $charset eq $cset; my @spec = ($henc, $benc, USE_ENCODE? $cset: undef); $CHARSETS{$charset} = \@spec; return @spec; } else { $charset = __PACKAGE__->new($charset) unless ref $charset; return map { $charset->{$_} } qw(HeaderEncoding BodyEncoding OutputCharset); } } =back =head2 Constants =over =item USE_ENCODE Unicode/multibyte support flag. Non-empty string will be set when Unicode and multibyte support is enabled. Currently, this flag will be non-empty on Perl 5.7.3 or later and empty string on earlier versions of Perl. =back =head2 Error Handling L<"body_encode"> and L<"header_encode"> accept following C options: =over =item C<"DEFAULT"> Put a substitution character in place of a malformed character. For UCM-based encodings, will be used. =item C<"FALLBACK"> Try C<"DEFAULT"> scheme using I (see L<"fallback">). When fallback charset is undefined and conversion causes error, code will die on error with an error message. =item C<"CROAK"> Code will die on error immediately with an error message. Therefore, you should trap the fatal error with eval{} unless you really want to let it die on error. Synonym is C<"STRICT">. =item C<"PERLQQ"> =item C<"HTMLCREF"> =item C<"XMLCREF"> Use C, C or C scheme defined by L module. =item numeric values Numeric values are also allowed. For more details see L. =back If error handling scheme is not specified or unknown scheme is specified, C<"DEFAULT"> will be assumed. =head2 Configuration File Built-in defaults for option parameters can be overridden by configuration file: F. For more details read F. =head1 VERSION Consult $VERSION variable. Development versions of this module may be found at L. =head2 Incompatible Changes =over 4 =item Release 1.001 =over 4 =item * new() method returns an object when CHARSET argument is not specified. =back =item Release 1.005 =over 4 =item * Restrict characters in encoded-word according to RFC 2047 section 5 (3). This also affects return value of encoded_header_len() method. =back =item Release 1.008.2 =over 4 =item * body_encoding() method may also returns C<"S">. =item * Return value of body_encode() method for UTF-8 may include C<"QUOTED-PRINTABLE"> encoding item that in earlier versions was fixed to C<"BASE64">. =back =back =head1 SEE ALSO Multipurpose Internet Mail Extensions (MIME). =head1 AUTHOR Hatuka*nezumi - IKEDA Soji =head1 COPYRIGHT Copyright (C) 2006-2017 Hatuka*nezumi - IKEDA Soji. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; MIME-Charset-1.013.1/lib/POD2/0000755000175100017510000000000014275402653017253 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/lib/POD2/JA/0000755000175100017510000000000014275402653017545 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/lib/POD2/JA/MIME/0000755000175100017510000000000014275402653020274 5ustar hatukanezumihatukanezumiMIME-Charset-1.013.1/lib/POD2/JA/MIME/Charset.pod0000644000175100017510000004333313071562366022400 0ustar hatukanezumihatukanezumi=encoding utf-8 =head1 NAME MIME::Charset~[ja] - MIME のためのキャラクタセット情報 =head1 SYNOPSIS use MIME::Charset: $charset = MIME::Charset->new("euc-jp"); キャラクタセット情報の取得: $benc = $charset->body_encoding; # 例 "Q" $cset = $charset->as_string; # 例 "US-ASCII" $henc = $charset->header_encoding; # 例 "S" $cset = $charset->output_charset; # 例 "ISO-2022-JP" テキストデータの変換: ($text, $charset, $encoding) = $charset->header_encode( "\xc9\xc2\xc5\xaa\xc0\xde\xc3\xef\xc5\xaa". "\xc7\xd1\xca\xaa\xbd\xd0\xce\xcf\xb4\xef", Charset => 'euc-jp'); # ...例えば (<変換ずみ文字列>, "ISO-2022-JP", "B") を返す。 ($text, $charset, $encoding) = $charset->body_encode( "Collectioneur path\xe9tiquement ", Charset => 'latin1'); # ...例えば (<元の文字列>, "ISO-8859-1", "QUOTED-PRINTABLE") を返す。 $len = $charset->encoded_header_len( "Perl\xe8\xa8\x80\xe8\xaa\x9e", Charset => "utf-8", Encoding => "b"); # ...例えば 28 を返す。 モジュール既定値の操作: MIME::Charset::alias("csEUCKR", "euc-kr"); MIME::Charset::default("iso-8859-1"); MIME::Charset::fallback("us-ascii"); 非OO関数 (近い将来に廃止): use MIME::Charset qw(:info); $benc = body_encoding("iso-8859-2"); # "Q" $cset = canonical_charset("ANSI X3.4-1968"); # "US-ASCII" $henc = header_encoding("utf-8"); # "S" $cset = output_charset("shift_jis"); # "ISO-2022-JP" use MIME::Charset qw(:trans); ($text, $charset, $encoding) = header_encode( "\xc9\xc2\xc5\xaa\xc0\xde\xc3\xef\xc5\xaa". "\xc7\xd1\xca\xaa\xbd\xd0\xce\xcf\xb4\xef", "euc-jp"); # ...(<変換されたテキスト>, "ISO-2022-JP", "B") を返す。 ($text, $charset, $encoding) = body_encode( "Collectioneur path\xe9tiquement ". "\xe9clectique de d\xe9chets", "latin1"); # ...(<元のテキスト>, "ISO-8859-1", "QUOTED-PRINTABLE") を返す。 $len = encoded_header_len( "Perl\xe8\xa8\x80\xe8\xaa\x9e", "b", "utf-8"); # 28 =head1 DESCRIPTION MIME::Charset は、インターネット上での MIME メッセージに用いるキャラクタセットの情報を提供する。 =head2 定義 B<キャラクタセット> とは、MIME での ``character set'' のことで、 オクテットの列を文字の列に変換する方法を指す。 これは、ISO/IEC における ``符号化文字集合'' (CCS) と ``文字符号化法'' (CES) の両方の概念を包含する。 B<エンコーディング> とは、MIME でのそれのことで、 メッセージ本体やメッセージヘッダ本体を印字可能な US-ASCII 文字の列として表現する方法を指す。 =cut =head2 コンストラクタ =over =item $charset = MIME::Charset->new([CHARSET [, OPTS]]) キャラクタセットオブジェクトを作成して返す。 OPTS には次の対を指定できる。 B: Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 変換を行わないので、次のオプションは効果を持たない。 =over 4 =item Mapping => MAPTYPE キャラクタセット名に対して実際に使うマッピングの拡張をするかどうか。 C<"EXTENDED"> は拡張マッピングを使う。 C<"STANDARD"> は標準化されている厳密なマッピングを使う。 既定は C<"EXTENDED">。 =back =cut =back =head2 キャラクタセット情報の取得 =over =item $charset->body_encoding =item body_encoding CHARSET CHARSET のメッセージ本体で推奨される伝送エンコーディングを取得する。 返値は C<"B"> (BASE64)、C<"Q"> (QUOTED-PRINTABLE)、C<"S"> (どちらか短いほう)、 C (伝送エンコードしなくてよい --- 7BIT か 8BIT) のいずれか。これはメッセージヘッダのエンコーディングとは違うこともある。 =cut =item $charset->as_string =item canonical_charset CHARSET キャラクタセットの正規の名前を取得する。 =cut =item $charset->decoder キャラクタセットを Unicode に復号するのに使う L<"Encode::Encoding"> オブジェクトを返す。 キャラクタセットが指定されていなかったか、当モジュールの知らないキャラクタセットであった場合は、undef 値を返す。 =cut =item $charset->dup キャラクタセットオブジェクトを複写する。 =cut =item $charset->encoder([CHARSET]) インターネット上の MIME メッセージで使うことを推奨される互換キャラクタセットで符号化するのに使う L<"Encode::Encoding"> オブジェクトを返す。 CHARSET 引数を指定した場合、$charset オブジェクトの符号化器 (および出力キャラクタセット名) を、CHARSET のそれに置き換える。 つまり、$charset オブジェクトは元のキャラクタセットから新たな CHARSET への変換器となる。 =cut =item $charset->header_encoding =item header_encoding CHARSET CHARSET のメッセージヘッダで推奨されるエンコーディング法を取得する。 返値は C<"B">、C<"Q">、C<"S"> (どちらか短くなるほう)、 C (エンコードしなくてよい) のいずれか。これはメッセージ本体のエンコーディングとは違うこともある。 =cut =item $charset->output_charset =item output_charset CHARSET 指定した CHARSET と互換で、インターネット上の MIME メッセージで使うことを推奨されるキャラクタセット名を (当モジュールが知っていれば) 取得する。 Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 この関数は単に L<"canonical_charset"> の結果を返す。 =cut =back =head2 テキストデータの変換 =over =item $charset->body_encode(STRING [, OPTS]) =item body_encode STRING, CHARSET [, OPTS] STRING を (必要なら) 変換したデータと、 メッセージ本体で推奨される伝送エンコーディングを取得する。 CHARSET は STRING を符号化しているキャラクタセット。 OPTS には以下の対を指定できる。 B: Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 変換を行わないので、以下のオプションは効果を持たない。 =over 4 =item Detect7bit => YESNO CHARSET がないとき、7ビットのキャラクタセットを自動認識しようとする。 既定は C<"YES">。 =item Replacement => REPLACEMENT エラー処理法の指定。L<"エラー処理"> 参照。 =back 3要素のリスト (I<変換ずみの文字列>, I<出力のキャラクタセット>, I<伝送エンコーディング>) が返る。 I<伝送エンコーディング> は C<"BASE64">、C<"QUOTED-PRINTABLE">、 C<"7BIT">、C<"8BIT"> のいずれか。I<出力のキャラクタセット> が決定できず、 I<変換ずみの文字列> が ASCII以外のバイトを含むときは、 I<出力のキャラクタセット> は C、I<伝送エンコーディング> は C<"BASE64"> となる。 I<出力のキャラクタセット> が C<"US-ASCII"> となるのは、文字列が ASCII以外のバイトを含まないときに限る。 =cut =item $charset->decode(STRING [,CHECK]) STRING を Unicode 文字列に復号する。 B: Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 この機能を実行すると死ぬ。 =cut =item detect_7bit_charset STRING 文字列 STRING を符号化している7 ビットキャラクタセットを推測する。 STRING が8ビットのバイトを含むときは C を返す。 そうでないとき、キャラクタセットが不明なら初期キャラクタセットを返す。 =cut =item $charset->encode(STRING [, CHECK]) STRING (Unicode 文字列または普通の文字列) を、 元のキャラクタセットと互換でインターネット上の MIME メッセージで使うことを推奨されるキャラクタセットを (当モジュールが知っていれば) 使って、符号化する。 元のキャラクタセットと互換キャラクタセットが同じでも、 文字列を Unicode に復号してから符号化することに注意。 B: Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 この機能を実行すると死ぬ。 =cut =item $charset->encoded_header_len(STRING [, ENCODING]) =item encoded_header_len STRING, ENCODING, CHARSET STRING をメッセージヘッダとしてエンコードしたときの長さ (行折りはしないとして) を取得する。 ENCODING は C<"B">、C<"Q">、C<"S"> (C<"B"> と C<"Q"> のうち短くなるほう) のいずれか。 =cut =item $charset->header_encode(STRING [, OPTS]) =item header_encode STRING, CHARSET [, OPTS] STRING を (必要なら) 変換したデータと、 メッセージヘッダで推奨されるエンコーディング法を取得する。 CHARSET は STRING を符号化しているキャラクタセット。 OPTS には以下の対を指定できる。 B: Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 変換を行わないので、以下のオプションは効果を持たない。 =over 4 =item Detect7bit => YESNO CHARSET がないとき、7ビットのキャラクタセットを自動認識しようとする。 既定は C<"YES">。 =item Replacement => REPLACEMENT エラー処理法の指定。L<"エラー処理"> 参照。 =back 3要素のリスト (I<変換ずみの文字列>, I<出力のキャラクタセット>, I<エンコーディング法>) が返る。 I<エンコーディング法> は C<"B">、C<"Q">、C (エンコードしなくてよい) のいずれか。 I<出力のキャラクタセット> が決定できず、I<変換ずみの文字列> が ASCII以外のバイトを含むときは、I<出力のキャラクタセット> は C<"8BIT"> (これはキャラクタセットの名前ではI<なく>、符号化が不可能なデータを表す特殊値) で I<エンコーディング法> は C (エンコードするべきではない) となる。 I<出力のキャラクタセット> が C<"US-ASCII"> となるのは、文字列が ASCII以外のバイトを含まないときに限る。 =cut =item $charset->undecode(STRING [,CHECK]) Unicode 文字列 string を、 $charset の入力キャラクタセットを使って文字列に変換する。 これは C<$charset-Edecoder-Eencode()> と同等である。 B: Unicode/マルチバイト対応が有効になっていないとき (L<"USE_ENCODE"> 参照) は、 この機能を実行すると死ぬ。 =cut =back =head2 モジュール既定値の操作 =over =item alias ALIAS [, CHARSET] L<"canonical_charset"> で正規名を決定するためのキャラクタセットの別名を取得/設定する。 CHARSET があって偽でないとき、ALIAS が CHARSET の別名に登録される。 さもなければ、別名に変更はない。いずれの場合でも、 現在 ALIAS が登録されているキャラクタセットを返す。 =cut =item default [CHARSET] 既定キャラクタセットを取得/設定する。 B<既定キャラクタセット>とは、 当モジュールで、処理のためのキャラクタセットが不明なときに用いるキャラクタセット。 当モジュールを利用するモジュールでは、 処理のためのキャラクタセットが不明なときや暗黙の既定値が必要なとき、 このキャラクタセットを使うことを推奨する。 これは既定では C<"US-ASCII">。 CHARSET があって偽でなければ、それを既定キャラクタセットに設定する。 さもなければ、既定キャラクタセットは変わらない。いずれの場合でも、 現在の既定キャラクタセットを返す。 B: 既定キャラクタセットは変更するI<べきではない>。 =cut =item fallback [CHARSET] 予備キャラクタセットを取得/設定する。 B<予備キャラクタセット>とは、 当モジュールで、指定されたキャラクタセットでの変換が失敗し、 エラー処理法に C<"FALLBACK"> が指定されていたときに用いるキャラクタセット。 当モジュールを利用するモジュールでは、 キャラクタセット変換が失敗するときに最終手段としてこのキャラクタセットを使ってもよい。 これは既定では C<"UTF-8">。 CHARSET があって偽でなければ、それを予備キャラクタセットに設定する。 CHARSET が C<"NONE"> であれば、予備キャラクタセットを未定にする。 さもなければ、予備キャラクタセットは変わらない。いずれの場合でも、 現在の予備キャラクタセットを返す。 B: 予備キャラクタセットに C<"US-ASCII"> を指定する価値はI<ある>。 変換の結果は、キャラクタセット情報がないときも可読となる。 =cut =item recommended CHARSET [, HEADERENC, BODYENC [, ENCCHARSET]] キャラクタセットの特性を取得/設定する。 必須でない引数があってそのどれかが偽でなければ、 その引数で CHARSET の特性を設定する。さもなければ、特性は変わらない。 いずれの場合でも、CHARSET の現在の特性を 3 要素のリスト (HEADERENC, BODYENC, ENCCHARSET) として返す。 HEADERENC はメッセージヘッダで推奨されるエンコーディング法。 C<"B">、C<"Q">、C<"S"> (どちらか短くなるほう)、 C (エンコードしなくてよい) を指定できる。 BODYENC はメッセージ本体で推奨される伝送エンコーディング。 C<"B">、C<"Q">、C<"S"> (どちらか短くなるほう)、C (伝送エンコードしなくてよい) を指定できる。 ENCCHARSET は、指定した CHARSET と互換で、インターネット上の MIME メッセージで使うことを推奨されるキャラクタセット名。 変換が必要ない (または当モジュールが適当なキャラクタセットを知らない) ときは、 ENCCHARSET は C。 B: この関数の今後の版では、ほかにも必須でない引数をとれるようになるかもしれない (たとえば、文字幅、行分割の挙動などについての属性)。 そのため、返値の形式も変わるかもしれない。個々の特性を取得するには L<"header_encoding">、L<"body_encoding">、L<"output_charset"> を使ってほしい。 =cut =back =head2 定数 =over =item USE_ENCODE Unicode/マルチバイト対応フラグ。 Unicode とマルチバイトへの対応が有効になっているときは、空でない文字列が設定されている。 現在、このフラグは Perl 5.7.3 以降で空でなく、それより以前の Perl では空の文字列。 =back =head2 エラー処理 L<"body_encode"> と L<"header_encode"> の C オプションには以下のものを指定できる: =over =item C<"DEFAULT"> 不正な文字を置き換え文字で置き換える。 UCM に基づく符号化器を持つキャラクタセットでは を使うことがある。 =item C<"FALLBACK"> I<予備キャラクタセット> を使って C<"DEFAULT"> 方式をやってみる (L<"fallback"> 参照)。 予備キャラクタセットが未定で変換がエラーを起こしたときは、 コードはエラーメッセージを出力して死ぬ。 =item C<"CROAK"> コードはエラーメッセージを出力してすぐ死ぬ。 したがって、本当にエラーで死なせたくなければ eval{} で致命的エラーを受け止めなければいけない。 C<"STRICT"> でも同じ。 =item C<"PERLQQ"> =item C<"HTMLCREF"> =item C<"XMLCREF"> L モジュールで定義している C、C、C の方式を使う。 =item 数値 数値を指定することもできる。 詳細は L を見てほしい。 =back エラー処理法が指定されないか、上記以外のエラー処理法が指定されたときは、 C<"DEFAULT"> とみなす。 =head2 設定ファイル オプションのパラメタの組み込み既定値は、設定ファイル F で変更することができる。 詳しくは F を読んでほしい。 =head1 VERSION $VERSION 変数を見てほしい。 このモジュールの開発版が L にある。 =head2 非互換な変更 =over 4 =item 1.001 =over 4 =item * new() メソッドは CHARSET 引数を指定しなくてもオブジェクトを返すようになった。 =back =item 1.005 =over 4 =item * encoded-word に含まれる文字種を RFC 2047 の 5 (3) 節のとおりにした。 encoded_header_len() メソッドの返値も変わる。 =back =item 1.008.2 =over 4 =item * body_encoding() メソッドも C<"S"> を返せるようになった。 =item * body_encode() メソッドの UTF-8 に対する返値のエンコーディング要素は、 これまでのリリースでは C<"BASE64"> に固定だったが、C<"QUOTED-PRINTABLE"> になることがある。 =back =back =head1 SEE ALSO Multipurpose Internet Mail Extensions (MIME). =head1 AUTHOR Hatuka*nezumi - IKEDA Soji =head1 COPYRIGHT Copyright (C) 2006-2017 Hatuka*nezumi - IKEDA Soji. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MIME-Charset-1.013.1/MANIFEST0000644000175100017510000000121613071307715017126 0ustar hatukanezumihatukanezumiARTISTIC Changes COPYING inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/MIME/Charset.pm lib/MIME/Charset/_Compat.pm lib/MIME/Charset/Defaults.pm.sample lib/MIME/Charset/UTF.pm lib/POD2/JA/MIME/Charset.pod Makefile.PL MANIFEST This list of files META.json README t/01encode.t t/01ooencode.t t/02enclen.t t/02ooenclen.t t/03info.t t/03ooinfo.t t/04alias.t t/05jp.t t/06utf.t t/pod.t MIME-Charset-1.013.1/README0000644000175100017510000000106313071562320016650 0ustar hatukanezumihatukanezumiMIME-Charset Package. Copyright (C) 2006-2017 by Hatuka*nezumi - IKEDA Soji . This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. *** One main module and some supporting program files are contained. For more details read following POD documentation: MIME::Charset - Charset Information for MIME For japonophones, POD in Japanese language is also included: POD2::JA::MIME::Charset - MIME のためのキャラクタセット情報 $$ MIME-Charset-1.013.1/Makefile.PL0000644000175100017510000000206614274110527017752 0ustar hatukanezumihatukanezumi#-*- perl -*- use lib '.'; use inc::Module::Install; # Define metadata all_from 'lib/MIME/Charset.pm'; license 'perl'; check_nmake; # Specific dependencies configure_requires 'CPAN' => 0; # for inc::Module::AutoInstall test_requires 'Test::More' => '0'; if ( $] >= 5.007003 ) { requires 'Encode' => '1.98'; include 'Module::AutoInstall'; feature 'Extended mappings by Japanese codepages', -default => 0, 'Encode::EUCJPASCII' => '0.02'; feature 'Additional mappings for JIS X 0213', -default => 0, 'Encode::JISX0213' => '0.03'; feature 'Additional mappings for Chinese standards', -default => 0, 'Encode::HanExtra' => '0.20'; feature 'Additional mappings for rarely used old standards', -default => 0, 'Encode::DIN66003' => '0.01'; feature 'Support for POD2 - translations of Perl documentation', -default => 0, 'POD2::Base' => '0.041'; } # Write out no_index directory => 't', 'inc'; auto_install force => 0, do_once => 1; WriteAll; MIME-Charset-1.013.1/Changes0000644000175100017510000002244114275402541017273 0ustar hatukanezumihatukanezumiRevision history for Perl module MIME::Charset. 1.013.1 2022-08-12 Hatuka*nezumi - IKEDA Soji * No new features. * Update META.json. 1.013 2022-08-09 Hatuka*nezumi - IKEDA Soji * Update tests. * A typo in comment: "3.18" should be "3.19". * Fix: Escape sequences won't be used with DIN 66003. 1.013_01 2022-08-08 Hatuka*nezumi - IKEDA Soji * Imp: Added support for DIN 66003. * Chg: Workaround: "ISO-8859-8-I" is treated as an alias of "ISO-8859-8" by Encode (3.18): See the note in https://encoding.spec.whatwg.org/#legacy-single-byte-encodings However we'll treat these as separate names for compatibility. 1.012.2 2017-04-11 Hatuka*nezumi - IKEDA Soji * Fix: Perl >= 5.26: Makefile.PL cannot use inc::Module::Install. 1.012.1 2017-04-07 Hatuka*nezumi - IKEDA Soji * Fix: CPAN RT #116459: Remove "." from @INC when loading modules. A workaround for CVE-2016-1238. 1.012 2015-03-28 Hatuka*nezumi - IKEDA Soji * CPAN RT #100839: Malformed JSON in META.json. 1.011.3 2014-12-10 Hatuka*nezumi - IKEDA Soji * Use "eval 'require ...'" to import optional encoding modules. Overridden $SIG{__DIE__} can pass "eval 'use ...'". * Replace META.yml with META.json. 1.011.2 2014-11-27 Hatuka*nezumi - IKEDA Soji * Added module CPAN to configure_require for inc::Test::AutoInstall. * Added POD2::Base to recommended feature. * Fix: wrong prototype for _resolve_S(). * Move repository to github. 1.011.1 2013-10-07 Hatuka*nezumi - IKEDA Soji * Fix: "shift_jis-2004" did not depend on Encode::JISX0213 but Encode::ShiftJIS2004. * Chg: Added gb18030 to extended mapping of GB2312. * Updated inc::Module::Install to version 1.01. 1.011.0 2013-09-26 Hatuka*nezumi - IKEDA Soji * Use Encode::JISX0213 instead of Encode::JIS2K which was not fully implemented. * Added support for iso-2022-jp-2 and JIS X 0213 encodings. * Reformat Changes file to suit to CPAN::Changes::Spec. 1.010.1 2013-08-25 Hatuka*nezumi - IKEDA Soji * No new features. * CPAN RT #86917: Invalid META. * Move Japanese documentation under POD2::JA. 1.010 2013-04-09 Hatuka*nezumi - IKEDA Soji * Fix: UTF-16 & UTF-32 encoders are died by the texts without BOM. * Added a test #6 and some cases to test #4. * Changed layout of distribution. 1.009.3 2012-12-30 Hatuka*nezumi - IKEDA Soji * No new features. * CPAN RT #77715: Spelling mistake in documentation. * Bug on CPAN site: cannot render PODs including "=item" with non-ASCII. 1.009.2 2012-06-02 Hatuka*nezumi - IKEDA Soji * Fix: detect_7bit_charset(): if charset was unknown, returns undef instead of "US-ASCII". * COPYING: Updated the address of FSF. 1.009.1 2011-06-09 Hatuka*nezumi - IKEDA Soji * Chg: Workaround for aliasing on TIS-620 that is treated as ISO-8859-11 by Encode. And added WINDOWS-874 as EXTENDED map of TIS-620. * Imp: Result of _find_encoder() will be cached. * Imp/Chg: 'S' encoding will be resolved numerically, without comparing actually encoded lengths. * Added informations for WINDOWS-125[03-8]. * Added some cases to test #4. 1.009 2011-06-08 Hatuka*nezumi - IKEDA Soji * withdrawn. 1.008.2 2011-05-28 Hatuka*nezumi - IKEDA Soji * Bug Fix: Body transfer-encoding profile "S" did not work properly, and profile for UTF-8 was NOT really updated. 1.008.1 2011-02-19 Hatuka*nezumi - IKEDA Soji * Chg: Workaround for CPAN RT #65796: Deep recursion error finding invalid charset. Limit length of charset name upto 75. * Imp: Supports Unicode/multibyte on Perl 5.7.3 (experimental). * Perl 5.7.3 & 5.8.3: avoid ``Useless use of a constant in void context'' warnings. * Doc: small fixes. 1.008 2009-10-19 Hatuka*nezumi - IKEDA Soji * Imp: support for iso-8859-6-[ei], iso-8859-8-[ei]. cf. report by Hanne Moa on Sympa bug #6385 at . * Imp: support for iso-8859-16. * Imp: Allow body transfer-encoding profile "S". * Chg: Default body transfer-encoding for UTF-8 from "B" to "S". * Doc: Some fixes. New section "Incompatible changes". * Fix: META.yml: optional_features is not hashref but arrayref. Thanks SREZIC@CPAN. 1.007.1 2009-06-16 Hatuka*nezumi - IKEDA Soji * Changes: - eucJP-ascii and its 7-bit counterpart was chosen instead of eucJP-ms, as latter will occasionally break standardized mappings. Shift-encoding counterpart hasn't been implemented yet. * Fix: Skip all pod tests on pre-UTF8 Perl. 1.007 2009-05-17 Hatuka*nezumi - IKEDA Soji * not really released. 1.007_02 2009-05-12 Hatuka*nezumi - IKEDA Soji * Charset/CP932.pm: Supports extended mappings for ISO-2022-JP/EUC-JP by those of eucJP-ms, as CP51932 mungles accented latin characters and ISO-2022-JP-1 does not support NEC/IBM extended mappings. 1.007_01 2009-05-11 Hatuka*nezumi - IKEDA Soji * Supports Perl 5.8.0. * New function: detect_7bit_charset(). * Bundle inc::Module::Install. * Corrected META.yml & PODs. Removed duplicated docs. 1.006.2 2008-04-17 Hatuka*nezumi - IKEDA Soji * bug fixes only; no new features. * Bug Fix: Perl >= 5.8.1: CPAN RT #34909: Test failures. * Bug Fix: Perl >= 5.10.0: CPAN RT #35070: HZ words are encoded as US-ASCII; added workaround for CPAN RT #35120. * Fix: Perl 5.11.0: Suppress ``Use of uninitialized value within @_ in uc'' warnings. * JA_JP.pod: Clarify distinction between ``符号化'' (on charset) and ``エンコード'' (on encoding). 1.006 2008-04-12 Hatuka*nezumi - IKEDA Soji * Workarounds for ``US-ASCII transformation'' charsets i.e. HZ-GB-2312 (RFC1842) and UTF-7 (RFC 2152). * Added tests. 1.005 2008-04-07 Hatuka*nezumi - IKEDA Soji * _enclen_Q(): Restrict characters in encoded-word according to RFC 2047 section 5 (3). * New method dup(). * body_encode() / header_encode(): Fix determination of US-ASCII: Works on pre-Encode environments. 1.004 2008-03-30 Hatuka*nezumi - IKEDA Soji * Added ESTI GSM 03.38 which won't be used for MIME messages (experimental). * _Compat.pm: resolve_alias(): real aliasing taken from Encode module. * Numeric values are allowed for ``Replacement'' options. * Added tests for aliases (some MIME preferred names only). * Bug Fix: Perl <=5.005: our is ``withdrawn''. 1.002 2008-03-20 Hatuka*nezumi - IKEDA Soji * New method undecode(). * encoder(): added argument to set instance. * Cleanup PODs. 1.001 2008-03-15 Hatuka*nezumi - IKEDA Soji * Bug fix: Detect7bit options have no effect by OO method (1.000). * Change: now new() returns an object when CHARSET is not specified. * New methods: as_string(), decode(), decoder(), encode() and encoder(). * New feature: "Mapping" option to choose extended mappings or strict ones. Default is "EXTENDED", while as of 1.000, only "STANDARD" mappings are available. * New feature: configuration file to override module defaults. See "Configuration File" section. 1.000 2008-03-04 Hatuka*nezumi - IKEDA Soji * Added OOP methods (non-OOP functions may be deprecated in near future). 0.044 2006-12-08 Hatuka*nezumi - IKEDA Soji * Fix on 'UTF-8-STRICT', new canonical name of 'UTF-8' by Encode module (approximately 2.14). 0.043 2006-11-16 Hatuka*nezumi - IKEDA Soji * No changes on codes. * Change of Charset-ja_JP.pod (former Charset/ja_JP.pod). * Charset.pm: Added information of development version. 0.042 2006-10-22 Hatuka*nezumi - IKEDA Soji * Added ja_JP pod. 0.04.1 2006-10-17 Hatuka*nezumi - IKEDA Soji * Bug fix: Handle wide characters exactly. 0.04 2006-10-13 Hatuka*nezumi - IKEDA Soji * Supports Perl 5.005 or later. Unicode/multibyte handling will be enabled on Perl 5.8.1 or later. USE_ENCODE flag was introduced. * decode_mimewords(): Added 'Charset' option. 0.03 2006-10-09 Hatuka*nezumi - IKEDA Soji * New function: encoded_header_len. * body_encode()/header_encode(): fallback to US-ASCII if possible. * Documentation: definitions of ``charset'' & ``encoding''. * Typos on Encode::FB_*. * More test cases. 0.02 2006-10-07 Hatuka*nezumi - IKEDA Soji * Fix exports. * Typo on GPL version. * Added synopsis. * Other typos. 0.01 2006-10-06 Hatuka*nezumi - IKEDA Soji * Initial CPAN upload. MIME-Charset-1.013.1/ARTISTIC0000644000175100017510000001446313071307715017152 0ustar hatukanezumihatukanezumiThe "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a. place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b. use the modified Package only within your corporation or organization. c. rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d. make other distribution arrangements with the Copyright Holder. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a. distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b. accompany the distribution with the machine-readable source of the Package with your modifications. c. give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d. make other distribution arrangements with the Copyright Holder. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End MIME-Charset-1.013.1/META.json0000644000175100017510000000505514275402363017425 0ustar hatukanezumihatukanezumi{ "abstract" : "Charset Information for MIME", "author" : [ "Hatuka*nezumi - IKEDA Soji " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.120630", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "MIME-Charset", "no_index" : { "directory" : [ "t", "inc" ] }, "optional_features" : { "ja_extended" : { "description" : "Extended mappings by Japanese codepages", "prereqs" : { "runtime" : { "requires" : { "Encode::EUCJPASCII" : "0.02" } } } }, "jis2000" : { "description" : "Additional mappings for JIS X 0213", "prereqs" : { "runtime" : { "requires" : { "Encode::JISX0213" : "0.03" } } } }, "zh_extra" : { "description" : "Additional mappings for Chinese standards", "prereqs" : { "runtime" : { "requires" : { "Encode::HanExtra" : "0.20" } } } }, "misc" : { "description" : "Additional mappings for rarely used old standards", "prereqs" : { "runtime" : { "requires" : { "Encode::DIN66003" : "0" } } } }, "pod2" : { "description" : "Support for POD2 - translations of Perl documentation", "prereqs" : { "runtime" : { "requires" : { "POD2::Base" : "0.041" } } } } }, "prereqs" : { "build" : { "requires" : { "CPAN" : "0", "ExtUtils::MakeMaker" : "6.42", "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Encode" : "1.98", "perl" : "5.005" } } }, "provides" : { "MIME::Charset" : { "file" : "lib/MIME/Charset.pm", "version" : "1.013.1" } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/hatukanezumi/MIME-Charset.git" } }, "version" : "1.013.1" }