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.29 by root, Tue Apr 23 19:44:12 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");
… …
286 // this genewrates quite ugly code, but the overhead 297 // this genewrates quite ugly code, but the overhead
287 // of copying the bytes for these lengths is probably so high 298 // of copying the bytes for these lengths is probably so high
288 // that a slightly inefficient get_length won't matter. 299 // that a slightly inefficient get_length won't matter.
289 300
290 if (expect_false (cnt == 0)) 301 if (expect_false (cnt == 0))
291 error ("indefinite BER value lengths not supported"); 302 error ("invalid use of indefinite BER length form in primitive encoding (X.690 8.1.3.2)");
292 303
293 if (expect_false (cnt > UVSIZE)) 304 if (expect_false (cnt > UVSIZE))
294 error ("BER value length too long (must fit into UV) or BER reserved value in length (X.690 8.1.3.5)"); 305 error ("BER value length too long (must fit into UV) or BER reserved value in length (X.690 8.1.3.5)");
295 306
296 want (cnt); 307 want (cnt);
… …
303 314
304 return res; 315 return res;
305} 316}
306 317
307static SV * 318static SV *
308decode_int (void) 319decode_int (UV len)
309{ 320{
310 UV len = get_length ();
311
312 if (!len) 321 if (!len)
313 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)");
314 323
315 U8 *data = get_n (len); 324 U8 *data = get_n (len);
316 325
317 if (expect_false (len > 1)) 326 if (expect_false (len > 1))
318 { 327 {
319 U16 mask = (data [0] << 8) | data [1] & 0xff80; 328 U16 mask = (data [0] << 8) | data [1] & 0xff80;
320 329
321 if (expect_false (mask == 0xff80 || mask == 0x0000)) 330 if (expect_false (mask == 0xff80 || mask == 0x0000))
322 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)");
323 } 332 }
324 333
325 int negative = data [0] & 0x80; 334 int negative = data [0] & 0x80;
326 335
327 UV val = negative ? -1 : 0; // copy signbit to all bits 336 UV val = negative ? -1 : 0; // copy signbit to all bits
… …
337 // but that's ok, as perl relies on it as well. 346 // but that's ok, as perl relies on it as well.
338 return negative ? newSViv ((IV)val) : newSVuv (val); 347 return negative ? newSViv ((IV)val) : newSVuv (val);
339} 348}
340 349
341static SV * 350static SV *
342decode_data (void) 351decode_data (UV len)
343{ 352{
344 UV len = get_length ();
345 return newSVpvn ((char *)get_n (len), len); 353 return newSVpvn ((char *)get_n (len), len);
346} 354}
347 355
348// helper for decode_object_identifier 356// helper for decode_object_identifier
349static char * 357static char *
… …
377 385
378 return buf; 386 return buf;
379} 387}
380 388
381static SV * 389static SV *
382decode_oid (int relative) 390decode_oid (UV len, int relative)
383{ 391{
384 UV len = get_length ();
385
386 if (len <= 0) 392 if (len <= 0)
387 { 393 {
388 error ("BER_TYPE_OID length must not be zero"); 394 error ("BER_TYPE_OID length must not be zero");
389 return &PL_sv_undef; 395 return &PL_sv_undef;
390 } 396 }
… …
423 } 429 }
424 430
425 return newSVpvn (oid, app - oid); 431 return newSVpvn (oid, app - oid);
426} 432}
427 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
428// TODO: this is unacceptably slow 514// TODO: this is unacceptably slow
429static SV * 515static SV *
430decode_ucs (int chrsize) 516decode_ucs (UV len, int chrsize)
431{ 517{
432 SV *res = NEWSV (0, 0);
433
434 UV len = get_length ();
435
436 if (len & (chrsize - 1)) 518 if (len & (chrsize - 1))
437 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);
438 522
439 while (len) 523 while (len)
440 { 524 {
441 U8 b1 = get_u8 (); 525 U8 b1 = get_u8 ();
442 U8 b2 = get_u8 (); 526 U8 b2 = get_u8 ();
… …
475 if (tag == ASN_TAG_BER) 559 if (tag == ASN_TAG_BER)
476 tag = get_w (); 560 tag = get_w ();
477 561
478 if (constructed) 562 if (constructed)
479 { 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 {
480 UV len = get_length (); 600 UV len = get_length ();
481 UV seqend = (cur - buf) + len;
482 AV *av = (AV *)sv_2mortal ((SV *)newAV ());
483 601
484 while (cur < buf + seqend)
485 av_push (av, decode_ber ());
486
487 if (cur > buf + seqend)
488 croak ("CONSTRUCTED type %02x length overflow (0x%x 0x%x)\n", identifier, (int)(cur - buf), (int)seqend);
489
490 res = newRV_inc ((SV *)av);
491 }
492 else
493 switch (profile_lookup (cur_profile, klass, tag)) 602 switch (profile_lookup (cur_profile, klass, tag))
494 { 603 {
495 case BER_TYPE_NULL: 604 case BER_TYPE_NULL:
496 { 605 if (expect_false (len))
497 UV len = get_length ();
498
499 if (len)
500 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);
501 607
502 res = &PL_sv_undef; 608 res = &PL_sv_undef;
503 }
504 break; 609 break;
505 610
506 case BER_TYPE_BOOL: 611 case BER_TYPE_BOOL:
507 {
508 UV len = get_length ();
509
510 if (len != 1) 612 if (expect_false (len != 1))
511 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);
512 614
513 res = newSVcacheint (!!get_u8 ()); 615 res = newSVcacheint (!!get_u8 ());
514 }
515 break; 616 break;
516 617
517 case BER_TYPE_OID: 618 case BER_TYPE_OID:
518 res = decode_oid (0); 619 res = decode_oid (len, 0);
519 break; 620 break;
520 621
521 case BER_TYPE_RELOID: 622 case BER_TYPE_RELOID:
522 res = decode_oid (1); 623 res = decode_oid (len, 1);
523 break; 624 break;
524 625
525 case BER_TYPE_INT: 626 case BER_TYPE_INT:
526 res = decode_int (); 627 res = decode_int (len);
527 break; 628 break;
528 629
529 case BER_TYPE_UTF8: 630 case BER_TYPE_UTF8:
530 res = decode_data (); 631 res = decode_data (len);
531 SvUTF8_on (res); 632 SvUTF8_on (res);
532 break; 633 break;
533 634
534 case BER_TYPE_BYTES: 635 case BER_TYPE_BYTES:
535 res = decode_data (); 636 res = decode_data (len);
536 break; 637 break;
537 638
538 case BER_TYPE_IPADDRESS: 639 case BER_TYPE_IPADDRESS:
539 { 640 {
540 UV len = get_length ();
541
542 if (len != 4) 641 if (len != 4)
543 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);
544 643
545 U8 *data = get_n (4); 644 U8 *data = get_n (4);
546 res = newSVpvf ("%d.%d.%d.%d", data [0], data [1], data [2], data [3]); 645 res = newSVpvf ("%d.%d.%d.%d", data [0], data [1], data [2], data [3]);
547 } 646 }
548 break; 647 break;
549 648
550 case BER_TYPE_UCS2: 649 case BER_TYPE_UCS2:
551 res = decode_ucs (2); 650 res = decode_ucs (len, 2);
552 break; 651 break;
553 652
554 case BER_TYPE_UCS4: 653 case BER_TYPE_UCS4:
555 res = decode_ucs (4); 654 res = decode_ucs (len, 4);
556 break; 655 break;
557 656
558 case BER_TYPE_REAL: 657 case BER_TYPE_REAL:
559 error ("BER_TYPE_REAL not implemented"); 658 res = decode_real (len);
659 break;
560 660
561 case BER_TYPE_CROAK: 661 case BER_TYPE_CROAK:
562 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);
563 663
564 default: 664 default:
565 croak ("unconfigured/unsupported class/tag %d/%d", klass, tag); 665 croak ("unconfigured/unsupported class/tag %d/%d", klass, tag);
566 } 666 }
667 }
567 668
568 AV *av = newAV (); 669 AV *av = newAV ();
569 av_fill (av, BER_ARRAYSIZE - 1); 670 av_fill (av, BER_ARRAYSIZE - 1);
570 AvARRAY (av)[BER_CLASS] = newSVcacheint (klass); 671 AvARRAY (av)[BER_CLASS] = newSVcacheint (klass);
571 AvARRAY (av)[BER_TAG ] = newSVcacheint (tag); 672 AvARRAY (av)[BER_TAG ] = newSVcacheint (tag);
… …
847 } 948 }
848 949
849 len_fixup (mark); 950 len_fixup (mark);
850} 951}
851 952
852// check whether an SV is a BER tuple and returns its AV * 953static void
853static AV * 954encode_real (SV *data)
854ber_tuple (SV *tuple)
855{ 955{
856 SV *rv; 956 NV nv = SvNV (data);
857 957
858 if (expect_false (!SvROK (tuple) || SvTYPE ((rv = SvRV (tuple))) != SVt_PVAV)) 958 if (expect_false (nv == (NV)0.))
859 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;
860 1001
861 if (expect_false (SvRMAGICAL (rv))) 1002 SV *sv = POPs;
862 croak ("BER tuple must not be tied"); 1003 STRLEN l;
1004 char *f = SvPV (sv, l);
863 1005
864 if (expect_false (AvFILL ((AV *)rv) != BER_ARRAYSIZE - 1)) 1006 put_length (l);
865 croak ("BER tuple must contain exactly %d elements, not %d", BER_ARRAYSIZE, AvFILL ((AV *)rv) + 1); 1007 memcpy (cur, f, l);
1008 cur += l;
866 1009
867 return (AV *)rv; 1010 PUTBACK;
1011 FREETMPS;
1012 }
868} 1013}
869 1014
870static void 1015static void
871encode_ucs (SV *data, int chrsize) 1016encode_ucs (SV *data, int chrsize)
872{ 1017{
… …
892 1037
893 *cur++ = uchr >> 8; 1038 *cur++ = uchr >> 8;
894 *cur++ = uchr; 1039 *cur++ = uchr;
895 } 1040 }
896} 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
897static void 1061static void
898encode_ber (SV *tuple) 1062encode_ber (SV *tuple)
899{ 1063{
900 AV *av = ber_tuple (tuple); 1064 AV *av = ber_tuple (tuple);
901 1065
… …
991 case BER_TYPE_UCS4: 1155 case BER_TYPE_UCS4:
992 encode_ucs (data, 4); 1156 encode_ucs (data, 4);
993 break; 1157 break;
994 1158
995 case BER_TYPE_REAL: 1159 case BER_TYPE_REAL:
996 croak ("BER_TYPE_REAL not implemented"); 1160 encode_real (data);
1161 break;
997 1162
998 case BER_TYPE_CROAK: 1163 case BER_TYPE_CROAK:
999 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);
1000 1165
1001 default: 1166 default:
… …
1100 STRLEN len; 1265 STRLEN len;
1101 buf = (U8 *)SvPVbyte (ber, len); 1266 buf = (U8 *)SvPVbyte (ber, len);
1102 cur = buf; 1267 cur = buf;
1103 end = buf + len; 1268 end = buf + len;
1104 1269
1270 PUTBACK;
1105 SV *tuple = decode_ber (); 1271 SV *tuple = decode_ber ();
1272 SPAGAIN;
1106 1273
1107 EXTEND (SP, 2); 1274 EXTEND (SP, 2);
1108 PUSHs (sv_2mortal (tuple)); 1275 PUSHs (sv_2mortal (tuple));
1109 1276
1110 if (ix) 1277 if (ix)
… …
1195 cur_profile = SvPROFILE (profile); 1362 cur_profile = SvPROFILE (profile);
1196 buf_sv = sv_2mortal (NEWSV (0, 256)); 1363 buf_sv = sv_2mortal (NEWSV (0, 256));
1197 SvPOK_only (buf_sv); 1364 SvPOK_only (buf_sv);
1198 set_buf (buf_sv); 1365 set_buf (buf_sv);
1199 1366
1367 PUTBACK;
1200 encode_ber (tuple); 1368 encode_ber (tuple);
1369 SPAGAIN;
1201 1370
1202 SvCUR_set (buf_sv, cur - buf); 1371 SvCUR_set (buf_sv, cur - buf);
1203 XPUSHs (buf_sv); 1372 XPUSHs (buf_sv);
1204} 1373}
1205 1374

Diff Legend

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