summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Encode/MIME
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Encode/MIME')
-rw-r--r--Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm230
-rw-r--r--Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm127
2 files changed, 0 insertions, 357 deletions
diff --git a/Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm b/Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm
deleted file mode 100644
index f4e2ad6e2b5..00000000000
--- a/Master/tlpkg/tlperl/lib/Encode/MIME/Header.pm
+++ /dev/null
@@ -1,230 +0,0 @@
-package Encode::MIME::Header;
-use strict;
-# use warnings;
-our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-use Encode qw(find_encoding encode_utf8 decode_utf8);
-use MIME::Base64;
-use Carp;
-
-my %seed =
- (
- decode_b => '1', # decodes 'B' encoding ?
- decode_q => '1', # decodes 'Q' encoding ?
- encode => 'B', # encode with 'B' or 'Q' ?
- bpl => 75, # bytes per line
- );
-
-$Encode::Encoding{'MIME-Header'} =
- bless {
- %seed,
- Name => 'MIME-Header',
- } => __PACKAGE__;
-
-$Encode::Encoding{'MIME-B'} =
- bless {
- %seed,
- decode_q => 0,
- Name => 'MIME-B',
- } => __PACKAGE__;
-
-$Encode::Encoding{'MIME-Q'} =
- bless {
- %seed,
- decode_q => 1,
- encode => 'Q',
- Name => 'MIME-Q',
- } => __PACKAGE__;
-
-use base qw(Encode::Encoding);
-
-sub needs_lines { 1 }
-sub perlio_ok{ 0 };
-
-sub decode($$;$){
- use utf8;
- my ($obj, $str, $chk) = @_;
- # zap spaces between encoded words
- $str =~ s/\?=\s+=\?/\?==\?/gos;
- # multi-line header to single line
- $str =~ s/(:?\r|\n|\r\n)[ \t]//gos;
- $str =~
- s{
- =\? # begin encoded word
- ([0-9A-Za-z\-_]+) # charset (encoding)
- \?([QqBb])\? # delimiter
- (.*?) # Base64-encodede contents
- \?= # end encoded word
- }{
- if (uc($2) eq 'B'){
- $obj->{decode_b} or croak qq(MIME "B" unsupported);
- decode_b($1, $3);
- }elsif(uc($2) eq 'Q'){
- $obj->{decode_q} or croak qq(MIME "Q" unsupported);
- decode_q($1, $3);
- }else{
- croak qq(MIME "$2" encoding is nonexistent!);
- }
- }egox;
- $_[1] = '' if $chk;
- return $str;
-}
-
-sub decode_b{
- my $enc = shift;
- my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
- my $db64 = decode_base64(shift);
- return $d->name eq 'utf8' ?
- Encode::decode_utf8($db64) : $d->decode($db64, Encode::FB_PERLQQ);
-}
-
-sub decode_q{
- my ($enc, $q) = @_;
- my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
- $q =~ s/_/ /go;
- $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego;
- return $d->name eq 'utf8' ?
- Encode::decode_utf8($q) : $d->decode($q, Encode::FB_PERLQQ);
-}
-
-my $especials =
- join('|' =>
- map {quotemeta(chr($_))}
- unpack("C*", qq{()<>@,;:\"\'/[]?.=}));
-
-my $re_encoded_word =
- qr{
- (?:
- =\? # begin encoded word
- (?:[0-9A-Za-z\-_]+) # charset (encoding)
- \?(?:[QqBb])\? # delimiter
- (?:.*?) # Base64-encodede contents
- \?= # end encoded word
- )
- }xo;
-
-my $re_especials = qr{$re_encoded_word|$especials}xo;
-
-sub encode($$;$){
- my ($obj, $str, $chk) = @_;
- my @line = ();
- for my $line (split /\r|\n|\r\n/o, $str){
- my (@word, @subline);
- for my $word (split /($re_especials)/o, $line){
- if ($word =~ /[^\x00-\x7f]/o or $word =~ /^$re_encoded_word$/o){
- push @word, $obj->_encode($word);
- }else{
- push @word, $word;
- }
- }
- my $subline = '';
- for my $word (@word){
- use bytes ();
- if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){
- push @subline, $subline;
- $subline = '';
- }
- $subline .= $word;
- }
- $subline and push @subline, $subline;
- push @line, join("\n " => @subline);
- }
- $_[1] = '' if $chk;
- return join("\n", @line);
-}
-
-use constant HEAD => '=?UTF-8?';
-use constant TAIL => '?=';
-use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, };
-
-sub _encode{
- my ($o, $str) = @_;
- my $enc = $o->{encode};
- my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL));
- # to coerce a floating-point arithmetics, the following contains
- # .0 in numbers -- dankogai
- $llen *= $enc eq 'B' ? 3.0/4.0 : 1.0/3.0;
- my @result = ();
- my $chunk = '';
- while(length(my $chr = substr($str, 0, 1, ''))){
- use bytes ();
- if (bytes::length($chunk) + bytes::length($chr) > $llen){
- push @result, SINGLE->{$enc}($chunk);
- $chunk = '';
- }
- $chunk .= $chr;
- }
- $chunk and push @result, SINGLE->{$enc}($chunk);
- return @result;
-}
-
-sub _encode_b{
- HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL;
-}
-
-sub _encode_q{
- my $chunk = shift;
- $chunk =~ s{
- ([^0-9A-Za-z])
- }{
- join("" => map {sprintf "=%02X", $_} unpack("C*", $1))
- }egox;
- return decode_utf8(HEAD . 'Q?' . $chunk . TAIL);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-Encode::MIME::Header -- MIME 'B' and 'Q' header encoding
-
-=head1 SYNOPSIS
-
- use Encode qw/encode decode/;
- $utf8 = decode('MIME-Header', $header);
- $header = encode('MIME-Header', $utf8);
-
-=head1 ABSTRACT
-
-This module implements RFC 2047 Mime Header Encoding. There are 3
-variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The
-difference is described below
-
- decode() encode()
- ----------------------------------------------
- MIME-Header Both B and Q =?UTF-8?B?....?=
- MIME-B B only; Q croaks =?UTF-8?B?....?=
- MIME-Q Q only; B croaks =?UTF-8?Q?....?=
-
-=head1 DESCRIPTION
-
-When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD>
-is extracted and decoded for I<X> encoding (B for Base64, Q for
-Quoted-Printable). Then the decoded chunk is fed to
-decode(I<encoding>). So long as I<encoding> is supported by Encode,
-any source encoding is fine.
-
-When you encode, it just encodes UTF-8 string with I<X> encoding then
-quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to
-encode are left as is and long lines are folded within 76 bytes per
-line.
-
-=head1 BUGS
-
-It would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP?
-and =?ISO-8859-1?= but that makes the implementation too complicated.
-These days major mail agents all support =?UTF-8? so I think it is
-just good enough.
-
-Due to popular demand, 'MIME-Header-ISO_2022_JP' was introduced by
-Makamaka. Thre are still too many MUAs especially cellular phone
-handsets which does not grok UTF-8.
-
-=head1 SEE ALSO
-
-L<Encode>
-
-RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other
-locations.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm b/Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm
deleted file mode 100644
index 5f637a32472..00000000000
--- a/Master/tlpkg/tlperl/lib/Encode/MIME/Header/ISO_2022_JP.pm
+++ /dev/null
@@ -1,127 +0,0 @@
-package Encode::MIME::Header::ISO_2022_JP;
-
-use strict;
-use base qw(Encode::MIME::Header);
-
-$Encode::Encoding{'MIME-Header-ISO_2022_JP'}
- = bless {encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP'}
- => __PACKAGE__;
-
-use constant HEAD => '=?ISO-2022-JP?B?';
-use constant TAIL => '?=';
-
-use Encode::CJKConstants qw(%RE);
-
-our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
-
-
-# I owe the below codes totally to
-# Jcode by Dan Kogai & http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64
-
-sub encode {
- my $self = shift;
- my $str = shift;
-
- utf8::encode($str) if( Encode::is_utf8($str) );
- Encode::from_to($str, 'utf8', 'euc-jp');
-
- my($trailing_crlf) = ($str =~ /(\n|\r|\x0d\x0a)$/o);
-
- $str = _mime_unstructured_header($str, $self->{bpl});
-
- not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o;
-
- return $str;
-}
-
-
-sub _mime_unstructured_header {
- my ($oldheader, $bpl) = @_;
- my $crlf = $oldheader =~ /\n$/;
- my($header, @words, @wordstmp, $i) = ('');
-
- $oldheader =~ s/\s+$//;
-
- @wordstmp = split /\s+/, $oldheader;
-
- for ($i = 0; $i < $#wordstmp; $i++){
- if( $wordstmp[$i] !~ /^[\x21-\x7E]+$/ and $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/){
- $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]";
- }
- else{
- push(@words, $wordstmp[$i]);
- }
- }
-
- push(@words, $wordstmp[-1]);
-
- for my $word (@words){
- if ($word =~ /^[\x21-\x7E]+$/) {
- $header =~ /(?:.*\n)*(.*)/;
- if (length($1) + length($word) > $bpl) {
- $header .= "\n $word";
- }
- else{
- $header .= $word;
- }
- }
- else{
- $header = _add_encoded_word($word, $header, $bpl);
- }
-
- $header =~ /(?:.*\n)*(.*)/;
-
- if(length($1) == $bpl){
- $header .= "\n ";
- }
- else {
- $header .= ' ';
- }
- }
-
- $header =~ s/\n? $//mg;
-
- $crlf ? "$header\n" : $header;
-}
-
-
-sub _add_encoded_word {
- my($str, $line, $bpl) = @_;
- my $result = '';
-
- while( length($str) ){
- my $target = $str;
- $str = '';
-
- if(length($line) + 22 + ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl){
- $line =~ s/[ \t\n\r]*$/\n/;
- $result .= $line;
- $line = ' ';
- }
-
- while(1){
- my $iso_2022_jp = $target;
- Encode::from_to($iso_2022_jp, 'euc-jp', 'iso-2022-jp');
-
- my $encoded
- = HEAD . MIME::Base64::encode_base64($iso_2022_jp, '') . TAIL;
-
- if(length($encoded) + length($line) > $bpl){
- $target =~ s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o;
- $str = $1 . $str;
- }
- else{
- $line .= $encoded;
- last;
- }
- }
-
- }
-
- $result . $line;
-}
-
-
-1;
-__END__
-