ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Convert-BER-XS/XS.xs
(Generate patch)

Comparing Convert-BER-XS/XS.xs (file contents):
Revision 1.26 by root, Sun Apr 21 10:42:22 2019 UTC vs.
Revision 1.34 by root, Thu Feb 6 11:51:40 2020 UTC

1#include "EXTERN.h" 1#include "EXTERN.h"
2#include "perl.h" 2#include "perl.h"
3#include "XSUB.h" 3#include "XSUB.h"
4
5#include <math.h>
4 6
5// C99 required! 7// C99 required!
6// this is not just for comments, but also for 8// this is not just for comments, but also for
7// integer constant semantics, 9// integer constant semantics,
8// sscanf format modifiers and more. 10// sscanf format modifiers and more.
… …
65 SNMP_TIMETICKS = 0x03, 67 SNMP_TIMETICKS = 0x03,
66 SNMP_OPAQUE = 0x04, 68 SNMP_OPAQUE = 0x04,
67 SNMP_COUNTER64 = 0x06, 69 SNMP_COUNTER64 = 0x06,
68}; 70};
69 71
72// low-level types this module can ecode the above (and more) into
70enum { 73enum {
71 BER_TYPE_BYTES, 74 BER_TYPE_BYTES,
72 BER_TYPE_UTF8, 75 BER_TYPE_UTF8,
73 BER_TYPE_UCS2, 76 BER_TYPE_UCS2,
74 BER_TYPE_UCS4, 77 BER_TYPE_UCS4,
… …
80 BER_TYPE_REAL, 83 BER_TYPE_REAL,
81 BER_TYPE_IPADDRESS, 84 BER_TYPE_IPADDRESS,
82 BER_TYPE_CROAK, 85 BER_TYPE_CROAK,
83}; 86};
84 87
88// tuple array indices
85enum { 89enum {
86 BER_CLASS = 0, 90 BER_CLASS = 0,
87 BER_TAG = 1, 91 BER_TAG = 1,
88 BER_FLAGS = 2, 92 BER_FLAGS = 2,
89 BER_DATA = 3, 93 BER_DATA = 3,
… …
98static SV *buf_sv; // encoding buffer 102static SV *buf_sv; // encoding buffer
99static U8 *buf, *cur, *end; // buffer start, current, end 103static U8 *buf, *cur, *end; // buffer start, current, end
100 104
101#if PERL_VERSION < 18 105#if PERL_VERSION < 18
102# define utf8_to_uvchr_buf(s,e,l) utf8_to_uvchr (s, l) 106# define utf8_to_uvchr_buf(s,e,l) utf8_to_uvchr (s, l)
107#endif
108
109#ifndef SvREFCNT_inc_NN
110#define SvREFCNT_inc_NN(x) SvREFCNT_inc (x)
111#endif
112#ifndef SvREFCNT_dec_NN
113#define SvREFCNT_dec_NN(x) SvREFCNT_dec (x)
103#endif 114#endif
104 115
105#if __GNUC__ >= 3 116#if __GNUC__ >= 3
106# define expect(expr,value) __builtin_expect ((expr), (value)) 117# define expect(expr,value) __builtin_expect ((expr), (value))
107# define INLINE static inline 118# define INLINE static inline
… …
256{ 267{
257 UV res = 0; 268 UV res = 0;
258 U8 c = get_u8 (); 269 U8 c = get_u8 ();
259 270
260 if (expect_false (c == 0x80)) 271 if (expect_false (c == 0x80))
261 error ("illegal BER padding (X.690 8.1.2.4.2, 8.19.2)"); 272 error ("invalid BER padding (X.690 8.1.2.4.2, 8.19.2)");
262 273
263 for (;;) 274 for (;;)
264 { 275 {
265 if (expect_false (res >> UVSIZE * 8 - 7)) 276 if (expect_false (res >> UVSIZE * 8 - 7))
266 error ("BER variable length integer overflow"); 277 error ("BER variable length integer overflow");
267 278
268 res = (res << 7) | (c & 0x7f); 279 res = (res << 7) | (c & 0x7f);
269 280
270 if (!(c & 0x80)) 281 if (expect_true (!(c & 0x80)))
271 return res; 282 return res;
272 283
273 c = get_u8 (); 284 c = get_u8 ();
274 } 285 }
275} 286}
… …
277static UV 288static UV
278get_length (void) 289get_length (void)
279{ 290{
280 UV res = get_u8 (); 291 UV res = get_u8 ();
281 292
282 if (res & 0x80) 293 if (expect_false (res & 0x80))
283 { 294 {
284 int cnt = res & 0x7f; 295 U8 cnt = res & 0x7f;
296
297 // this genewrates quite ugly code, but the overhead
298 // of copying the bytes for these lengths is probably so high
299 // that a slightly inefficient get_length won't matter.
300
301 if (expect_false (cnt == 0))
302 error ("invalid use of indefinite BER length form in primitive encoding (X.690 8.1.3.2)");
303
304 if (expect_false (cnt > UVSIZE))
305 error ("BER value length too long (must fit into UV) or BER reserved value in length (X.690 8.1.3.5)");
306
307 want (cnt);
308
285 res = 0; 309 res = 0;
286 310 do
287 switch (cnt) 311 res = (res << 8) | *cur++;
288 { 312 while (--cnt);
289 case 0:
290 error ("indefinite BER value lengths not supported");
291
292 case 0x7f:
293 error ("BER reserved value in length (X.690 8.1.3.5)");
294
295 default:
296 error ("BER value length too long (must fit into UV)");
297
298#if UVSIZE > 4
299 case 8: res = (res << 8) | get_u8 ();
300 case 7: res = (res << 8) | get_u8 ();
301 case 6: res = (res << 8) | get_u8 ();
302 case 5: res = (res << 8) | get_u8 ();
303#endif
304 case 4: res = (res << 8) | get_u8 ();
305 case 3: res = (res << 8) | get_u8 ();
306 case 2: res = (res << 8) | get_u8 ();
307 case 1: res = (res << 8) | get_u8 ();
308 }
309 } 313 }
310 314
311 return res; 315 return res;
312} 316}
313 317
314static SV * 318static SV *
315decode_int (void) 319decode_int (UV len)
316{ 320{
317 UV len = get_length ();
318
319 if (!len) 321 if (!len)
320 error ("invalid BER_TYPE_INT length zero (X.690 8.3.1)"); 322 error ("invalid BER_TYPE_INT length zero (X.690 8.3.1)");
321 323
322 U8 *data = get_n (len); 324 U8 *data = get_n (len);
323 325
324 if (expect_false (len > 1)) 326 if (expect_false (len > 1))
325 { 327 {
326 U16 mask = (data [0] << 8) | data [1] & 0xff80; 328 U16 mask = (data [0] << 8) | data [1] & 0xff80;
327 329
328 if (expect_false (mask == 0xff80 || mask == 0x0000)) 330 if (expect_false (mask == 0xff80 || mask == 0x0000))
329 error ("illegal padding in BER_TYPE_INT (X.690 8.3.2)"); 331 error ("invalid padding in BER_TYPE_INT (X.690 8.3.2)");
330 } 332 }
331 333
332 int negative = data [0] & 0x80; 334 int negative = data [0] & 0x80;
333 335
334 UV val = negative ? -1 : 0; // copy signbit to all bits 336 UV val = negative ? -1 : 0; // copy signbit to all bits
… …
344 // but that's ok, as perl relies on it as well. 346 // but that's ok, as perl relies on it as well.
345 return negative ? newSViv ((IV)val) : newSVuv (val); 347 return negative ? newSViv ((IV)val) : newSVuv (val);
346} 348}
347 349
348static SV * 350static SV *
349decode_data (void) 351decode_data (UV len)
350{ 352{
351 UV len = get_length ();
352 return newSVpvn ((char *)get_n (len), len); 353 return newSVpvn ((char *)get_n (len), len);
353} 354}
354 355
355// helper for decode_object_identifier 356// helper for decode_object_identifier
356static char * 357static char *
… …
384 385
385 return buf; 386 return buf;
386} 387}
387 388
388static SV * 389static SV *
389decode_oid (int relative) 390decode_oid (UV len, int relative)
390{ 391{
391 UV len = get_length ();
392
393 if (len <= 0) 392 if (len <= 0)
394 { 393 {
395 error ("BER_TYPE_OID length must not be zero"); 394 error ("BER_TYPE_OID length must not be zero");
396 return &PL_sv_undef; 395 return &PL_sv_undef;
397 } 396 }
… …
402 static char oid[MAX_OID_STRLEN]; // static, because too large for stack 401 static char oid[MAX_OID_STRLEN]; // static, because too large for stack
403 char *app = oid; 402 char *app = oid;
404 403
405 if (relative) 404 if (relative)
406 app = write_uv (app, w); 405 app = write_uv (app, w);
406 else
407 {
408 UV w1, w2;
409
407 else if (w < 2 * 40) 410 if (w < 2 * 40)
408 { 411 (w1 = w / 40), (w2 = w % 40);
412 else
413 (w1 = 2), (w2 = w - 2 * 40);
414
409 app = write_uv (app, (U8)w / 40); 415 app = write_uv (app, w1);
410 *app++ = '.'; 416 *app++ = '.';
411 app = write_uv (app, (U8)w % 40);
412 }
413 else
414 {
415 app = write_uv (app, 2); 417 app = write_uv (app, w2);
416 *app++ = '.';
417 app = write_uv (app, w - 2 * 40);
418 } 418 }
419 419
420 while (cur < end) 420 while (cur < end)
421 { 421 {
422 // we assume an oid component is never > 64 digits 422 // we assume an oid component is never > 64 digits
… …
429 } 429 }
430 430
431 return newSVpvn (oid, app - oid); 431 return newSVpvn (oid, app - oid);
432} 432}
433 433
434// oh my, this is a total mess
435static SV *
436decode_real (UV len)
437{
438 SV *res;
439 U8 *beg = cur;
440
441 if (len == 0)
442 res = newSVnv (0.);
443 else
444 {
445 U8 info = get_u8 ();
446
447 if (info & 0x80)
448 {
449 // binary
450 static const U8 base[] = { 2, 8, 16, 0 };
451 NV S = info & 0x40 ? -1 : 1; // sign
452 NV B = base [(info >> 4) & 3]; // base
453 NV F = 1 << ((info >> 2) & 3); // scale factor ("shift")
454 int L = info & 3; // exponent length
455
456 if (!B)
457 croak ("BER_TYPE_REAL binary encoding uses invalid base (0x%02x)", info);
458
459 SAVETMPS;
460
461 SV *E = sv_2mortal (decode_int (L == 3 ? get_u8 () : L + 1));
462 SV *M = sv_2mortal (decode_int (len - (cur - beg)));
463
464 res = newSVnv (S * SvNV (M) * F * Perl_pow (B, SvNV (E)));
465
466 FREETMPS;
467 }
468 else if (info & 0x40)
469 {
470 // SpecialRealValue
471 U8 special = get_u8 ();
472 NV val;
473
474 switch (special)
475 {
476 case 0x40: val = NV_INF; break;
477 case 0x41: val = -NV_INF; break;
478 case 0x42: val = NV_NAN; break;
479 case 0x43: val = -(NV)0.; break;
480
481 default:
482 croak ("BER_TYPE_REAL SpecialRealValues invalid encoding 0x%02x (X.690 8.5.9)", special);
483 }
484
485 res = newSVnv (val);
486 }
487 else
488 {
489 // decimal
490 dSP;
491 SAVETMPS;
492 PUSHMARK (SP);
493 EXTEND (SP, 2);
494 PUSHs (sv_2mortal (newSVcacheint (info & 0x3f)));
495 PUSHs (sv_2mortal (newSVpvn (get_n (len - 1), len - 1)));
496 PUTBACK;
497 call_pv ("Convert::BER::XS::_decode_real_decimal", G_SCALAR);
498 SPAGAIN;
499 res = SvREFCNT_inc_NN (POPs);
500 PUTBACK;
501 FREETMPS;
502 }
503 }
504
505 if (cur - beg != len)
506 {
507 SvREFCNT_dec_NN (res);
508 croak ("BER_TYPE_REAL invalid content length (X.690 8,5)");
509 }
510
511 return res;
512}
513
434// TODO: this is unacceptably slow 514// TODO: this is unacceptably slow
435static SV * 515static SV *
436decode_ucs (int chrsize) 516decode_ucs (UV len, int chrsize)
437{ 517{
438 SV *res = NEWSV (0, 0);
439
440 UV len = get_length ();
441
442 if (len & (chrsize - 1)) 518 if (len & (chrsize - 1))
443 croak ("BER_TYPE_UCS has an invalid number of octets (%d)", len); 519 croak ("BER_TYPE_UCS has an invalid number of octets (%d)", len);
520
521 SV *res = NEWSV (0, 0);
444 522
445 while (len) 523 while (len)
446 { 524 {
447 U8 b1 = get_u8 (); 525 U8 b1 = get_u8 ();
448 U8 b2 = get_u8 (); 526 U8 b2 = get_u8 ();
… …
481 if (tag == ASN_TAG_BER) 559 if (tag == ASN_TAG_BER)
482 tag = get_w (); 560 tag = get_w ();
483 561
484 if (constructed) 562 if (constructed)
485 { 563 {
564 want (1);
565 AV *av = (AV *)sv_2mortal ((SV *)newAV ());
566
567 if (expect_false (*cur == 0x80))
568 {
569 // indefinite length
570 ++cur;
571
572 for (;;)
573 {
574 want (2);
575 if (!cur [0] && !cur [1])
576 {
577 cur += 2;
578 break;
579 }
580
581 av_push (av, decode_ber ());
582 }
583 }
584 else
585 {
586 UV len = get_length ();
587 UV seqend = (cur - buf) + len;
588
589 while (cur < buf + seqend)
590 av_push (av, decode_ber ());
591
592 if (expect_false (cur > buf + seqend))
593 croak ("CONSTRUCTED type %02x length overflow (0x%x 0x%x)\n", identifier, (int)(cur - buf), (int)seqend);
594 }
595
596 res = newRV_inc ((SV *)av);
597 }
598 else
599 {
486 UV len = get_length (); 600 UV len = get_length ();
487 UV seqend = (cur - buf) + len;
488 AV *av = (AV *)sv_2mortal ((SV *)newAV ());
489 601
490 while (cur < buf + seqend)
491 av_push (av, decode_ber ());
492
493 if (cur > buf + seqend)
494 croak ("CONSTRUCTED type %02x length overflow (0x%x 0x%x)\n", identifier, (int)(cur - buf), (int)seqend);
495
496 res = newRV_inc ((SV *)av);
497 }
498 else
499 switch (profile_lookup (cur_profile, klass, tag)) 602 switch (profile_lookup (cur_profile, klass, tag))
500 { 603 {
501 case BER_TYPE_NULL: 604 case BER_TYPE_NULL:
502 { 605 if (expect_false (len))
503 UV len = get_length ();
504
505 if (len)
506 croak ("BER_TYPE_NULL value with non-zero length %d encountered (X.690 8.8.2)", len); 606 croak ("BER_TYPE_NULL value with non-zero length %d encountered (X.690 8.8.2)", len);
507 607
508 res = &PL_sv_undef; 608 res = &PL_sv_undef;
509 }
510 break; 609 break;
511 610
512 case BER_TYPE_BOOL: 611 case BER_TYPE_BOOL:
513 {
514 UV len = get_length ();
515
516 if (len != 1) 612 if (expect_false (len != 1))
517 croak ("BER_TYPE_BOOLEAN value with invalid length %d encountered (X.690 8.2.1)", len); 613 croak ("BER_TYPE_BOOLEAN value with invalid length %d encountered (X.690 8.2.1)", len);
518 614
519 res = newSVcacheint (!!get_u8 ()); 615 res = newSVcacheint (!!get_u8 ());
520 }
521 break; 616 break;
522 617
523 case BER_TYPE_OID: 618 case BER_TYPE_OID:
524 res = decode_oid (0); 619 res = decode_oid (len, 0);
525 break; 620 break;
526 621
527 case BER_TYPE_RELOID: 622 case BER_TYPE_RELOID:
528 res = decode_oid (1); 623 res = decode_oid (len, 1);
529 break; 624 break;
530 625
531 case BER_TYPE_INT: 626 case BER_TYPE_INT:
532 res = decode_int (); 627 res = decode_int (len);
533 break; 628 break;
534 629
535 case BER_TYPE_UTF8: 630 case BER_TYPE_UTF8:
536 res = decode_data (); 631 res = decode_data (len);
537 SvUTF8_on (res); 632 SvUTF8_on (res);
538 break; 633 break;
539 634
540 case BER_TYPE_BYTES: 635 case BER_TYPE_BYTES:
541 res = decode_data (); 636 res = decode_data (len);
542 break; 637 break;
543 638
544 case BER_TYPE_IPADDRESS: 639 case BER_TYPE_IPADDRESS:
545 { 640 {
546 UV len = get_length ();
547
548 if (len != 4) 641 if (len != 4)
549 croak ("BER_TYPE_IPADDRESS type with invalid length %d encountered (RFC 2578 7.1.5)", len); 642 croak ("BER_TYPE_IPADDRESS type with invalid length %d encountered (RFC 2578 7.1.5)", len);
550 643
551 U8 c1 = get_u8 (); 644 U8 *data = get_n (4);
552 U8 c2 = get_u8 (); 645 res = newSVpvf ("%d.%d.%d.%d", data [0], data [1], data [2], data [3]);
553 U8 c3 = get_u8 ();
554 U8 c4 = get_u8 ();
555
556 res = newSVpvf ("%d.%d.%d.%d", c1, c2, c3, c4);
557 } 646 }
558 break; 647 break;
559 648
560 case BER_TYPE_UCS2: 649 case BER_TYPE_UCS2:
561 res = decode_ucs (2); 650 res = decode_ucs (len, 2);
562 break; 651 break;
563 652
564 case BER_TYPE_UCS4: 653 case BER_TYPE_UCS4:
565 res = decode_ucs (4); 654 res = decode_ucs (len, 4);
566 break; 655 break;
567 656
568 case BER_TYPE_REAL: 657 case BER_TYPE_REAL:
569 error ("BER_TYPE_REAL not implemented"); 658 res = decode_real (len);
659 break;
570 660
571 case BER_TYPE_CROAK: 661 case BER_TYPE_CROAK:
572 croak ("class/tag %d/%d mapped to BER_TYPE_CROAK", klass, tag); 662 croak ("class/tag %d/%d mapped to BER_TYPE_CROAK", klass, tag);
573 663
574 default: 664 default:
575 croak ("unconfigured/unsupported class/tag %d/%d", klass, tag); 665 croak ("unconfigured/unsupported class/tag %d/%d", klass, tag);
576 } 666 }
667 }
577 668
578 AV *av = newAV (); 669 AV *av = newAV ();
579 av_fill (av, BER_ARRAYSIZE - 1); 670 av_fill (av, BER_ARRAYSIZE - 1);
580 AvARRAY (av)[BER_CLASS] = newSVcacheint (klass); 671 AvARRAY (av)[BER_CLASS] = newSVcacheint (klass);
581 AvARRAY (av)[BER_TAG ] = newSVcacheint (tag); 672 AvARRAY (av)[BER_TAG ] = newSVcacheint (tag);
… …
668} 759}
669 760
670static U8 * 761static U8 *
671put_length_at (UV val, U8 *cur) 762put_length_at (UV val, U8 *cur)
672{ 763{
673 if (val < 0x7fU) 764 if (val <= 0x7fU)
674 *cur++ = val; 765 *cur++ = val;
675 else 766 else
676 { 767 {
677 U8 *lenb = cur++; 768 U8 *lenb = cur++;
678 769
679#if UVSIZE > 4 770#if UVSIZE > 4
680 *cur = val >> 56; cur += *cur > 0; 771 *cur = val >> 56; cur += val >= ((UV)1 << (8 * 7));
681 *cur = val >> 48; cur += *cur > 0; 772 *cur = val >> 48; cur += val >= ((UV)1 << (8 * 6));
682 *cur = val >> 40; cur += *cur > 0; 773 *cur = val >> 40; cur += val >= ((UV)1 << (8 * 5));
683 *cur = val >> 32; cur += *cur > 0; 774 *cur = val >> 32; cur += val >= ((UV)1 << (8 * 4));
684#endif 775#endif
685 *cur = val >> 24; cur += *cur > 0; 776 *cur = val >> 24; cur += val >= ((UV)1 << (8 * 3));
686 *cur = val >> 16; cur += *cur > 0; 777 *cur = val >> 16; cur += val >= ((UV)1 << (8 * 2));
687 *cur = val >> 8; cur += *cur > 0; 778 *cur = val >> 8; cur += val >= ((UV)1 << (8 * 1));
688 *cur = val ; cur += 1; 779 *cur = val ; cur += 1;
689 780
690 *lenb = 0x80 + cur - lenb - 1; 781 *lenb = 0x80 + cur - lenb - 1;
691 } 782 }
692 783
… …
694} 785}
695 786
696static void 787static void
697put_length (UV val) 788put_length (UV val)
698{ 789{
699 need (5 + val); 790 need (9 + val);
700 cur = put_length_at (val, cur); 791 cur = put_length_at (val, cur);
701} 792}
702 793
703// return how many bytes the encoded length requires 794// return how many bytes the encoded length requires
704static int length_length (UV val) 795static int length_length (UV val)
705{ 796{
706 return val < 0x7fU 797 // use hashing with a DeBruin sequence, anyone?
798 return expect_true (val <= 0x7fU)
707 ? 1 799 ? 1
708 : 2 800 : 2
709 + (val > 0xffU) 801 + (val > 0x000000000000ffU)
710 + (val > 0xffffU) 802 + (val > 0x0000000000ffffU)
711 + (val > 0xffffffU) 803 + (val > 0x00000000ffffffU)
712#if UVSIZE > 4 804#if UVSIZE > 4
713 + (val > 0xffffffffU) 805 + (val > 0x000000ffffffffU)
714 + (val > 0xffffffffffU) 806 + (val > 0x0000ffffffffffU)
715 + (val > 0xffffffffffffU) 807 + (val > 0x00ffffffffffffU)
716 + (val > 0xffffffffffffffU) 808 + (val > 0xffffffffffffffU)
717#endif 809#endif
718 ; 810 ;
719} 811}
720 812
… …
856 } 948 }
857 949
858 len_fixup (mark); 950 len_fixup (mark);
859} 951}
860 952
861// check whether an SV is a BER tuple and returns its AV * 953static void
862static AV * 954encode_real (SV *data)
863ber_tuple (SV *tuple)
864{ 955{
865 SV *rv; 956 NV nv = SvNV (data);
866 957
867 if (expect_false (!SvROK (tuple) || SvTYPE ((rv = SvRV (tuple))) != SVt_PVAV)) 958 if (expect_false (nv == (NV)0.))
868 croak ("BER tuple must be array-reference"); 959 {
960 if (signbit (nv))
961 {
962 // negative zero
963 need (3);
964 *cur++ = 2;
965 *cur++ = 0x40;
966 *cur++ = 0x43;
967 }
968 else
969 {
970 // positive zero
971 need (1);
972 *cur++ = 0;
973 }
974 }
975 else if (expect_false (Perl_isinf (nv)))
976 {
977 need (3);
978 *cur++ = 2;
979 *cur++ = 0x40;
980 *cur++ = nv < (NV)0. ? 0x41 : 0x40;
981 }
982 else if (expect_false (Perl_isnan (nv)))
983 {
984 need (3);
985 *cur++ = 2;
986 *cur++ = 0x40;
987 *cur++ = 0x42;
988 }
989 else
990 {
991 // use decimal encoding
992 dSP;
993 SAVETMPS;
994 PUSHMARK (SP);
995 EXTEND (SP, 2);
996 PUSHs (data);
997 PUSHs (sv_2mortal (newSVcacheint (NV_DIG)));
998 PUTBACK;
999 call_pv ("Convert::BER::XS::_encode_real_decimal", G_SCALAR);
1000 SPAGAIN;
869 1001
870 if (expect_false (SvRMAGICAL (rv))) 1002 SV *sv = POPs;
871 croak ("BER tuple must not be tied"); 1003 STRLEN l;
1004 char *f = SvPV (sv, l);
872 1005
873 if (expect_false (AvFILL ((AV *)rv) != BER_ARRAYSIZE - 1)) 1006 put_length (l);
874 croak ("BER tuple must contain exactly %d elements, not %d", BER_ARRAYSIZE, AvFILL ((AV *)rv) + 1); 1007 memcpy (cur, f, l);
1008 cur += l;
875 1009
876 return (AV *)rv; 1010 PUTBACK;
1011 FREETMPS;
1012 }
877} 1013}
878 1014
879static void 1015static void
880encode_ucs (SV *data, int chrsize) 1016encode_ucs (SV *data, int chrsize)
881{ 1017{
… …
901 1037
902 *cur++ = uchr >> 8; 1038 *cur++ = uchr >> 8;
903 *cur++ = uchr; 1039 *cur++ = uchr;
904 } 1040 }
905} 1041}
1042
1043// check whether an SV is a BER tuple and returns its AV *
1044static AV *
1045ber_tuple (SV *tuple)
1046{
1047 SV *rv;
1048
1049 if (expect_false (!SvROK (tuple) || SvTYPE ((rv = SvRV (tuple))) != SVt_PVAV))
1050 croak ("BER tuple must be array-reference");
1051
1052 if (expect_false (SvRMAGICAL (rv)))
1053 croak ("BER tuple must not be tied");
1054
1055 if (expect_false (AvFILL ((AV *)rv) != BER_ARRAYSIZE - 1))
1056 croak ("BER tuple must contain exactly %d elements, not %d", BER_ARRAYSIZE, AvFILL ((AV *)rv) + 1);
1057
1058 return (AV *)rv;
1059}
1060
906static void 1061static void
907encode_ber (SV *tuple) 1062encode_ber (SV *tuple)
908{ 1063{
909 AV *av = ber_tuple (tuple); 1064 AV *av = ber_tuple (tuple);
910 1065
… …
1000 case BER_TYPE_UCS4: 1155 case BER_TYPE_UCS4:
1001 encode_ucs (data, 4); 1156 encode_ucs (data, 4);
1002 break; 1157 break;
1003 1158
1004 case BER_TYPE_REAL: 1159 case BER_TYPE_REAL:
1005 croak ("BER_TYPE_REAL not implemented"); 1160 encode_real (data);
1161 break;
1006 1162
1007 case BER_TYPE_CROAK: 1163 case BER_TYPE_CROAK:
1008 croak ("class/tag %d/%d mapped to BER_TYPE_CROAK", klass, tag); 1164 croak ("class/tag %d/%d mapped to BER_TYPE_CROAK", klass, tag);
1009 1165
1010 default: 1166 default:
… …
1109 STRLEN len; 1265 STRLEN len;
1110 buf = (U8 *)SvPVbyte (ber, len); 1266 buf = (U8 *)SvPVbyte (ber, len);
1111 cur = buf; 1267 cur = buf;
1112 end = buf + len; 1268 end = buf + len;
1113 1269
1270 PUTBACK;
1114 SV *tuple = decode_ber (); 1271 SV *tuple = decode_ber ();
1272 SPAGAIN;
1115 1273
1116 EXTEND (SP, 2); 1274 EXTEND (SP, 2);
1117 PUSHs (sv_2mortal (tuple)); 1275 PUSHs (sv_2mortal (tuple));
1118 1276
1119 if (ix) 1277 if (ix)
… …
1204 cur_profile = SvPROFILE (profile); 1362 cur_profile = SvPROFILE (profile);
1205 buf_sv = sv_2mortal (NEWSV (0, 256)); 1363 buf_sv = sv_2mortal (NEWSV (0, 256));
1206 SvPOK_only (buf_sv); 1364 SvPOK_only (buf_sv);
1207 set_buf (buf_sv); 1365 set_buf (buf_sv);
1208 1366
1367 PUTBACK;
1209 encode_ber (tuple); 1368 encode_ber (tuple);
1369 SPAGAIN;
1210 1370
1211 SvCUR_set (buf_sv, cur - buf); 1371 SvCUR_set (buf_sv, cur - buf);
1212 XPUSHs (buf_sv); 1372 XPUSHs (buf_sv);
1213} 1373}
1214 1374

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines