1#############################################################################
2## Name:        Base64.pm
3## Purpose:     XML::Smart::Base64
4## Author:      Graciliano M. P.
5## Modified by:
6## Created:     25/5/2003
7## RCS-ID:
8## Copyright:   (c) 2003 Graciliano M. P.
9## Licence:     This program is free software; you can redistribute it and/or
10##              modify it under the same terms as Perl itself
11
12
13#############################################################################
14
15
16##
17## Modified by Harish to fix bugs in xml creation and to errors more readable.
18##     Tue Nov  1 21:18:43 IST 2011
19
20
21############################################################################
22
23
24package XML::Smart::Base64                                     ;
25
26use strict                                                     ;
27use warnings                                                   ;
28
29use Carp                                                       ;
30
31use XML::Smart::Shared qw( _unset_sig_warn _reset_sig_warn )   ;
32
33our $VERSION = '1.3'       ;
34
35
36my ($BASE64_PM) ;
37eval("use MIME::Base64 ()") ;
38if ( defined &MIME::Base64::encode_base64 ) { $BASE64_PM = 1 ;}
39
40
41
42
43#################
44# ENCODE_BASE64 #
45#################
46
47sub encode_base64 {
48
49    my $value   = $_[0] ;
50
51    if( $BASE64_PM ) {
52
53	eval {
54	    _unset_sig_warn() ;
55	    my $encoded = MIME::Base64::encode_base64( $value  ) ;
56	    my $decoded = MIME::Base64::decode_base64( $encoded) ;
57	    _reset_sig_warn() ;
58
59	    my $tmp_decoded =  $decoded ;
60	    $tmp_decoded    =~ s/\n//g  ;
61
62	    my $tmp_value   =  $value   ;
63	    $tmp_value      =~ s/\n//g  ;
64
65	    return $encoded if( $tmp_decoded eq $tmp_value ) ;
66	};
67
68    }
69
70    {
71	my $encoded     ;
72	my $decoded     ;
73	my $tmp_value   ;
74	my $tmp_decoded ;
75	eval {
76	    _unset_sig_warn() ;
77	    $encoded = _encode_base64_pure_perl( $value   ) ;
78	    $decoded = _decode_base64_pure_perl( $encoded ) ;
79	    _reset_sig_warn() ;
80
81	    $tmp_decoded    =  $decoded ;
82	    $tmp_decoded    =~ s/\n//g  ;
83
84	    $tmp_value      =  $value   ;
85	    $tmp_value      =~ s/\n//g  ;
86	} ; unless( $@ ) {
87	    return $encoded if( $tmp_decoded eq $tmp_value ) ;
88	}
89    }
90
91    {
92	_unset_sig_warn() ;
93	my $encoded = _encode_ord_special( $value   ) ;
94	my $decoded = _decode_ord_special( $encoded ) ;
95	_reset_sig_warn() ;
96
97	my $tmp_decoded =  $decoded ;
98	$tmp_decoded    =~ s/\n//g  ;
99
100	my $tmp_value   =  $value   ;
101	$tmp_value      =~ s/\n//g  ;
102
103	return $encoded if( $tmp_decoded eq $tmp_value ) ;
104    }
105
106
107
108    croak( "Error Encoding\n" ) ;
109
110}
111
112############################
113# _ENCODE_BASE64_PURE_PERL #
114############################
115
116sub _encode_base64_pure_perl {
117    my $res = "";
118    my $eol = $_[1];
119    $eol = "\n" unless defined $eol;
120    pos($_[0]) = 0;                          # ensure start at the beginning
121    while ($_[0] =~ /(.{1,45})/gs) {
122	my $text = $1 ;
123	$res .= substr( pack('u', $text ), 1 ) ;
124	chop($res);
125    }
126    $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
127    # fix padding at the end
128    my $padding = (3 - length($_[0]) % 3) % 3;
129    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
130    # break encoded string into lines of no more than 76 characters each
131    if (length $eol) {
132	$res =~ s/(.{1,76})/$1$eol/g;
133    }
134    $res;
135}
136
137
138
139############################
140#   _ENCODE_ORD_SPECIAL    #
141############################
142
143
144sub _encode_ord_special {
145
146    my $value = shift ;
147
148    my @chars = split( //, $value ) ;
149    my @ords  ;
150    foreach my $char ( @chars ) {
151	push @ords, ord( $char ) ;
152    }
153
154    return join( "|", @ords ) ;
155
156}
157
158
159############################
160#   _DECODE_ORD_SPECIAL    #
161############################
162
163
164sub _decode_ord_special {
165
166    my $value = shift ;
167    my @ords = split( /\|/, $value ) ;
168    my @chars  ;
169    foreach my $ord ( @ords ) {
170	push @chars, chr( $ord ) ;
171    }
172
173    return join( "", @chars ) ;
174
175}
176
177#################
178# DECODE_BASE64 #
179#################
180
181sub decode_base64 {
182
183    my $value = $_[0] ;
184
185    if( $BASE64_PM ) {
186
187	eval {
188	    _unset_sig_warn() ;
189	    my $decoded = MIME::Base64::decode_base64( $value   ) ;
190	    my $encoded = MIME::Base64::encode_base64( $decoded ) ;
191	    _reset_sig_warn() ;
192
193	    my $tmp_value   = $value   ;
194	    $tmp_value      =~ s/\n//g ;
195
196	    my $tmp_encoded = $encoded ;
197	    $tmp_encoded    =~ s/\n//g ;
198
199	    return $decoded if( $tmp_encoded eq $tmp_value  ) ;
200	};
201
202    }
203
204    {
205
206	my $decoded     ;
207	my $encoded     ;
208	my $tmp_value   ;
209	my $tmp_encoded ;
210	eval {
211	    $decoded = _decode_base64_pure_perl( $value     ) ;
212	    $encoded = _encode_base64_pure_perl( $decoded   ) ;
213
214	    $tmp_value      = $value   ;
215	    $tmp_value      =~ s/\n//g ;
216
217	    $tmp_encoded    = $encoded ;
218	    $tmp_encoded    =~ s/\n//g ;
219	} ; unless( $@ ) {
220	    return $decoded if( $tmp_encoded eq $tmp_value  ) ;
221	}
222
223    }
224
225    {
226
227	my $decoded = _decode_ord_special( $value     ) ;
228	my $encoded = _encode_ord_special( $decoded   ) ;
229
230	my $tmp_value   = $value   ;
231	$tmp_value      =~ s/\n//g ;
232
233	my $tmp_encoded = $encoded ;
234	$tmp_encoded    =~ s/\n//g ;
235
236	return $decoded if( $tmp_encoded eq $tmp_value  ) ;
237
238    }
239
240    croak "Error Decoding $value\n"  ;
241
242}
243
244
245############################
246# _DECODE_BASE64_PURE_PERL #
247############################
248
249sub _decode_base64_pure_perl {
250  local($^W) = 0 ;
251  my $str = shift ;
252  my $res = "";
253
254  $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
255  if (length($str) % 4) {
256	#require Carp;
257	#Carp::carp("Length of base64 data not a multiple of 4")
258  }
259  $str =~ s/=+$//;                        # remove padding
260  $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
261  while ($str =~ /(.{1,60})/gs) {
262	my $len = chr(32 + length($1)*3/4); # compute length byte
263	$res .= unpack("u", $len . $1 );    # uudecode
264  }
265  $res;
266}
267
268#######
269# END #
270#######
271
2721;
273
274