home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Armour.pm < prev    next >
Encoding:
Perl POD Document  |  2001-03-19  |  6.4 KB  |  248 lines
  1. #!/usr/bin/perl -sw
  2. ##
  3. ## Convert::ASCII::Armour 
  4. ##
  5. ## Copyright (c) 2001, Vipul Ved Prakash.  All rights reserved.
  6. ## This code is free software; you can redistribute it and/or modify
  7. ## it under the same terms as Perl itself.
  8. ##
  9. ## $Id: Armour.pm,v 1.4 2001/03/19 23:15:09 vipul Exp $
  10.  
  11. package Convert::ASCII::Armour; 
  12. use strict;
  13. use Digest::MD5 qw(md5);
  14. use MIME::Base64;
  15. use Compress::Zlib qw(compress uncompress);
  16. use vars qw($VERSION);
  17.  
  18. ($VERSION)  = '$Revision: 1.4 $' =~ /\s(\d+\.\d+)\s/; 
  19.  
  20.  
  21. sub new { 
  22.     return bless {}, shift;
  23. }
  24.  
  25.  
  26. sub error { 
  27.     my ($self, $errstr) = @_;
  28.     $$self{errstr} = "$errstr\n";
  29.     return; 
  30. }
  31.  
  32.  
  33. sub errstr { 
  34.     my $self = shift;
  35.     return $$self{errstr};
  36. }
  37.  
  38.  
  39. sub armour { 
  40.  
  41.     my ($self, %params) = @_;
  42.  
  43.     my $compress = $params{Compress} ? "COMPRESSED " : "";
  44.     return undef unless $params{Content};
  45.     $params{Object} = "UNKNOWN $compress DATA" unless $params{Object};
  46.  
  47.     my $head     = "-"x5 . "BEGIN $compress$params{Object}" . "-"x5;   
  48.     my $tail     = "-"x5 . "END $compress$params{Object}" . "-"x5; 
  49.  
  50.     my $content  = $self->encode_content (%{$params{Content}}); 
  51.        $content  = compress($content) if $compress;
  52.     my $checksum = encode_base64 (md5 ($content));
  53.     my $econtent = encode_base64 ($content);
  54.  
  55.     my $eheaders = "";
  56.     for my $key (keys %{$params{Headers}}) { 
  57.        $eheaders .= "$key: $params{Headers}->{$key}\n";
  58.     } 
  59.  
  60.     my $message  = "$head\n$eheaders\n$econtent=$checksum$tail\n";
  61.     return $message;
  62.  
  63. }
  64.  
  65.  
  66. sub unarmour { 
  67.     my ($self, $message) = @_;
  68.  
  69.     my ($head, $object, $headers, $content, $tail) = $message =~ 
  70.         m:(-----BEGIN ([^\n\-]+)-----)\n(.*?\n\n)?(.+)(-----END .*?-----)$:s 
  71.         or return $self->error ("Breached Armour.");
  72.  
  73.     my ($compress, $obj) = $object =~ /^(COMPRESSED )(.*)$/;
  74.     $object = $obj if $obj;
  75.     $content =~ s:=([^\n]+)$::s or return $self->error ("Breached Armour.");
  76.     my $checksum = $1; $content = decode_base64 ($content);
  77.     my $ncheck  = encode_base64 (md5 ($content)); $ncheck =~ s/\n//;
  78.     return $self->error ("Checksum Failed.") unless $ncheck eq $checksum;
  79.     $content = uncompress ($content) if $compress;
  80.     my $dcontent = $self->decode_content ($content) || return; 
  81.  
  82.     my $dheaders; 
  83.     if ($headers) { 
  84.         my @pairs = split /\n/, $headers;
  85.         for (@pairs) { 
  86.             my ($key, $value) = split /: /, $_, 2; 
  87.             $$dheaders{$key} = $value if $key;
  88.         }
  89.     }            
  90.  
  91.     my %return = ( Content => $dcontent, 
  92.                    Object  => $object, 
  93.                    Headers => $dheaders );
  94.  
  95.     return \%return;
  96.  
  97. }
  98.  
  99.  
  100. sub encode_content { 
  101.     my ($self, %data)  = @_;
  102.     my $encoded = "";
  103.  
  104.     for my $key (keys %data) { 
  105.         $encoded .= length ($key) . chr(0) . length ($data{$key}) . 
  106.                                     chr(0) . "$key$data{$key}"; 
  107.     }
  108.  
  109.     return $encoded; 
  110. }
  111.  
  112.  
  113. sub decode_content { 
  114.     my ($self, $content) = @_; 
  115.     my %data; 
  116.  
  117.     while ($content) { 
  118.         $content =~ s/^(\d+)\x00(\d+)\x00// || 
  119.             return $self->error ("Inconsistent content."); 
  120.         my $keylen = $1; my $valuelen = $2; 
  121.         my $key = substr $content, 0, $keylen; 
  122.         my $value = substr $content, $keylen, $valuelen; 
  123.         substr ($content, 0, $keylen + $valuelen) = "";
  124.         $data{$key} = $value;
  125.     }
  126.  
  127.     return \%data;
  128. }
  129.  
  130.  
  131. sub   armor {   armour (@_) }
  132. sub unarmor { unarmour (@_) }
  133.  
  134.  
  135. 1;
  136.  
  137.  
  138. =head1 NAME
  139.  
  140. Convert::ASCII::Armour - Convert binary octets into ASCII armoured messages.
  141.  
  142. =head1 SYNOPSIS
  143.  
  144.     my $converter = new Convert::ASCII::Armour; 
  145.  
  146.     my $message   = $converter->armour( 
  147.                         Object   => "FOO RECORD", 
  148.                         Headers  => { 
  149.                                       Table   => "FooBar", 
  150.                                       Version => "1.23", 
  151.                                     },
  152.                         Content  => { 
  153.                                       Key  => "0x8738FA7382", 
  154.                                       Name => "Zoya Hall",
  155.                                       Pic  => "....",  # gif 
  156.                                     },
  157.                         Compress => 1,
  158.                     );
  159.  
  160.     print $message; 
  161.  
  162.  
  163.     -----BEGIN COMPRESSED FOO RECORD-----
  164.     Version: 1.23
  165.     Table: FooBar
  166.  
  167.     eJwzZzA0Z/BNLS5OTE8NycgsVgCiRIVciIAJg6EJg0tiSaqhsYJvYlFy...
  168.     XnpOZl5qYlJySmpaekZmVnZObl5+QWFRcUlpWXlFZRWXAk7g6OTs4urm...
  169.     Fh4VGaWAR5ehkbGJqZm5hSUeNXWKDsoGcWpaGpq68bba0dWxtTVmDOYM...
  170.     NzuZ
  171.     =MxpZvjkrv5XyhkVCuXmsBQ==
  172.     -----END COMPRESSED FOO RECORD-----
  173.  
  174.  
  175.     my $decoded   = $converter->unarmour( $message ) 
  176.                      || die $converter->errstr();
  177.                         
  178.  
  179. =head1 DESCRIPTION
  180.  
  181. This module converts hashes of binary octets into ASCII messages suitable
  182. for transfer over 6-bit clean transport channels. The encoded ASCII
  183. resembles PGP's armoured messages, but are in no way compatible with PGP.
  184.  
  185. =head1 METHODS
  186.  
  187. =head2 B<new()>
  188.  
  189. Constructor.
  190.  
  191. =head2 B<armour()>
  192.  
  193. Converts a hash of binary octets into an ASCII encoded message. The
  194. encoded message has 4 parts: head and tail strings that act as identifiers
  195. and delimiters, a cluster of headers at top of the message, Base64 encoded
  196. message body and a Base64 encoded MD5 digest of the message body. armour()
  197. takes a hash as argument with following keys:
  198.  
  199. =over 4
  200.  
  201. =item B<Object>
  202.  
  203. An identification string embedded in head and tail strings.
  204.  
  205. =item B<Content> 
  206.  
  207. Content is a hashref that contains the binary octets to be encoded. This
  208. hash is serialized, compressed (if specified) and encoded into ASCII with
  209. MIME::Base64.  The result is the body of the encoded message.
  210.  
  211. =item B<Headers>
  212.  
  213. Headers is a hashref that contains ASCII headers that are placed at top of
  214. the encoded message. Headers are encoded as RFC822 headers.
  215.  
  216. =item B<Compress>
  217.  
  218. A boolean parameter that forces armour() to compress the message body.
  219.  
  220. =back
  221.  
  222. =head2 B<unarmour()>
  223.  
  224. Decodes an armoured ASCII message into the hash provided as argument
  225. to armour(). The hash contains Content, Object, and Headers.
  226. unarmour() performs several consistency checks and returns a non-true
  227. value on failure.
  228.  
  229. =head2 B<errstr()>
  230.  
  231. Returns the error message set by unarmour() on failure.
  232.  
  233. =head1 AUTHOR
  234.  
  235. Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
  236.  
  237. =head1 LICENSE
  238.  
  239. Copyright (c) 2001, Vipul Ved Prakash. All rights reserved. This code is
  240. free software; you can redistribute it and/or modify it under the same
  241. terms as Perl itself.
  242.  
  243. =head1 SEE ALSO
  244.  
  245. MIME::Base64(3), Compress::Zlib(3), Digest::MD5(3)
  246.  
  247. =cut
  248.