Mercurial > hg > xemacs-beta
annotate modules/base64/base64.c @ 5570:6c76f5b7e2e3
Be more careful still in #'cl-defsubst-expand.
lisp/ChangeLog addition:
2011-09-11 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-defsubst-expand):
Be more careful still here, make sure that any references to
variables in BODY don't access those values in the enclosing scope
when that would be inappropriate.
Add some documentation of a potential reasonable approach to
avoiding the problems with our (non-Common Lisp-conformant)
#'symbol-macrolet.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 11 Sep 2011 16:05:05 +0100 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 428 | 1 /* base64 interface for XEmacs. |
| 2 Copyright (C) 1998, 1999 Free Software Foundation, Inc. | |
| 5137 | 3 Copyright (C) 2010 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5137
diff
changeset
|
7 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 8 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5137
diff
changeset
|
9 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5137
diff
changeset
|
10 option) any later version. |
| 428 | 11 |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5137
diff
changeset
|
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 19 |
| 20 /* Synched up with: Not in FSF. */ | |
| 21 | |
| 22 /* Author: William Perry <wmperry@aventail.com> */ | |
| 23 | |
| 24 #include <emodules.h> | |
| 25 | |
| 26 unsigned char alphabet[64] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; | |
| 27 | |
| 28 DEFUN ("base64-encode", Fbase64_encode, 1, 5, 0, /* | |
| 29 Return the base64 encoding of an object. | |
| 30 OBJECT is either a string or a buffer. | |
| 31 Optional arguments START and END denote buffer positions for computing the | |
| 32 hash of a portion of OBJECT. The optional CODING argument specifies the coding | |
| 33 system the text is to be represented in while computing the digest. This only | |
| 34 has meaning with MULE, and defaults to the current format of the data. | |
| 35 If ERROR-ME-NOT is nil, report an error if the coding system can't be | |
| 36 determined. Else assume binary coding if all else fails. | |
| 37 */ | |
| 38 (object, start, end, coding, error_me_not)) | |
| 39 { | |
| 5137 | 40 int cols,bits,char_count; |
| 41 Lisp_Object instream, outstream,deststream; | |
| 42 Lstream *istr, *ostr, *dstr; | |
| 43 static Extbyte_dynarr *conversion_out_dynarr; | |
| 44 static Extbyte_dynarr *out_dynarr; | |
| 45 char tempbuf[1024]; /* some random amount */ | |
| 46 struct gcpro gcpro1, gcpro2; | |
| 47 Lisp_Object conv_out_stream, coding_system; | |
| 48 Lstream *costr; | |
| 49 struct gcpro gcpro3; | |
| 428 | 50 |
| 5137 | 51 if (!conversion_out_dynarr) |
| 52 conversion_out_dynarr = Dynarr_new (Extbyte); | |
| 53 else | |
| 54 Dynarr_reset (conversion_out_dynarr); | |
| 55 | |
| 56 if (!out_dynarr) | |
| 57 out_dynarr = Dynarr_new (Extbyte); | |
| 58 else | |
| 59 Dynarr_reset (out_dynarr); | |
| 60 | |
| 61 char_count = bits = cols = 0; | |
| 62 | |
| 63 /* set up the in stream */ | |
| 64 if (BUFFERP (object)) | |
| 65 { | |
| 66 struct buffer *b = XBUFFER (object); | |
| 67 Charbpos begv, endv; | |
| 68 /* Figure out where we need to get info from */ | |
| 69 get_buffer_range_char (b, start, end, &begv, &endv, GB_ALLOW_NIL); | |
| 428 | 70 |
| 5137 | 71 instream = make_lisp_buffer_input_stream (b, begv, endv, 0); |
| 72 } | |
| 73 else | |
| 74 { | |
| 75 Bytecount bstart, bend; | |
| 76 CHECK_STRING (object); | |
| 77 get_string_range_byte (object, start, end, &bstart, &bend, | |
| 78 GB_HISTORICAL_STRING_BEHAVIOR); | |
| 79 instream = make_lisp_string_input_stream (object, bstart, bend); | |
| 80 } | |
| 81 istr = XLSTREAM (instream); | |
| 428 | 82 |
| 5137 | 83 /* Find out what format the buffer will be saved in, so we can make |
| 84 the digest based on what it will look like on disk */ | |
| 85 if (NILP (coding)) | |
| 86 { | |
| 87 if (BUFFERP (object)) | |
| 428 | 88 { |
| 5137 | 89 /* Use the file coding for this buffer by default */ |
| 90 coding_system = XBUFFER (object)->buffer_file_coding_system; | |
| 428 | 91 } |
| 5137 | 92 else |
| 93 { | |
| 94 /* attempt to autodetect the coding of the string. Note: this VERY hit-and-miss */ | |
| 95 enum eol_type eol = EOL_AUTODETECT; | |
| 96 coding_system = Fget_coding_system (Qundecided); | |
| 97 determine_real_coding_system (istr, &coding_system, &eol); | |
| 98 } | |
| 99 if (NILP (coding_system)) | |
| 100 coding_system = Fget_coding_system (Qbinary); | |
| 101 else | |
| 428 | 102 { |
| 5137 | 103 coding_system = Ffind_coding_system (coding_system); |
| 104 if (NILP (coding_system)) | |
| 105 coding_system = Fget_coding_system (Qbinary); | |
| 428 | 106 } |
| 5137 | 107 } |
| 108 else | |
| 109 { | |
| 110 coding_system = Ffind_coding_system (coding); | |
| 111 if (NILP (coding_system)) | |
| 112 { | |
| 113 if (NILP (error_me_not)) | |
| 114 signal_simple_error ("No such coding system", coding); | |
| 115 else | |
| 116 coding_system = Fget_coding_system (Qbinary); /* default to binary */ | |
| 117 } | |
| 118 } | |
| 428 | 119 |
| 5137 | 120 /* setup the out stream */ |
| 121 outstream = make_dynarr_output_stream ((unsigned_char_dynarr *)conversion_out_dynarr); | |
| 122 ostr = XLSTREAM (outstream); | |
| 123 deststream = make_dynarr_output_stream ((unsigned_char_dynarr *)out_dynarr); | |
| 124 dstr = XLSTREAM (deststream); | |
| 125 /* setup the conversion stream */ | |
| 126 conv_out_stream = make_encoding_output_stream (ostr, coding_system); | |
| 127 costr = XLSTREAM (conv_out_stream); | |
| 128 GCPRO3 (instream, outstream, conv_out_stream); | |
| 129 | |
| 130 /* Get the data while doing the conversion */ | |
| 131 while (1) | |
| 132 { | |
| 133 int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); | |
| 134 int l; | |
| 135 if (!size_in_bytes) | |
| 136 break; | |
| 137 /* It does seem the flushes are necessary... */ | |
| 138 Lstream_write (costr, tempbuf, size_in_bytes); | |
| 139 Lstream_flush (costr); | |
| 140 Lstream_flush (ostr); | |
| 141 | |
| 142 /* Update the base64 output buffer */ | |
| 143 for (l = 0; l < size_in_bytes; l++) | |
| 428 | 144 { |
| 5137 | 145 bits += Dynarr_at (conversion_out_dynarr,l); |
| 146 char_count++; | |
| 147 if (char_count == 3) | |
| 428 | 148 { |
| 5137 | 149 static char obuf[4]; |
| 150 obuf[0] = alphabet[(bits >> 18)]; | |
| 151 obuf[1] = alphabet[(bits >> 12) & 0x3f]; | |
| 152 obuf[2] = alphabet[(bits >> 6) & 0x3f]; | |
| 153 obuf[3] = alphabet[bits & 0x3f]; | |
| 154 | |
| 155 Lstream_write (dstr,obuf,sizeof (obuf)); | |
| 156 cols += 4; | |
| 157 if (cols == 72) | |
| 158 { | |
| 159 Lstream_write (dstr,"\n",sizeof (unsigned char)); | |
| 160 cols = 0; | |
| 161 } | |
| 162 bits = char_count = 0; | |
| 428 | 163 } |
| 5137 | 164 else |
| 428 | 165 { |
| 5137 | 166 bits <<= 8; |
| 428 | 167 } |
| 168 } | |
| 5137 | 169 /* reset the dynarr */ |
| 170 Lstream_rewind (ostr); | |
| 171 } | |
| 172 Lstream_close (istr); | |
| 173 Lstream_close (costr); | |
| 174 Lstream_close (ostr); | |
| 428 | 175 |
| 5137 | 176 if (char_count != 0) |
| 177 { | |
| 178 bits <<= 16 - (8 * char_count); | |
| 179 Lstream_write (dstr,&alphabet[bits >> 18],sizeof (unsigned char)); | |
| 180 Lstream_write (dstr,&alphabet[(bits >> 12) & 0x3f],sizeof (unsigned char)); | |
| 181 if (char_count == 1) | |
| 182 { | |
| 183 Lstream_write (dstr,"==",2 * sizeof (unsigned char)); | |
| 184 } else | |
| 185 { | |
| 186 Lstream_write (dstr,&alphabet[(bits >> 6) & 0x3f],sizeof (unsigned char)); | |
| 187 Lstream_write (dstr,"=",sizeof (unsigned char)); | |
| 428 | 188 } |
| 5137 | 189 } |
| 190 #if 0 | |
| 191 if (cols > 0) | |
| 192 { | |
| 193 Lstream_write (dstr,"\n",sizeof (unsigned char)); | |
| 194 } | |
| 428 | 195 #endif |
| 5137 | 196 UNGCPRO; |
| 197 Lstream_delete (istr); | |
| 198 Lstream_delete (ostr); | |
| 199 Lstream_delete (costr); | |
| 200 Lstream_flush (dstr); | |
| 201 Lstream_delete (dstr); | |
| 428 | 202 |
| 5137 | 203 return (make_string (Dynarr_atp (out_dynarr,0),Dynarr_length (out_dynarr))); |
| 428 | 204 } |
| 205 | |
| 206 DEFUN ("base64-decode", Fbase64_decode, 1, 5, 0, /* | |
| 207 Undo the base64 encoding of an object. | |
| 208 OBJECT is either a string or a buffer. | |
| 209 Optional arguments START and END denote buffer positions for computing the | |
| 210 hash of a portion of OBJECT. The optional CODING argument specifies the coding | |
| 211 system the text is to be represented in while computing the digest. This only | |
| 212 has meaning with MULE, and defaults to the current format of the data. | |
| 213 If ERROR-ME-NOT is nil, report an error if the coding system can't be | |
| 214 determined. Else assume binary coding if all else fails. | |
| 215 */ | |
| 216 (object, start, end, coding, error_me_not)) | |
| 217 { | |
| 5137 | 218 static char inalphabet[256], decoder[256]; |
| 219 int i,cols,bits,char_count,hit_eof; | |
| 220 Lisp_Object instream, outstream,deststream; | |
| 221 Lstream *istr, *ostr, *dstr; | |
| 222 static Extbyte_dynarr *conversion_out_dynarr; | |
| 223 static Extbyte_dynarr *out_dynarr; | |
| 224 char tempbuf[1024]; /* some random amount */ | |
| 225 struct gcpro gcpro1, gcpro2; | |
| 226 Lisp_Object conv_out_stream, coding_system; | |
| 227 Lstream *costr; | |
| 228 struct gcpro gcpro3; | |
| 428 | 229 |
| 5137 | 230 for (i = (sizeof alphabet) - 1; i >= 0 ; i--) |
| 231 { | |
| 232 inalphabet[alphabet[i]] = 1; | |
| 233 decoder[alphabet[i]] = i; | |
| 428 | 234 } |
| 235 | |
| 5137 | 236 if (!conversion_out_dynarr) |
| 237 conversion_out_dynarr = Dynarr_new (Extbyte); | |
| 238 else | |
| 239 Dynarr_reset (conversion_out_dynarr); | |
| 428 | 240 |
| 5137 | 241 if (!out_dynarr) |
| 242 out_dynarr = Dynarr_new (Extbyte); | |
| 243 else | |
| 244 Dynarr_reset (out_dynarr); | |
| 428 | 245 |
| 5137 | 246 char_count = bits = cols = hit_eof = 0; |
| 428 | 247 |
| 5137 | 248 /* set up the in stream */ |
| 249 if (BUFFERP (object)) | |
| 250 { | |
| 251 struct buffer *b = XBUFFER (object); | |
| 252 Charbpos begv, endv; | |
| 253 /* Figure out where we need to get info from */ | |
| 254 get_buffer_range_char (b, start, end, &begv, &endv, GB_ALLOW_NIL); | |
| 428 | 255 |
| 5137 | 256 instream = make_lisp_buffer_input_stream (b, begv, endv, 0); |
| 257 } | |
| 258 else | |
| 259 { | |
| 260 Bytecount bstart, bend; | |
| 261 CHECK_STRING (object); | |
| 262 get_string_range_byte (object, start, end, &bstart, &bend, | |
| 263 GB_HISTORICAL_STRING_BEHAVIOR); | |
| 264 instream = make_lisp_string_input_stream (object, bstart, bend); | |
| 265 } | |
| 266 istr = XLSTREAM (instream); | |
| 428 | 267 |
| 5137 | 268 /* Find out what format the buffer will be saved in, so we can make |
| 269 the digest based on what it will look like on disk */ | |
| 270 if (NILP (coding)) | |
| 271 { | |
| 272 if (BUFFERP (object)) | |
| 273 { | |
| 274 /* Use the file coding for this buffer by default */ | |
| 275 coding_system = XBUFFER (object)->buffer_file_coding_system; | |
| 276 } | |
| 277 else | |
| 278 { | |
| 279 /* attempt to autodetect the coding of the string. Note: this VERY hit-and-miss */ | |
| 280 enum eol_type eol = EOL_AUTODETECT; | |
| 281 coding_system = Fget_coding_system (Qundecided); | |
| 282 determine_real_coding_system (istr, &coding_system, &eol); | |
| 283 } | |
| 284 if (NILP (coding_system)) | |
| 285 coding_system = Fget_coding_system (Qbinary); | |
| 286 else | |
| 287 { | |
| 288 coding_system = Ffind_coding_system (coding_system); | |
| 289 if (NILP (coding_system)) | |
| 290 coding_system = Fget_coding_system (Qbinary); | |
| 291 } | |
| 292 } | |
| 293 else | |
| 294 { | |
| 295 coding_system = Ffind_coding_system (coding); | |
| 296 if (NILP (coding_system)) | |
| 428 | 297 { |
| 5137 | 298 if (NILP (error_me_not)) |
| 299 signal_simple_error ("No such coding system", coding); | |
| 300 else | |
| 301 coding_system = Fget_coding_system (Qbinary); /* default to binary */ | |
| 302 } | |
| 303 } | |
| 304 | |
| 305 /* setup the out stream */ | |
| 306 outstream = make_dynarr_output_stream ((unsigned_char_dynarr *)conversion_out_dynarr); | |
| 307 ostr = XLSTREAM (outstream); | |
| 308 deststream = make_dynarr_output_stream ((unsigned_char_dynarr *)out_dynarr); | |
| 309 dstr = XLSTREAM (deststream); | |
| 310 /* setup the conversion stream */ | |
| 311 conv_out_stream = make_encoding_output_stream (ostr, coding_system); | |
| 312 costr = XLSTREAM (conv_out_stream); | |
| 313 GCPRO3 (instream, outstream, conv_out_stream); | |
| 314 | |
| 315 /* Get the data while doing the conversion */ | |
| 316 while (1) | |
| 317 { | |
| 318 int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); | |
| 319 int l; | |
| 320 if (!size_in_bytes) | |
| 321 { | |
| 322 hit_eof = 1; | |
| 323 break; | |
| 324 } | |
| 325 /* It does seem the flushes are necessary... */ | |
| 326 Lstream_write (costr, tempbuf, size_in_bytes); | |
| 327 Lstream_flush (costr); | |
| 328 Lstream_flush (ostr); | |
| 329 | |
| 330 /* Update the base64 output buffer */ | |
| 331 for (l = 0; l < size_in_bytes; l++) | |
| 332 { | |
| 333 if (Dynarr_at (conversion_out_dynarr,l) == '=') | |
| 334 goto decoder_out; | |
| 335 bits += decoder[Dynarr_at (conversion_out_dynarr,l)]; | |
| 336 fprintf (stderr,"%d\n",bits); | |
| 337 char_count++; | |
| 338 if (char_count == 4) | |
| 428 | 339 { |
| 5137 | 340 static unsigned char obuf[3]; |
| 341 obuf[0] = (bits >> 16); | |
| 342 obuf[1] = (bits >> 8) & 0xff; | |
| 343 obuf[2] = (bits & 0xff); | |
| 344 | |
| 345 Lstream_write (dstr,obuf,sizeof (obuf)); | |
| 346 bits = char_count = 0; | |
| 428 | 347 } |
| 5137 | 348 else |
| 428 | 349 { |
| 5137 | 350 bits <<= 6; |
| 428 | 351 } |
| 352 } | |
| 5137 | 353 /* reset the dynarr */ |
| 354 Lstream_rewind (ostr); | |
| 355 } | |
| 356 decoder_out: | |
| 357 Lstream_close (istr); | |
| 358 Lstream_close (costr); | |
| 359 Lstream_close (ostr); | |
| 428 | 360 |
| 5137 | 361 if (hit_eof) |
| 362 { | |
| 363 if (char_count) | |
| 364 { | |
| 365 error_with_frob (object,"base64-decode failed: at least %d bits truncated",((4 - char_count) * 6)); | |
| 428 | 366 } |
| 5137 | 367 } |
| 368 switch (char_count) | |
| 369 { | |
| 370 case 1: | |
| 371 error_with_frob (object, "base64 encoding incomplete: at least 2 bits missing"); | |
| 372 break; | |
| 373 case 2: | |
| 374 char_count = bits >> 10; | |
| 375 Lstream_write (dstr,&char_count,sizeof (char_count)); | |
| 376 break; | |
| 377 case 3: | |
| 378 { | |
| 379 unsigned char buf[2]; | |
| 380 buf[0] = (bits >> 16); | |
| 381 buf[1] = (bits >> 8) & 0xff; | |
| 382 Lstream_write (dstr,buf,sizeof (buf)); | |
| 383 break; | |
| 384 } | |
| 385 } | |
| 428 | 386 |
| 5137 | 387 UNGCPRO; |
| 388 Lstream_delete (istr); | |
| 389 Lstream_delete (ostr); | |
| 390 Lstream_delete (costr); | |
| 391 Lstream_flush (dstr); | |
| 392 Lstream_delete (dstr); | |
| 428 | 393 |
| 5137 | 394 return (make_string (Dynarr_atp (out_dynarr,0),Dynarr_length (out_dynarr))); |
| 428 | 395 } |
| 396 | |
| 397 void | |
| 398 syms_of_base64 (void) | |
| 399 { | |
| 5137 | 400 DEFSUBR (Fbase64_encode); |
| 401 DEFSUBR (Fbase64_decode); | |
| 428 | 402 } |
| 403 | |
| 404 void | |
| 405 vars_of_base64 (void) | |
| 406 { | |
| 407 Fprovide (intern ("base64")); | |
| 408 } |