File Coverage

blib/lib/Convert/ASCII/Armour.pm
Criterion Covered Total %
statement 71 76 93.4
branch 17 24 70.8
condition 1 3 33.3
subroutine 12 14 85.7
pod 4 9 44.4
total 105 126 83.3


line stmt bran cond sub pod time code
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 5     5   70 use strict;
  5         159  
  5         125  
13 5     5   83 use Digest::MD5 qw(md5);
  5         95  
  5         97  
14 5     5   282 use MIME::Base64;
  5         51  
  5         111  
15 5     5   200 use Compress::Zlib qw(compress uncompress);
  5         52  
  5         121  
16 5     5   95 use vars qw($VERSION);
  5         47  
  5         76  
17              
18             ($VERSION)  = '$Revision: 1.4 $' =~ /\s(\d+\.\d+)\s/;
19              
20              
21             sub new {
22 5     5 1 74     return bless {}, shift;
23             }
24              
25              
26             sub error {
27 0     0 0 0     my ($self, $errstr) = @_;
28 0         0     $$self{errstr} = "$errstr\n";
29 0         0     return;
30             }
31              
32              
33             sub errstr {
34 0     0 1 0     my $self = shift;
35 0         0     return $$self{errstr};
36             }
37              
38              
39             sub armour {
40              
41 4     4 1 55     my ($self, %params) = @_;
42              
43 4 100       77     my $compress = $params{Compress} ? "COMPRESSED " : "";
44 4 50       52     return undef unless $params{Content};
45 4 50       52     $params{Object} = "UNKNOWN $compress DATA" unless $params{Object};
46              
47 4         64     my $head = "-"x5 . "BEGIN $compress$params{Object}" . "-"x5;
48 4         58     my $tail = "-"x5 . "END $compress$params{Object}" . "-"x5;
49              
50 4         40     my $content = $self->encode_content (%{$params{Content}});
  4         82  
51 4 100       65        $content = compress($content) if $compress;
52 4         5553     my $checksum = encode_base64 (md5 ($content));
53 4         56     my $econtent = encode_base64 ($content);
54              
55 4         57     my $eheaders = "";
56 4         38     for my $key (keys %{$params{Headers}}) {
  4         89  
57 6         79        $eheaders .= "$key: $params{Headers}->{$key}\n";
58                 }
59              
60 4         64     my $message = "$head\n$eheaders\n$econtent=$checksum$tail\n";
61 4         96     return $message;
62              
63             }
64              
65              
66             sub unarmour {
67 4     4 1 42     my ($self, $message) = @_;
68              
69 4 50       281     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 4         59     my ($compress, $obj) = $object =~ /^(COMPRESSED )(.*)$/;
74 4 100       51     $object = $obj if $obj;
75 4 50       71     $content =~ s:=([^\n]+)$::s or return $self->error ("Breached Armour.");
76 4         53     my $checksum = $1; $content = decode_base64 ($content);
  4         55  
77 4         68     my $ncheck = encode_base64 (md5 ($content)); $ncheck =~ s/\n//;
  4         45  
78 4 50       48     return $self->error ("Checksum Failed.") unless $ncheck eq $checksum;
79 4 100       56     $content = uncompress ($content) if $compress;
80 4   33     2308     my $dcontent = $self->decode_content ($content) || return;
81              
82 4         37     my $dheaders;
83 4 100       46     if ($headers) {
84 3         44         my @pairs = split /\n/, $headers;
85 3         34         for (@pairs) {
86 6         86             my ($key, $value) = split /: /, $_, 2;
87 6 50       84             $$dheaders{$key} = $value if $key;
88                     }
89                 }
90              
91 4         52     my %return = ( Content => $dcontent,
92                                Object => $object,
93                                Headers => $dheaders );
94              
95 4         159     return \%return;
96              
97             }
98              
99              
100             sub encode_content {
101 5     5 0 70     my ($self, %data) = @_;
102 5         50     my $encoded = "";
103              
104 5         58     for my $key (keys %data) {
105 20         307         $encoded .= length ($key) . chr(0) . length ($data{$key}) .
106                                                 chr(0) . "$key$data{$key}";
107                 }
108              
109 5         72     return $encoded;
110             }
111              
112              
113             sub decode_content {
114 5     5 0 55     my ($self, $content) = @_;
115 5         46     my %data;
116              
117 5         74     while ($content) {
118 20 50       259         $content =~ s/^(\d+)\x00(\d+)\x00// ||
119                         return $self->error ("Inconsistent content.");
120 20         193         my $keylen = $1; my $valuelen = $2;
  20         191  
121 20         200         my $key = substr $content, 0, $keylen;
122 20         196         my $value = substr $content, $keylen, $valuelen;
123 20         243         substr ($content, 0, $keylen + $valuelen) = "";
124 20         295         $data{$key} = $value;
125                 }
126              
127 5         85     return \%data;
128             }
129              
130              
131 1     1 0 14 sub   armor { armour (@_) }
132 1     1 0 13 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