home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / _encode.pm < prev    next >
Encoding:
Perl POD Document  |  2003-10-08  |  9.1 KB  |  399 lines
  1. # Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4.  
  5. package Convert::ASN1;
  6.  
  7. # $Id: _encode.pm,v 1.19 2003/10/08 12:28:09 gbarr Exp $
  8.  
  9. BEGIN {
  10.   unless (CHECK_UTF8) {
  11.     local $SIG{__DIE__};
  12.     eval { require bytes } and 'bytes'->import
  13.   }
  14. }
  15.  
  16. # These are the subs which do the encoding, they are called with
  17. # 0      1    2       3     4     5
  18. # $opt, $op, $stash, $var, $buf, $loop
  19. # The order in the array must match the op definitions above
  20.  
  21. my @encode = (
  22.   sub { die "internal error\n" },
  23.   \&_enc_boolean,
  24.   \&_enc_integer,
  25.   \&_enc_bitstring,
  26.   \&_enc_string,
  27.   \&_enc_null,
  28.   \&_enc_object_id,
  29.   \&_enc_real,
  30.   \&_enc_sequence,
  31.   \&_enc_sequence, # SET is the same encoding as sequence
  32.   \&_enc_time,
  33.   \&_enc_time,
  34.   \&_enc_utf8,
  35.   \&_enc_any,
  36.   \&_enc_choice,
  37.   \&_enc_object_id,
  38. );
  39.  
  40.  
  41. sub _encode {
  42.   my ($optn, $ops, $stash, $path) = @_;
  43.   my $var;
  44.  
  45.   foreach my $op (@{$ops}) {
  46.     if (defined(my $opt = $op->[cOPT])) {
  47.       next unless defined $stash->{$opt};
  48.     }
  49.     if (defined($var = $op->[cVAR])) {
  50.       push @$path, $var;
  51.       require Carp, Carp::croak(join(".", @$path)," is undefined")  unless defined $stash->{$var};
  52.     }
  53.     $_[4] .= $op->[cTAG];
  54.  
  55.     &{$encode[$op->[cTYPE]]}(
  56.       $optn,
  57.       $op,
  58.       (UNIVERSAL::isa($stash, 'HASH')
  59.     ? ($stash, defined($var) ? $stash->{$var} : undef)
  60.     : ({}, $stash)),
  61.       $_[4],
  62.       $op->[cLOOP],
  63.       $path,
  64.     );
  65.  
  66.     pop @$path if defined $var;
  67.   }
  68.  
  69.   $_[4];
  70. }
  71.  
  72.  
  73. sub _enc_boolean {
  74. # 0      1    2       3     4     5      6
  75. # $optn, $op, $stash, $var, $buf, $loop, $path
  76.  
  77.   $_[4] .= pack("CC",1, $_[3] ? 0xff : 0);
  78. }
  79.  
  80.  
  81. sub _enc_integer {
  82. # 0      1    2       3     4     5      6
  83. # $optn, $op, $stash, $var, $buf, $loop, $path
  84.   if (abs($_[3]) >= 2**31) {
  85.     my $os = i2osp($_[3], ref($_[3]) || $_[0]->{encode_bigint} || 'Math::BigInt');
  86.     my $len = length $os;
  87.     my $msb = (vec($os, 0, 8) & 0x80) ? 0 : 255;
  88.     $len++, $os = chr($msb) . $os if $msb xor $_[3] > 0;
  89.     $_[4] .= asn_encode_length($len);
  90.     $_[4] .= $os;
  91.   }
  92.   else {
  93.     my $val = int($_[3]);
  94.     my $neg = ($val < 0);
  95.     my $len = num_length($neg ? ~$val : $val);
  96.     my $msb = $val & (0x80 << (($len - 1) * 8));
  97.  
  98.     $len++ if $neg ? !$msb : $msb;
  99.  
  100.     $_[4] .= asn_encode_length($len);
  101.     $_[4] .= substr(pack("N",$val), -$len);
  102.   }
  103. }
  104.  
  105.  
  106. sub _enc_bitstring {
  107. # 0      1    2       3     4     5      6
  108. # $optn, $op, $stash, $var, $buf, $loop, $path
  109.   my $vref = ref($_[3]) ? \($_[3]->[0]) : \$_[3];
  110.  
  111.   if (CHECK_UTF8 and Encode::is_utf8($$vref)) {
  112.     utf8::encode(my $tmp = $$vref);
  113.     $vref = \$tmp;
  114.   }
  115.  
  116.   if (ref($_[3])) {
  117.     my $less = (8 - ($_[3]->[1] & 7)) & 7;
  118.     my $len = ($_[3]->[1] + 7)/8;
  119.     $_[4] .= asn_encode_length(1+$len);
  120.     $_[4] .= chr($less);
  121.     $_[4] .= substr($$vref, 0, $len);
  122.     if ($less && $len) {
  123.       substr($_[4],-1) &= chr((0xff << $less) & 0xff);
  124.     }
  125.   }
  126.   else {
  127.     $_[4] .= asn_encode_length(1+length $$vref);
  128.     $_[4] .= chr(0);
  129.     $_[4] .= $$vref;
  130.   }
  131. }
  132.  
  133.  
  134. sub _enc_string {
  135. # 0      1    2       3     4     5      6
  136. # $optn, $op, $stash, $var, $buf, $loop, $path
  137.  
  138.   if (CHECK_UTF8 and Encode::is_utf8($_[3])) {
  139.     utf8::encode(my $tmp = $_[3]);
  140.     $_[4] .= asn_encode_length(length $tmp);
  141.     $_[4] .= $tmp;
  142.   }
  143.   else {
  144.     $_[4] .= asn_encode_length(length $_[3]);
  145.     $_[4] .= $_[3];
  146.   }
  147. }
  148.  
  149.  
  150. sub _enc_null {
  151. # 0      1    2       3     4     5      6
  152. # $optn, $op, $stash, $var, $buf, $loop, $path
  153.  
  154.   $_[4] .= chr(0);
  155. }
  156.  
  157.  
  158. sub _enc_object_id {
  159. # 0      1    2       3     4     5      6
  160. # $optn, $op, $stash, $var, $buf, $loop, $path
  161.  
  162.   my @data = ($_[3] =~ /(\d+)/g);
  163.  
  164.   if ($_[1]->[cTYPE] == opOBJID) {
  165.     if(@data < 2) {
  166.       @data = (0);
  167.     }
  168.     else {
  169.       my $first = $data[1] + ($data[0] * 40);
  170.       splice(@data,0,2,$first);
  171.     }
  172.   }
  173.  
  174.   my $l = length $_[4];
  175.   $_[4] .= pack("cw*", 0, @data);
  176.   substr($_[4],$l,1) = asn_encode_length(length($_[4]) - $l - 1);
  177. }
  178.  
  179.  
  180. sub _enc_real {
  181. # 0      1    2       3     4     5      6
  182. # $optn, $op, $stash, $var, $buf, $loop, $path
  183.  
  184.   # Zero
  185.   unless ($_[3]) {
  186.     $_[4] .= chr(0);
  187.     return;
  188.   }
  189.  
  190.   require POSIX;
  191.  
  192.   # +oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
  193.   if ($_[3] >= POSIX::HUGE_VAL()) {
  194.     $_[4] .= pack("C*",0x01,0x40);
  195.     return;
  196.   }
  197.  
  198.   # -oo (well we use HUGE_VAL as Infinity is not avaliable to perl)
  199.   if ($_[3] <= - POSIX::HUGE_VAL()) {
  200.     $_[4] .= pack("C*",0x01,0x41);
  201.     return;
  202.   }
  203.  
  204.   if (exists $_[0]->{'encode_real'} && $_[0]->{'encode_real'} ne 'binary') {
  205.     my $tmp = sprintf("%g",$_[3]);
  206.     $_[4] .= asn_encode_length(1+length $tmp);
  207.     $_[4] .= chr(1); # NR1?
  208.     $_[4] .= $tmp;
  209.     return;
  210.   }
  211.  
  212.   # We have a real number.
  213.   my $first = 0x80;
  214.   my($mantissa, $exponent) = POSIX::frexp($_[3]);
  215.  
  216.   if ($mantissa < 0.0) {
  217.     $mantissa = -$mantissa;
  218.     $first |= 0x40;
  219.   }
  220.   my($eMant,$eExp);
  221.  
  222.   while($mantissa > 0.0) {
  223.     ($mantissa, my $int) = POSIX::modf($mantissa * (1<<8));
  224.     $eMant .= chr($int);
  225.   }
  226.   $exponent -= 8 * length $eMant;
  227.  
  228.   _enc_integer(undef, undef, undef, $exponent, $eExp);
  229.  
  230.   # $eExp will br prefixed by a length byte
  231.   
  232.   if (5 > length $eExp) {
  233.     $eExp =~ s/\A.//s;
  234.     $first |= length($eExp)-1;
  235.   }
  236.   else {
  237.     $first |= 0x3;
  238.   }
  239.  
  240.   $_[4] .= asn_encode_length(1 + length($eMant) + length($eExp));
  241.   $_[4] .= chr($first);
  242.   $_[4] .= $eExp;
  243.   $_[4] .= $eMant;
  244. }
  245.  
  246.  
  247. sub _enc_sequence {
  248. # 0      1    2       3     4     5      6
  249. # $optn, $op, $stash, $var, $buf, $loop, $path
  250.  
  251.   if (my $ops = $_[1]->[cCHILD]) {
  252.     my $l = length $_[4];
  253.     $_[4] .= "\0\0"; # guess
  254.     if (defined $_[5]) {
  255.       my $op   = $ops->[0]; # there should only be one
  256.       my $enc  = $encode[$op->[cTYPE]];
  257.       my $tag  = $op->[cTAG];
  258.       my $loop = $op->[cLOOP];
  259.  
  260.       push @{$_[6]}, -1;
  261.  
  262.       foreach my $var (@{$_[3]}) {
  263.     $_[6]->[-1]++;
  264.     $_[4] .= $tag;
  265.  
  266.     &{$enc}(
  267.       $_[0], # $optn
  268.       $op,   # $op
  269.       $_[2], # $stash
  270.       $var,  # $var
  271.       $_[4], # $buf
  272.       $loop, # $loop
  273.       $_[6], # $path
  274.     );
  275.       }
  276.       pop @{$_[6]};
  277.     }
  278.     else {
  279.       _encode($_[0],$_[1]->[cCHILD], defined($_[3]) ? $_[3] : $_[2], $_[6], $_[4]);
  280.     }
  281.     substr($_[4],$l,2) = asn_encode_length(length($_[4]) - $l - 2);
  282.   }
  283.   else {
  284.     $_[4] .= asn_encode_length(length $_[3]);
  285.     $_[4] .= $_[3];
  286.   }
  287. }
  288.  
  289.  
  290. my %_enc_time_opt = ( utctime => 1, withzone => 0, raw => 2);
  291.  
  292. sub _enc_time {
  293. # 0      1    2       3     4     5      6
  294. # $optn, $op, $stash, $var, $buf, $loop, $path
  295.  
  296.   my $mode = $_enc_time_opt{$_[0]->{'encode_time'} || ''} || 0;
  297.  
  298.   if ($mode == 2) {
  299.     $_[4] .= asn_encode_length(length $_[3]);
  300.     $_[4] .= $_[3];
  301.     return;
  302.   }
  303.  
  304.   my @time;
  305.   my $offset;
  306.   my $isgen = $_[1]->[cTYPE] == opGTIME;
  307.  
  308.   if (ref($_[3])) {
  309.     $offset = int($_[3]->[1] / 60);
  310.     $time = $_[3]->[0] + $_[3]->[1];
  311.   }
  312.   elsif ($mode == 0) {
  313.     if (exists $_[0]->{'encode_timezone'}) {
  314.       $offset = int($_[0]->{'encode_timezone'} / 60);
  315.       $time = $_[3] + $_[0]->{'encode_timezone'};
  316.     }
  317.     else {
  318.       @time = localtime($_[3]);
  319.       my @g = gmtime($_[3]);
  320.       
  321.       $offset = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60;
  322.       $time = $_[3] + $offset*60;
  323.     }
  324.   }
  325.   else {
  326.     $time = $_[3];
  327.   }
  328.   @time = gmtime($time);
  329.   $time[4] += 1;
  330.   $time[5] = $isgen ? ($time[5] + 1900) : ($time[5] % 100);
  331.  
  332.   my $tmp = sprintf("%02d"x6, @time[5,4,3,2,1,0]);
  333.   if ($isgen) {
  334.     my $sp = sprintf("%.03f",$time);
  335.     $tmp .= substr($sp,-4) unless $sp =~ /\.000$/;
  336.   }
  337.   $tmp .= $offset ? sprintf("%+03d%02d",$offset / 60, abs($offset % 60)) : 'Z';
  338.   $_[4] .= asn_encode_length(length $tmp);
  339.   $_[4] .= $tmp;
  340. }
  341.  
  342.  
  343. sub _enc_utf8 {
  344. # 0      1    2       3     4     5      6
  345. # $optn, $op, $stash, $var, $buf, $loop, $path
  346.  
  347.   if (CHECK_UTF8) {
  348.     my $tmp = $_[3];
  349.     utf8::upgrade($tmp) unless Encode::is_utf8($tmp);
  350.     utf8::encode($tmp);
  351.     $_[4] .= asn_encode_length(length $tmp);
  352.     $_[4] .= $tmp;
  353.   }
  354.   else {
  355.     $_[4] .= asn_encode_length(length $_[3]);
  356.     $_[4] .= $_[3];
  357.   }
  358. }
  359.  
  360.  
  361. sub _enc_any {
  362. # 0      1    2       3     4     5      6
  363. # $optn, $op, $stash, $var, $buf, $loop, $path
  364.  
  365.   my $handler;
  366.   if ($_[1]->[cDEFINE] && $_[2]->{$_[1]->[cDEFINE]}) {
  367.     $handler=$_[0]->{oidtable}{$_[2]->{$_[1]->[cDEFINE]}};
  368.   }
  369.   if ($handler) {
  370.     $_[4] .= $handler->encode($_[3]);
  371.   } else {
  372.     $_[4] .= $_[3];
  373.   }
  374. }
  375.  
  376.  
  377. sub _enc_choice {
  378. # 0      1    2       3     4     5      6
  379. # $optn, $op, $stash, $var, $buf, $loop, $path
  380.  
  381.   my $stash = defined($_[3]) ? $_[3] : $_[2];
  382.   for my $op (@{$_[1]->[cCHILD]}) {
  383.     my $var = defined $op->[cVAR] ? $op->[cVAR] : $op->[cCHILD]->[0]->[cVAR];
  384.  
  385.     if (exists $stash->{$var}) {
  386.       push @{$_[6]}, $var;
  387.       _encode($_[0],[$op], $stash, $_[6], $_[4]);
  388.       pop @{$_[6]};
  389.       return;
  390.     }
  391.   }
  392.   require Carp;
  393.   Carp::croak("No value found for CHOICE " . join(".", @{$_[6]}));
  394. }
  395.  
  396.  
  397. 1;
  398.  
  399.