dbscripts/lib/codec.pl

   1 #!/usr/bin/perl
   2
   3 ################################################################
   4 ###     codec
   5 ###
   6 ### $VER: 2.1 (8bit,quoted-printable,perlish)$
   7 ### USAGE: $codec=&Codec::new('perlish');
   8 ###              $encoded=$codec->encode($clear);
   9 ###              $clear=$codec->decode($encoded);
  10
  11 package Codec;
  12
  13
  14 $VERSION="1.1";
  15
  16 sub new {
  17         my($type)=shift;
  18         my($res);
  19
  20         return undef unless (defined $encode{$type});
  21
  22         $$res{'encode'}=$encode{$type};
  23         $$res{'decode'}=$decode{$type};
  24         $$res{'type'}=$type;
  25
  26         bless $res, "Codec";
  27
  28         return $res;
  29         }
  30
  31 sub reset {
  32         }
  33
  34 sub encode {
  35         my($obj,$str)=@_;
  36         return &{$$obj{'encode'}}($str);
  37         }
  38
  39 sub decode {
  40         my($obj,$str)=@_;
  41         return &{$$obj{'decode'}}($str);
  42         }
  43
  44 sub name {
  45         my($obj)=shift;
  46         return $$obj{'type'};
  47         }
  48
  49 ################################################################
  50 ###     local
  51
  52 $crlf=pack("CC",13,10);
  53
  54 ################################################################
  55 ###     id
  56
  57 $encode{'8bit'}=sub { return $_[0]; };
  58 $decode{'8bit'}=sub { return $_[0]; };
  59
  60 ################################################################
  61 ###     perlish
  62
  63 sub quote_perlish {
  64         my($str)=@_;
  65
  66         $str=~s/\\/\\\\/g;
  67
  68         $str=~s/\"/\\042/g;
  69         $str=~s/\'/\\047/g;
  70
  71         $str=~s/\@/\\@/g;
  72         $str=~s/([\x80-\xFF])/sprintf("\\x%02x",ord($1))/eg;
  73         $str=~s/([\x00-\x20])/sprintf("\\x%02x",ord($1))/eg;
  74         return $str;
  75         }
  76
  77 sub convert_perlish {
  78         my($item)=shift;
  79         my($type,$key,$value,@res,$entry);
  80
  81         $type=ref($item);
  82
  83         if ((!defined $type)||($type eq "")) {
  84                 return "\042".&quote_perlish($item)."\042";
  85                 }
  86         else {
  87                 if ($type eq "HASH") {
  88                         while (($key,$value)=each %$item) {
  89                                 $entry="\042".&quote_perlish($key)."\042";
  90                                 $entry.="=>";
  91                                 $entry.=&convert_perlish($value);
  92                                 push(@res,$entry);
  93                                 }
  94                         return "{".join(",",@res)."}";
  95                         }
  96                 if ($type eq "ARRAY") {
  97                         foreach $value (@$item) {
  98                                 push(@res,&convert_perlish($value));
  99                                 }
 100                         return "[".join(",",@res)."]";
 101                         }
 102                 if ($type eq "SCALAR") {
 103                         return "\042".&quote_perlish($item)."\042";
 104                         }
 105                 return "";
 106                 }
 107         };
 108
 109 $encode{'perlish'}=\&convert_perlish;
 110
 111 $decode{'perlish'}=sub {
 112         my($str)=shift;
 113         my($res);
 114
 115         return eval($str);
 116         };
 117
 118 ################################################################
 119 ###     quoted-printable
 120
 121 $encode{'quoted-printable'}=sub {
 122         my($str)=shift;
 123         my(@lines,$item);
 124
 125
 126         $str=~s/=/=3D/g;
 127         $str=~s/([\x00-\x1F\x80-\xFF])/sprintf("=%02X",ord($1))/eg;
 128
 129         if (length($str)>75) {
 130                 while (length($str)>75) {
 131                         if (substr($str,73,1) eq "=") {
 132                                 push(@lines,substr($str,0,73)."=");     ### soft break
 133                                 $str=substr($str,73);
 134                                 }
 135                         elsif (substr($str,74,1) eq "=") {
 136                                 push(@lines,substr($str,0,74)."=");     ### soft break
 137                                 $str=substr($str,74);
 138                                 }
 139                         else {
 140                                 push(@lines,substr($str,0,75)."=");     ### soft break
 141                                 $str=substr($str,75);
 142                                 }
 143                         }
 144                 push(@lines,$str);
 145                 $str=join($HTTP::crlf,@lines);
 146                 }
 147
 148         return $str;
 149         };
 150
 151 $decode{'quoted-printable'}=sub {
 152         $_[0]=~s/=([0-9a-fA-F][0-9a-fA-F])/pack("C", hex($1))/eg;
 153         $_[0]=~s/=$crlf//g;
 154         return $_[0];
 155         };
 156 1;