Convert-BER-XS/XS.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

// C99 required

enum {
  // ASN_TAG
  ASN_BOOLEAN           = 0x01,
  ASN_INTEGER32         = 0x02,
  ASN_BIT_STRING        = 0x03,
  ASN_OCTET_STRING      = 0x04,
  ASN_NULL              = 0x05,
  ASN_OBJECT_IDENTIFIER = 0x06,
  ASN_OID               = 0x06, //X
  ASN_OBJECT_DESCRIPTOR = 0x07, //X
  ASN_EXTERNAL          = 0x08, //X
  ASN_REAL              = 0x09, //X
  ASN_ENUMERATED        = 0x0a, //X
  ASN_EMBEDDED_PDV      = 0x0b, //X
  ASN_UTF8_STRING       = 0x0c, //X
  ASN_RELATIVE_OID      = 0x0d, //X
  ASN_SEQUENCE          = 0x10,
  ASN_SET               = 0x11, //X
  ASN_NUMERIC_STRING    = 0x12, //X
  ASN_PRINTABLE_STRING  = 0x13, //X
  ASN_TELETEX_STRING    = 0x14, //X
  ASN_T61_STRING        = 0x14, //X
  ASN_VIDEOTEX_STRING   = 0x15, //X
  ASN_IA5_STRING        = 0x16, //X
  ASN_ASCII_STRING      = 0x16, //X
  ASN_UTC_TIME          = 0x17, //X
  ASN_GENERALIZED_TIME  = 0x18, //X
  ASN_GRAPHIC_STRING    = 0x19, //X
  ASN_VISIBLE_STRING    = 0x1a, //X
  ASN_ISO646_STRING     = 0x1a, //X
  ASN_GENERAL_STRING    = 0x1b, //X
  ASN_UNIVERSAL_STRING  = 0x1c, //X
  ASN_CHARACTER_STRING  = 0x1d, //X
  ASN_BMPSTRING         = 0x1e, //X

  ASN_TAG_BER           = 0x1f,
  ASN_TAG_MASK          = 0x1f,

  // primitive/constructed
  ASN_CONSTRUCTED       = 0x20,

  // ASN_CLASS
  ASN_UNIVERSAL         = 0x00,
  ASN_APPLICATION       = 0x40,
  ASN_CONTEXT           = 0x80,
  ASN_PRIVATE           = 0xc0,

  ASN_CLASS_MASK        = 0xc0,
  ASN_CLASS_SHIFT       = 6,

  // ASN_APPLICATION SNMP
  SNMP_IPADDRESS         = 0x00,
  SNMP_COUNTER32         = 0x01,
  SNMP_UNSIGNED32        = 0x02,
  SNMP_TIMETICKS         = 0x03,
  SNMP_OPAQUE            = 0x04,
  SNMP_COUNTER64         = 0x06,
};

enum {
  BER_CLASS       = 0,
  BER_TAG         = 1,
  BER_CONSTRUCTED = 2,
  BER_DATA        = 3,
  BER_ARRAYSIZE
};

#define MAX_OID_STRLEN 4096

static SV *buf_sv; // encoding buffer
static U8 *buf, *cur, *end; // buffer start, current, end

#if __GNUC__ >= 3
# define expect(expr,value)         __builtin_expect ((expr), (value))
# define INLINE                     static inline
#else
# define expect(expr,value)         (expr)
# define INLINE                     static
#endif

#define expect_false(expr) expect ((expr) != 0, 0)
#define expect_true(expr)  expect ((expr) != 0, 1)

// for "small" integers, return a readonly sv, otherwise create a new one
static SV *newSVcacheint (int val)
{
  static SV *cache[32];

  if (expect_false (val < 0 || val >= sizeof (cache)))
    return newSViv (val);

  if (expect_false (!cache [val]))
    {
      cache [val] = newSVuv (val);
      SvREADONLY_on (cache [val]);
    }

  return SvREFCNT_inc_NN (cache [val]);
}

/////////////////////////////////////////////////////////////////////////////
// decoder

static void
error (const char *errmsg)
{
  croak ("%s at offset 0x%04x", errmsg, cur - buf);
}

static void
want (UV count)
{
  if (expect_false ((uintptr_t)(end - cur) < count))
    error ("unexpected end of message buffer");
}

// get_* functions fetch something from the buffer
// decode_* functions use get_* fun ctions to decode ber values

// get n octets
static U8 *
get_n (UV count)
{
  want (count);
  U8 *res = cur;
  cur += count;
  return res;
}

// get single octet
static U8
get_u8 (void)
{
  if (cur == end)
    error ("unexpected end of message buffer");

  return *cur++;
}

// get ber-encoded integer (i.e. pack "w")
static U32
get_w (void)
{
  U32 res = 0;

  for (;;)
    {
      U8 c = get_u8 ();
      res = (res << 7) | (c & 0x7f);

      if (!(c & 0x80))
        return res;
    }
}

static U32
get_length (void)
{
  U32 res = get_u8 ();

  if (res & 0x80)
    {
      int cnt = res & 0x7f;
      res = 0;

      switch (cnt)
        {
          case 0:
            error ("indefinite ASN.1 lengths not supported");
            return 0;

          default:
            error ("ASN.1 length too long");
            return 0;

          case 4: res = (res << 8) | get_u8 ();
          case 3: res = (res << 8) | get_u8 ();
          case 2: res = (res << 8) | get_u8 ();
          case 1: res = (res << 8) | get_u8 ();
        }
    }

  return res;
}

static U32
get_integer32 (void)
{
  U32 length = get_length ();

  if (length <= 0)
    {
      error ("INTEGER32 length equal to zero");
      return 0;
    }

  U8 *data = get_n (length);

  if (length > 5 || (length > 4 && data [0]))
    {
      error ("INTEGER32 length too long");
      return 0;
    }

  U32 res = data [0] & 0x80 ? 0xffffffff : 0;

  while (length--)
    res = (res << 8) | *data++;

  return res;
}

static SV *
decode_integer32 (void)
{
  return newSViv ((I32)get_integer32 ());
}

static SV *
decode_unsigned32 (void)
{
  return newSVuv ((U32)get_integer32 ());
}

#if IVSIZE >= 8

static U64TYPE
get_integer64 (void)
{
  U32 length = get_length ();

  if (length <= 0)
    {
      error ("INTEGER64 length equal to zero");
      return 0;
    }

  U8 *data = get_n (length);

  if (length > 9 || (length > 8 && data [0]))
    {
      error ("INTEGER64 length too long");
      return 0;
    }

  U64TYPE res = data [0] & 0x80 ? 0xffffffffffffffff : 0;

  while (length--)
    res = (res << 8) | *data++;

  return res;
}

static SV *
decode_integer64 (void)
{
  return newSViv ((I64TYPE)get_integer64 ());
}

static SV *
decode_unsigned64 (void)
{
  return newSVuv ((U64TYPE)get_integer64 ());
}

#endif

static SV *
decode_octet_string (void)
{
  U32 length = get_length ();
  U8 *data = get_n (length);
  return newSVpvn (data, length);
}

// gelper for decode_object_identifier
static char *
write_uv (char *buf, U32 u)
{
  // the one-digit case is absolutely predominant, so this pays off (hopefully)
  if (u < 10)
    *buf++ = u + '0';
  else
    {
      char *beg = buf;

      do
        {
          *buf++ = u % 10 + '0';
          u /= 10;
        }
      while (u);

      // reverse digits
      for (char *ptr = buf; --ptr != beg; ++beg)
        {
          char c = *ptr;
          *ptr = *beg;
          *beg = c;
        }
    }

  return buf;
}

static SV *
decode_object_identifier (void)
{
  U32 length = get_length ();

  if (length <= 0)
    {
      error ("OBJECT IDENTIFIER length equal to zero");
      return &PL_sv_undef;
    }

  U8 *end = cur + length;
  U32 w = get_w ();

  static char oid[MAX_OID_STRLEN]; // must be static
  char *app = oid;

  app = write_uv (app, (U8)w / 40);
  *app++ = '.';
  app = write_uv (app, (U8)w % 40);

  // we assume an oid component is never > 64 bytes
  while (cur < end && oid + sizeof (oid) - app > 64)
    {
      w = get_w ();
      *app++ = '.';
      app = write_uv (app, w);
    }

  return newSVpvn (oid, app - oid);
}

static SV *
decode_ber ()
{
  int identifier = get_u8 ();

  SV *res;

  int constructed = identifier & ASN_CONSTRUCTED;
  int klass       = identifier & ASN_CLASS_MASK;
  int tag         = identifier & ASN_TAG_MASK;

  if (tag == ASN_TAG_BER)
    tag = get_w ();

  if (tag == ASN_TAG_BER)
    tag = get_w ();

  if (constructed)
    {
      U32 len = get_length ();
      U32 seqend = (cur - buf) + len;
      AV *av = (AV *)sv_2mortal ((SV *)newAV ());

      while (cur < buf + seqend)
        av_push (av, decode_ber ());

      if (cur > buf + seqend)
        croak ("constructed type %02x overflow (%x %x)\n", identifier, cur - buf, seqend);

      res = newRV_inc ((SV *)av);
    }
  else
    switch (identifier)
      {
        case ASN_NULL:
          res = &PL_sv_undef;
          break;

        case ASN_OBJECT_IDENTIFIER:
          res = decode_object_identifier ();
          break;

        case ASN_INTEGER32:
          res = decode_integer32 ();
          break;

        case ASN_APPLICATION | SNMP_UNSIGNED32:
        case ASN_APPLICATION | SNMP_COUNTER32:
        case ASN_APPLICATION | SNMP_TIMETICKS:
          res = decode_unsigned32 ();
          break;

#if 0 // handled by default case
        case ASN_OCTET_STRING:
        case ASN_APPLICATION | ASN_IPADDRESS:
        case ASN_APPLICATION | ASN_OPAQUE:
          res = decode_octet_string ();
          break;
#endif

        case ASN_APPLICATION | SNMP_COUNTER64:
          res = decode_integer64 ();
          break;

        default:
          res = decode_octet_string ();
          break;
      }

  AV *av = newAV ();
  av_fill (av, BER_ARRAYSIZE - 1);
  AvARRAY (av)[BER_CLASS      ] = newSVcacheint (klass >> ASN_CLASS_SHIFT);
  AvARRAY (av)[BER_TAG        ] = newSVcacheint (tag);
  AvARRAY (av)[BER_CONSTRUCTED] = newSVcacheint (constructed ? 1 : 0);
  AvARRAY (av)[BER_DATA       ] = res;

  return newRV_noinc ((SV *)av);
}

/////////////////////////////////////////////////////////////////////////////
// encoder

/* adds two STRLENs together, slow, and with paranoia */
static STRLEN
strlen_sum (STRLEN l1, STRLEN l2)
{
  size_t sum = l1 + l2;

  if (sum < (size_t)l2 || sum != (size_t)(STRLEN)sum)
    croak ("JSON::XS: string size overflow");

  return sum;
}

static void
set_buf (SV *sv)
{
  STRLEN len;
  buf_sv = sv;
  buf = SvPVbyte (buf_sv, len);
  cur = buf;
  end = buf + len;
}

/* similar to SvGROW, but somewhat safer and guarantees exponential realloc strategy */
static char *
my_sv_grow (SV *sv, size_t len1, size_t len2)
{
  len1 = strlen_sum (len1, len2);
  len1 = strlen_sum (len1, len1 >> 1);

  if (len1 > 4096 - 24)
    len1 = (len1 | 4095) - 24;

  return SvGROW (sv, len1);
}

static void
need (STRLEN len)
{
  if (expect_false ((uintptr_t)(end - cur) < len))
    {
      STRLEN pos = cur - buf;
      buf = my_sv_grow (buf_sv, pos, len);
      cur = buf + pos;
      end = buf + SvLEN (buf_sv) - 1;
    }
}

static void
put_u8 (int val)
{
  need (1);
  *cur++ = val;
}

static void
put_w_nocheck (U32 val)
{
  *cur = (val >> 7 * 4) | 0x80; cur += val >= (1 << (7 * 4));
  *cur = (val >> 7 * 3) | 0x80; cur += val >= (1 << (7 * 3));
  *cur = (val >> 7 * 2) | 0x80; cur += val >= (1 << (7 * 2));
  *cur = (val >> 7 * 1) | 0x80; cur += val >= (1 << (7 * 1));
  *cur =  val           & 0x7f; cur += 1;
}

static void
put_w (U32 val)
{
  need (5); // we only handle up to 5 bytes

  put_w_nocheck (val);
}

static U8 *
put_length_at (U32 val, U8 *cur)
{
  if (val < 0x7fU)
    *cur++ = val;
  else
    {
      U8 *lenb = cur++;

      *cur = val >> 24; cur += *cur > 0;
      *cur = val >> 16; cur += *cur > 0;
      *cur = val >>  8; cur += *cur > 0;
      *cur = val      ; cur += 1;

      *lenb = 0x80 + cur - lenb - 1;
    }

  return cur;
}

static void
put_length (U32 val)
{
  need (5);
  cur = put_length_at (val, cur);
}

// return how many bytes the encoded length requires
static int length_length (U32 val)
{
  return val < 0x7fU
    ? 1
    : 2 + (val > 0xffU) + (val > 0xffffU) + (val > 0xffffffU);
}

static void
encode_octet_string (SV *sv)
{
  STRLEN len;
  char *ptr = SvPVbyte (sv, len);

  put_length (len);
  need (len);
  memcpy (cur, ptr, len);
  cur += len;
}

static void
encode_integer32 (IV iv)
{
  need (5);

  U8 *lenb = cur++;

  if (iv < 0)
    {
      // get two's complement bit pattern - works even on hypthetical non-2c machines
      U32 uv = iv;

      *cur = uv >> 24; cur += !!(~uv & 0xff800000U);
      *cur = uv >> 16; cur += !!(~uv & 0xffff8000U);
      *cur = uv >>  8; cur += !!(~uv & 0xffffff80U);
      *cur = uv      ; cur += 1;
    }
  else
    {
      *cur = iv >> 24; cur += *cur > 0;
      *cur = iv >> 16; cur += *cur > 0;
      *cur = iv >>  8; cur += *cur > 0;
      *cur = iv      ; cur += 1;
    }

  *lenb = cur - lenb - 1;
}

static void
encode_unsigned64 (U64TYPE uv)
{
  need (9);

  U8 *lenb = cur++;

  *cur = uv >> 56; cur += *cur > 0;
  *cur = uv >> 48; cur += *cur > 0;
  *cur = uv >> 40; cur += *cur > 0;
  *cur = uv >> 32; cur += *cur > 0;
  *cur = uv >> 24; cur += *cur > 0;
  *cur = uv >> 16; cur += *cur > 0;
  *cur = uv >>  8; cur += *cur > 0;
  *cur = uv      ; cur += 1;

  *lenb = cur - lenb - 1;
}

// we don't know the length yet, so we optimistically
// assume the length will need one octet later. if that
// turns out to be wrong, we memove as needed.
// mark the beginning
static STRLEN
len_fixup_mark ()
{
  return cur++ - buf;
}

// patch up the length
static void
len_fixup (STRLEN mark)
{
  STRLEN reallen = (cur - buf) - mark - 1;
  int lenlen = length_length (reallen);

  if (expect_false (lenlen > 1))
    {
      // bad luck, we have to shift the bytes to make room for the length
      need (5);
      memmove (buf + mark + lenlen, buf + mark + 1, reallen);
      cur += lenlen - 1;
    }
  
  put_length_at (reallen, buf + mark);
}

static char *
read_uv (char *str, UV *uv)
{
  UV r = 0;

  while (*str >= '0')
    r = r * 10 + *str++ - '0';

  *uv = r;

  str += !!*str; // advance over any non-zero byte

  return str;
}

static void
encode_object_identifier (SV *oid)
{
  STRLEN slen;
  char *ptr = SvPV (oid, slen); // utf8 vs. bytes does not matter

  // we need at most as many octets as the string form
  need (slen + 1);
  STRLEN mark = len_fixup_mark ();

  UV w1, w2;

  ptr = read_uv (ptr, &w1);
  ptr = read_uv (ptr, &w2);

  put_w_nocheck (w1 * 40 + w2);

  while (*ptr)
    {
      ptr = read_uv (ptr, &w1);
      put_w_nocheck (w1);
    }

  len_fixup (mark);
}

static void
encode_ber (SV *tuple)
{
  if (expect_false (!SvROK (tuple) || SvTYPE (SvRV (tuple)) != SVt_PVAV))
    croak ("BER tuple must be array-reference");

  AV *av = (AV *)SvRV (tuple);

  if (expect_false (SvRMAGICAL (av)))
    croak ("BER tuple must not be tied");

  if (expect_false (AvFILL (av) != BER_ARRAYSIZE - 1))
    croak ("BER tuple must contain exactly %d elements, not %d", BER_ARRAYSIZE, AvFILL (av) + 1);

  int klass       = SvIV (AvARRAY (av)[BER_CLASS]);
  int tag         = SvIV (AvARRAY (av)[BER_TAG]);
  int constructed = SvIV (AvARRAY (av)[BER_CONSTRUCTED]) ? ASN_CONSTRUCTED : 0;
  SV *data        =       AvARRAY (av)[BER_DATA];

  int identifier = (klass << ASN_CLASS_SHIFT) | constructed;

  if (expect_false (tag >= ASN_TAG_BER))
    {
      put_u8 (identifier | ASN_TAG_BER);
      put_w (tag);
    }
  else
    put_u8 (identifier | tag);

  if (constructed)
    {
      // we optimistically assume that only one length byte is needed
      // and adjust later
      need (1);
      STRLEN mark = len_fixup_mark ();

      if (expect_false (!SvROK (data) || SvTYPE (SvRV (data)) != SVt_PVAV))
        croak ("BER constructed data must be array-reference");

      AV *av = (AV *)SvRV (data);
      int fill = AvFILL (av);

      if (expect_false (SvRMAGICAL (av)))
        croak ("BER constructed data must not be tied");

      for (int i = 0; i <= fill; ++i)
        encode_ber (AvARRAY (av)[i]);

      len_fixup (mark);
    }
  else
    switch (identifier | tag)
      {
        case ASN_NULL:
          put_length (0);
          break;

        case ASN_OBJECT_IDENTIFIER:
          encode_object_identifier (data);
          break;

        case ASN_INTEGER32:
          encode_integer32 (SvIV (data));
          break;

        case ASN_APPLICATION | SNMP_UNSIGNED32:
        case ASN_APPLICATION | SNMP_COUNTER32:
        case ASN_APPLICATION | SNMP_TIMETICKS:
        case ASN_APPLICATION | SNMP_COUNTER64:
          encode_unsigned64 (SvUV (data));
          break;

        default:
          encode_octet_string (data);
          break;
      }

}

/////////////////////////////////////////////////////////////////////////////

MODULE = Convert::BER::XS               PACKAGE = Convert::BER::XS

PROTOTYPES: ENABLE

BOOT:
{
  HV *stash = gv_stashpv ("Convert::BER::XS", 1);

  static const struct {
    const char *name;
    IV iv;
  } *civ, const_iv[] = {
    { "ASN_BOOLEAN",           ASN_BOOLEAN           },
    { "ASN_INTEGER32",         ASN_INTEGER32         },
    { "ASN_BIT_STRING",        ASN_BIT_STRING        },
    { "ASN_OCTET_STRING",      ASN_OCTET_STRING      },
    { "ASN_NULL",              ASN_NULL              },
    { "ASN_OBJECT_IDENTIFIER", ASN_OBJECT_IDENTIFIER },
    { "ASN_TAG_BER",           ASN_TAG_BER           },
    { "ASN_TAG_MASK",          ASN_TAG_MASK          },
    { "ASN_CONSTRUCTED",       ASN_CONSTRUCTED       },
    { "ASN_UNIVERSAL",         ASN_UNIVERSAL   >> ASN_CLASS_SHIFT },
    { "ASN_APPLICATION",       ASN_APPLICATION >> ASN_CLASS_SHIFT },
    { "ASN_CONTEXT",           ASN_CONTEXT     >> ASN_CLASS_SHIFT },
    { "ASN_PRIVATE",           ASN_PRIVATE     >> ASN_CLASS_SHIFT },
    { "ASN_CLASS_MASK",        ASN_CLASS_MASK        },
    { "ASN_CLASS_SHIFT",       ASN_CLASS_SHIFT       },
    { "ASN_SEQUENCE",          ASN_SEQUENCE          },
    { "SNMP_IPADDRESS",        SNMP_IPADDRESS        },
    { "SNMP_COUNTER32",        SNMP_COUNTER32        },
    { "SNMP_UNSIGNED32",       SNMP_UNSIGNED32       },
    { "SNMP_TIMETICKS",        SNMP_TIMETICKS        },
    { "SNMP_OPAQUE",           SNMP_OPAQUE           },
    { "SNMP_COUNTER64",        SNMP_COUNTER64        },

    { "BER_CLASS"      , BER_CLASS       },
    { "BER_TAG"        , BER_TAG         },
    { "BER_CONSTRUCTED", BER_CONSTRUCTED },
    { "BER_DATA"       , BER_DATA        },
  };

  for (civ = const_iv + sizeof (const_iv) / sizeof (const_iv [0]); civ > const_iv; civ--)
    newCONSTSUB (stash, (char *)civ[-1].name, newSViv (civ[-1].iv));
}

SV *
ber_decode (SV *ber)
        CODE:
{
        STRLEN len;

        buf = SvPVbyte (ber, len);
        cur = buf;
        end = buf + len;

        RETVAL = decode_ber ();
}
        OUTPUT: RETVAL

void
ber_is (SV *tuple, SV *klass = &PL_sv_undef, SV *tag = &PL_sv_undef, SV *constructed = &PL_sv_undef, SV *data = &PL_sv_undef)
        PROTOTYPE: $;$$$
        PPCODE:
{
        if (!SvOK (tuple))
          XSRETURN_NO;

        if (!SvROK (tuple) || SvTYPE (SvRV (tuple)) != SVt_PVAV)
          croak ("ber_seq: tuple must be ber tuple (array-ref)");

        AV *av = (AV *)SvRV (tuple);

        XPUSHs (
             (!SvOK (klass)       || SvIV  (AvARRAY (av)[BER_CLASS      ]) == SvIV (klass))
          && (!SvOK (tag)         || SvIV  (AvARRAY (av)[BER_TAG        ]) == SvIV (tag))
          && (!SvOK (constructed) || !SvIV (AvARRAY (av)[BER_CONSTRUCTED]) == !SvIV (constructed))
          && (!SvOK (data)        || sv_eq (AvARRAY (av)[BER_DATA       ], data))
          ? &PL_sv_yes : &PL_sv_no);
}

void
ber_is_seq (SV *tuple)
        PPCODE:
{
        if (!SvOK (tuple))
          XSRETURN_UNDEF;

        if (!SvROK (tuple) || SvTYPE (SvRV (tuple)) != SVt_PVAV)
          croak ("ber_seq: tuple must be ber tuple (array-ref)");

        AV *av = (AV *)SvRV (tuple);

        XPUSHs (
             SvIV (AvARRAY (av)[BER_CLASS      ]) == ASN_UNIVERSAL
          && SvIV (AvARRAY (av)[BER_TAG        ]) == ASN_SEQUENCE
          && SvIV (AvARRAY (av)[BER_CONSTRUCTED])
          ? AvARRAY (av)[BER_DATA] : &PL_sv_undef);
}

void
ber_is_i32 (SV *tuple, IV value)
        PPCODE:
{
        if (!SvOK (tuple))
          XSRETURN_NO;

        if (!SvROK (tuple) || SvTYPE (SvRV (tuple)) != SVt_PVAV)
          croak ("ber_seq: tuple must be ber tuple (array-ref)");

        AV *av = (AV *)SvRV (tuple);

        XPUSHs (
              SvIV (AvARRAY (av)[BER_CLASS      ]) == ASN_UNIVERSAL
          &&  SvIV (AvARRAY (av)[BER_TAG        ]) == ASN_INTEGER32
          && !SvIV (AvARRAY (av)[BER_CONSTRUCTED])
          &&  SvIV (AvARRAY (av)[BER_DATA       ]) == value
          ? &PL_sv_yes : &PL_sv_no);
}

void
ber_is_oid (SV *tuple, SV *oid)
        PPCODE:
{
        if (!SvOK (tuple))
          XSRETURN_NO;

        if (!SvROK (tuple) || SvTYPE (SvRV (tuple)) != SVt_PVAV)
          croak ("ber_seq: tuple must be ber tuple (array-ref)");

        AV *av = (AV *)SvRV (tuple);

        XPUSHs (
              SvIV (AvARRAY (av)[BER_CLASS      ]) == ASN_UNIVERSAL
          &&  SvIV (AvARRAY (av)[BER_TAG        ]) == ASN_OBJECT_IDENTIFIER
          && !SvIV (AvARRAY (av)[BER_CONSTRUCTED])
          &&  sv_eq (AvARRAY (av)[BER_DATA], oid)
          ? &PL_sv_yes : &PL_sv_no);
}

#############################################################################

void
ber_encode (SV *tuple)
        PPCODE:
{
        buf_sv = sv_2mortal (NEWSV (0, 256));
        SvPOK_only (buf_sv);
        set_buf (buf_sv);

        encode_ber (tuple);

        SvCUR_set (buf_sv, cur - buf);
        XPUSHs (buf_sv);
}

Revision:	1.3
Committed:	Fri Apr 19 19:46:29 2019 UTC (5 years, 1 month ago) by root
Branch:	MAIN
CVS Tags:	rel-0_1
Changes since 1.2:	+410 -68 lines
Log Message:	* empty log message *
#	Content
1	#include "EXTERN.h"
2	#include "perl.h"
3	#include "XSUB.h"
4
5	// C99 required
6
7	enum {
8	// ASN_TAG
9	ASN_BOOLEAN = 0x01,
10	ASN_INTEGER32 = 0x02,
11	ASN_BIT_STRING = 0x03,
12	ASN_OCTET_STRING = 0x04,
13	ASN_NULL = 0x05,
14	ASN_OBJECT_IDENTIFIER = 0x06,
15	ASN_OID = 0x06, //X
16	ASN_OBJECT_DESCRIPTOR = 0x07, //X
17	ASN_EXTERNAL = 0x08, //X
18	ASN_REAL = 0x09, //X
19	ASN_ENUMERATED = 0x0a, //X
20	ASN_EMBEDDED_PDV = 0x0b, //X
21	ASN_UTF8_STRING = 0x0c, //X
22	ASN_RELATIVE_OID = 0x0d, //X
23	ASN_SEQUENCE = 0x10,
24	ASN_SET = 0x11, //X
25	ASN_NUMERIC_STRING = 0x12, //X
26	ASN_PRINTABLE_STRING = 0x13, //X
27	ASN_TELETEX_STRING = 0x14, //X
28	ASN_T61_STRING = 0x14, //X
29	ASN_VIDEOTEX_STRING = 0x15, //X
30	ASN_IA5_STRING = 0x16, //X
31	ASN_ASCII_STRING = 0x16, //X
32	ASN_UTC_TIME = 0x17, //X
33	ASN_GENERALIZED_TIME = 0x18, //X
34	ASN_GRAPHIC_STRING = 0x19, //X
35	ASN_VISIBLE_STRING = 0x1a, //X
36	ASN_ISO646_STRING = 0x1a, //X
37	ASN_GENERAL_STRING = 0x1b, //X
38	ASN_UNIVERSAL_STRING = 0x1c, //X
39	ASN_CHARACTER_STRING = 0x1d, //X
40	ASN_BMPSTRING = 0x1e, //X
41
42	ASN_TAG_BER = 0x1f,
43	ASN_TAG_MASK = 0x1f,
44
45	// primitive/constructed
46	ASN_CONSTRUCTED = 0x20,
47
48	// ASN_CLASS
49	ASN_UNIVERSAL = 0x00,
50	ASN_APPLICATION = 0x40,
51	ASN_CONTEXT = 0x80,
52	ASN_PRIVATE = 0xc0,
53
54	ASN_CLASS_MASK = 0xc0,
55	ASN_CLASS_SHIFT = 6,
56
57	// ASN_APPLICATION SNMP
58	SNMP_IPADDRESS = 0x00,
59	SNMP_COUNTER32 = 0x01,
60	SNMP_UNSIGNED32 = 0x02,
61	SNMP_TIMETICKS = 0x03,
62	SNMP_OPAQUE = 0x04,
63	SNMP_COUNTER64 = 0x06,
64	};
65
66	enum {
67	BER_CLASS = 0,
68	BER_TAG = 1,
69	BER_CONSTRUCTED = 2,
70	BER_DATA = 3,
71	BER_ARRAYSIZE
72	};
73
74	#define MAX_OID_STRLEN 4096
75
76	static SV *buf_sv; // encoding buffer
77	static U8 buf, cur, *end; // buffer start, current, end
78
79	#if __GNUC__ >= 3
80	# define expect(expr,value) __builtin_expect ((expr), (value))
81	# define INLINE static inline
82	#else
83	# define expect(expr,value) (expr)
84	# define INLINE static
85	#endif
86
87	#define expect_false(expr) expect ((expr) != 0, 0)
88	#define expect_true(expr) expect ((expr) != 0, 1)
89
90	// for "small" integers, return a readonly sv, otherwise create a new one
91	static SV *newSVcacheint (int val)
92	{
93	static SV *cache[32];
94
95	if (expect_false (val < 0 \|\| val >= sizeof (cache)))
96	return newSViv (val);
97
98	if (expect_false (!cache [val]))
99	{
100	cache [val] = newSVuv (val);
101	SvREADONLY_on (cache [val]);
102	}
103
104	return SvREFCNT_inc_NN (cache [val]);
105	}
106
107	/////////////////////////////////////////////////////////////////////////////
108	// decoder
109
110	static void
111	error (const char *errmsg)
112	{
113	croak ("%s at offset 0x%04x", errmsg, cur - buf);
114	}
115
116	static void
117	want (UV count)
118	{
119	if (expect_false ((uintptr_t)(end - cur) < count))
120	error ("unexpected end of message buffer");
121	}
122
123	// get_* functions fetch something from the buffer
124	// decode_* functions use get_* fun ctions to decode ber values
125
126	// get n octets
127	static U8 *
128	get_n (UV count)
129	{
130	want (count);
131	U8 *res = cur;
132	cur += count;
133	return res;
134	}
135
136	// get single octet
137	static U8
138	get_u8 (void)
139	{
140	if (cur == end)
141	error ("unexpected end of message buffer");
142
143	return *cur++;
144	}
145
146	// get ber-encoded integer (i.e. pack "w")
147	static U32
148	get_w (void)
149	{
150	U32 res = 0;
151
152	for (;;)
153	{
154	U8 c = get_u8 ();
155	res = (res << 7) \| (c & 0x7f);
156
157	if (!(c & 0x80))
158	return res;
159	}
160	}
161
162	static U32
163	get_length (void)
164	{
165	U32 res = get_u8 ();
166
167	if (res & 0x80)
168	{
169	int cnt = res & 0x7f;
170	res = 0;
171
172	switch (cnt)
173	{
174	case 0:
175	error ("indefinite ASN.1 lengths not supported");
176	return 0;
177
178	default:
179	error ("ASN.1 length too long");
180	return 0;
181
182	case 4: res = (res << 8) \| get_u8 ();
183	case 3: res = (res << 8) \| get_u8 ();
184	case 2: res = (res << 8) \| get_u8 ();
185	case 1: res = (res << 8) \| get_u8 ();
186	}
187	}
188
189	return res;
190	}
191
192	static U32
193	get_integer32 (void)
194	{
195	U32 length = get_length ();
196
197	if (length <= 0)
198	{
199	error ("INTEGER32 length equal to zero");
200	return 0;
201	}
202
203	U8 *data = get_n (length);
204
205	if (length > 5 \|\| (length > 4 && data [0]))
206	{
207	error ("INTEGER32 length too long");
208	return 0;
209	}
210
211	U32 res = data [0] & 0x80 ? 0xffffffff : 0;
212
213	while (length--)
214	res = (res << 8) \| *data++;
215
216	return res;
217	}
218
219	static SV *
220	decode_integer32 (void)
221	{
222	return newSViv ((I32)get_integer32 ());
223	}
224
225	static SV *
226	decode_unsigned32 (void)
227	{
228	return newSVuv ((U32)get_integer32 ());
229	}
230
231	#if IVSIZE >= 8
232
233	static U64TYPE
234	get_integer64 (void)
235	{
236	U32 length = get_length ();
237
238	if (length <= 0)
239	{
240	error ("INTEGER64 length equal to zero");
241	return 0;
242	}
243
244	U8 *data = get_n (length);
245
246	if (length > 9 \|\| (length > 8 && data [0]))
247	{
248	error ("INTEGER64 length too long");
249	return 0;
250	}
251
252	U64TYPE res = data [0] & 0x80 ? 0xffffffffffffffff : 0;
253
254	while (length--)
255	res = (res << 8) \| *data++;
256
257	return res;
258	}
259
260	static SV *
261	decode_integer64 (void)
262	{
263	return newSViv ((I64TYPE)get_integer64 ());
264	}
265
266	static SV *
267	decode_unsigned64 (void)
268	{
269	return newSVuv ((U64TYPE)get_integer64 ());
270	}
271
272	#endif
273
274	static SV *
275	decode_octet_string (void)
276	{
277	U32 length = get_length ();
278	U8 *data = get_n (length);
279	return newSVpvn (data, length);
280	}
281
282	// gelper for decode_object_identifier
283	static char *
284	write_uv (char *buf, U32 u)
285	{
286	// the one-digit case is absolutely predominant, so this pays off (hopefully)
287	if (u < 10)
288	*buf++ = u + '0';
289	else
290	{
291	char *beg = buf;
292
293	do
294	{
295	*buf++ = u % 10 + '0';
296	u /= 10;
297	}
298	while (u);
299
300	// reverse digits
301	for (char *ptr = buf; --ptr != beg; ++beg)
302	{
303	char c = *ptr;
304	ptr = beg;
305	*beg = c;
306	}
307	}
308
309	return buf;
310	}
311
312	static SV *
313	decode_object_identifier (void)
314	{
315	U32 length = get_length ();
316
317	if (length <= 0)
318	{
319	error ("OBJECT IDENTIFIER length equal to zero");
320	return &PL_sv_undef;
321	}
322
323	U8 *end = cur + length;
324	U32 w = get_w ();
325
326	static char oid[MAX_OID_STRLEN]; // must be static
327	char *app = oid;
328
329	app = write_uv (app, (U8)w / 40);
330	*app++ = '.';
331	app = write_uv (app, (U8)w % 40);
332
333	// we assume an oid component is never > 64 bytes
334	while (cur < end && oid + sizeof (oid) - app > 64)
335	{
336	w = get_w ();
337	*app++ = '.';
338	app = write_uv (app, w);
339	}
340
341	return newSVpvn (oid, app - oid);
342	}
343
344	static SV *
345	decode_ber ()
346	{
347	int identifier = get_u8 ();
348
349	SV *res;
350
351	int constructed = identifier & ASN_CONSTRUCTED;
352	int klass = identifier & ASN_CLASS_MASK;
353	int tag = identifier & ASN_TAG_MASK;
354
355	if (tag == ASN_TAG_BER)
356	tag = get_w ();
357
358	if (tag == ASN_TAG_BER)
359	tag = get_w ();
360
361	if (constructed)
362	{
363	U32 len = get_length ();
364	U32 seqend = (cur - buf) + len;
365	AV av = (AV )sv_2mortal ((SV *)newAV ());
366
367	while (cur < buf + seqend)
368	av_push (av, decode_ber ());
369
370	if (cur > buf + seqend)
371	croak ("constructed type %02x overflow (%x %x)\n", identifier, cur - buf, seqend);
372
373	res = newRV_inc ((SV *)av);
374	}
375	else
376	switch (identifier)
377	{
378	case ASN_NULL:
379	res = &PL_sv_undef;
380	break;
381
382	case ASN_OBJECT_IDENTIFIER:
383	res = decode_object_identifier ();
384	break;
385
386	case ASN_INTEGER32:
387	res = decode_integer32 ();
388	break;
389
390	case ASN_APPLICATION \| SNMP_UNSIGNED32:
391	case ASN_APPLICATION \| SNMP_COUNTER32:
392	case ASN_APPLICATION \| SNMP_TIMETICKS:
393	res = decode_unsigned32 ();
394	break;
395
396	#if 0 // handled by default case
397	case ASN_OCTET_STRING:
398	case ASN_APPLICATION \| ASN_IPADDRESS:
399	case ASN_APPLICATION \| ASN_OPAQUE:
400	res = decode_octet_string ();
401	break;
402	#endif
403
404	case ASN_APPLICATION \| SNMP_COUNTER64:
405	res = decode_integer64 ();
406	break;
407
408	default:
409	res = decode_octet_string ();
410	break;
411	}
412
413	AV *av = newAV ();
414	av_fill (av, BER_ARRAYSIZE - 1);
415	AvARRAY (av)[BER_CLASS ] = newSVcacheint (klass >> ASN_CLASS_SHIFT);
416	AvARRAY (av)[BER_TAG ] = newSVcacheint (tag);
417	AvARRAY (av)[BER_CONSTRUCTED] = newSVcacheint (constructed ? 1 : 0);
418	AvARRAY (av)[BER_DATA ] = res;
419
420	return newRV_noinc ((SV *)av);
421	}
422
423	/////////////////////////////////////////////////////////////////////////////
424	// encoder
425
426	/* adds two STRLENs together, slow, and with paranoia */
427	static STRLEN
428	strlen_sum (STRLEN l1, STRLEN l2)
429	{
430	size_t sum = l1 + l2;
431
432	if (sum < (size_t)l2 \|\| sum != (size_t)(STRLEN)sum)
433	croak ("JSON::XS: string size overflow");
434
435	return sum;
436	}
437
438	static void
439	set_buf (SV *sv)
440	{
441	STRLEN len;
442	buf_sv = sv;
443	buf = SvPVbyte (buf_sv, len);
444	cur = buf;
445	end = buf + len;
446	}
447
448	/* similar to SvGROW, but somewhat safer and guarantees exponential realloc strategy */
449	static char *
450	my_sv_grow (SV *sv, size_t len1, size_t len2)
451	{
452	len1 = strlen_sum (len1, len2);
453	len1 = strlen_sum (len1, len1 >> 1);
454
455	if (len1 > 4096 - 24)
456	len1 = (len1 \| 4095) - 24;
457
458	return SvGROW (sv, len1);
459	}
460
461	static void
462	need (STRLEN len)
463	{
464	if (expect_false ((uintptr_t)(end - cur) < len))
465	{
466	STRLEN pos = cur - buf;
467	buf = my_sv_grow (buf_sv, pos, len);
468	cur = buf + pos;
469	end = buf + SvLEN (buf_sv) - 1;
470	}
471	}
472
473	static void
474	put_u8 (int val)
475	{
476	need (1);
477	*cur++ = val;
478	}
479
480	static void
481	put_w_nocheck (U32 val)
482	{
483	cur = (val >> 7 4) \| 0x80; cur += val >= (1 << (7 * 4));
484	cur = (val >> 7 3) \| 0x80; cur += val >= (1 << (7 * 3));
485	cur = (val >> 7 2) \| 0x80; cur += val >= (1 << (7 * 2));
486	cur = (val >> 7 1) \| 0x80; cur += val >= (1 << (7 * 1));
487	*cur = val & 0x7f; cur += 1;
488	}
489
490	static void
491	put_w (U32 val)
492	{
493	need (5); // we only handle up to 5 bytes
494
495	put_w_nocheck (val);
496	}
497
498	static U8 *
499	put_length_at (U32 val, U8 *cur)
500	{
501	if (val < 0x7fU)
502	*cur++ = val;
503	else
504	{
505	U8 *lenb = cur++;
506
507	cur = val >> 24; cur += cur > 0;
508	cur = val >> 16; cur += cur > 0;
509	cur = val >> 8; cur += cur > 0;
510	*cur = val ; cur += 1;
511
512	*lenb = 0x80 + cur - lenb - 1;
513	}
514
515	return cur;
516	}
517
518	static void
519	put_length (U32 val)
520	{
521	need (5);
522	cur = put_length_at (val, cur);
523	}
524
525	// return how many bytes the encoded length requires
526	static int length_length (U32 val)
527	{
528	return val < 0x7fU
529	? 1
530	: 2 + (val > 0xffU) + (val > 0xffffU) + (val > 0xffffffU);
531	}
532
533	static void
534	encode_octet_string (SV *sv)
535	{
536	STRLEN len;
537	char *ptr = SvPVbyte (sv, len);
538
539	put_length (len);
540	need (len);
541	memcpy (cur, ptr, len);
542	cur += len;
543	}
544
545	static void
546	encode_integer32 (IV iv)
547	{
548	need (5);
549
550	U8 *lenb = cur++;
551
552	if (iv < 0)
553	{
554	// get two's complement bit pattern - works even on hypthetical non-2c machines
555	U32 uv = iv;
556
557	*cur = uv >> 24; cur += !!(~uv & 0xff800000U);
558	*cur = uv >> 16; cur += !!(~uv & 0xffff8000U);
559	*cur = uv >> 8; cur += !!(~uv & 0xffffff80U);
560	*cur = uv ; cur += 1;
561	}
562	else
563	{
564	cur = iv >> 24; cur += cur > 0;
565	cur = iv >> 16; cur += cur > 0;
566	cur = iv >> 8; cur += cur > 0;
567	*cur = iv ; cur += 1;
568	}
569
570	*lenb = cur - lenb - 1;
571	}
572
573	static void
574	encode_unsigned64 (U64TYPE uv)
575	{
576	need (9);
577
578	U8 *lenb = cur++;
579
580	cur = uv >> 56; cur += cur > 0;
581	cur = uv >> 48; cur += cur > 0;
582	cur = uv >> 40; cur += cur > 0;
583	cur = uv >> 32; cur += cur > 0;
584	cur = uv >> 24; cur += cur > 0;
585	cur = uv >> 16; cur += cur > 0;
586	cur = uv >> 8; cur += cur > 0;
587	*cur = uv ; cur += 1;
588
589	*lenb = cur - lenb - 1;
590	}
591
592	// we don't know the length yet, so we optimistically
593	// assume the length will need one octet later. if that
594	// turns out to be wrong, we memove as needed.
595	// mark the beginning
596	static STRLEN
597	len_fixup_mark ()
598	{
599	return cur++ - buf;
600	}
601
602	// patch up the length
603	static void
604	len_fixup (STRLEN mark)
605	{
606	STRLEN reallen = (cur - buf) - mark - 1;
607	int lenlen = length_length (reallen);
608
609	if (expect_false (lenlen > 1))
610	{
611	// bad luck, we have to shift the bytes to make room for the length
612	need (5);
613	memmove (buf + mark + lenlen, buf + mark + 1, reallen);
614	cur += lenlen - 1;
615	}
616
617	put_length_at (reallen, buf + mark);
618	}
619
620	static char *
621	read_uv (char str, UV uv)
622	{
623	UV r = 0;
624
625	while (*str >= '0')
626	r = r * 10 + *str++ - '0';
627
628	*uv = r;
629
630	str += !!*str; // advance over any non-zero byte
631
632	return str;
633	}
634
635	static void
636	encode_object_identifier (SV *oid)
637	{
638	STRLEN slen;
639	char *ptr = SvPV (oid, slen); // utf8 vs. bytes does not matter
640
641	// we need at most as many octets as the string form
642	need (slen + 1);
643	STRLEN mark = len_fixup_mark ();
644
645	UV w1, w2;
646
647	ptr = read_uv (ptr, &w1);
648	ptr = read_uv (ptr, &w2);
649
650	put_w_nocheck (w1 * 40 + w2);
651
652	while (*ptr)
653	{
654	ptr = read_uv (ptr, &w1);
655	put_w_nocheck (w1);
656	}
657
658	len_fixup (mark);
659	}
660
661	static void
662	encode_ber (SV *tuple)
663	{
664	if (expect_false (!SvROK (tuple) \|\| SvTYPE (SvRV (tuple)) != SVt_PVAV))
665	croak ("BER tuple must be array-reference");
666
667	AV av = (AV )SvRV (tuple);
668
669	if (expect_false (SvRMAGICAL (av)))
670	croak ("BER tuple must not be tied");
671
672	if (expect_false (AvFILL (av) != BER_ARRAYSIZE - 1))
673	croak ("BER tuple must contain exactly %d elements, not %d", BER_ARRAYSIZE, AvFILL (av) + 1);
674
675	int klass = SvIV (AvARRAY (av)[BER_CLASS]);
676	int tag = SvIV (AvARRAY (av)[BER_TAG]);
677	int constructed = SvIV (AvARRAY (av)[BER_CONSTRUCTED]) ? ASN_CONSTRUCTED : 0;
678	SV *data = AvARRAY (av)[BER_DATA];
679
680	int identifier = (klass << ASN_CLASS_SHIFT) \| constructed;
681
682	if (expect_false (tag >= ASN_TAG_BER))
683	{
684	put_u8 (identifier \| ASN_TAG_BER);
685	put_w (tag);
686	}
687	else
688	put_u8 (identifier \| tag);
689
690	if (constructed)
691	{
692	// we optimistically assume that only one length byte is needed
693	// and adjust later
694	need (1);
695	STRLEN mark = len_fixup_mark ();
696
697	if (expect_false (!SvROK (data) \|\| SvTYPE (SvRV (data)) != SVt_PVAV))
698	croak ("BER constructed data must be array-reference");
699
700	AV av = (AV )SvRV (data);
701	int fill = AvFILL (av);
702
703	if (expect_false (SvRMAGICAL (av)))
704	croak ("BER constructed data must not be tied");
705
706	for (int i = 0; i <= fill; ++i)
707	encode_ber (AvARRAY (av)[i]);
708
709	len_fixup (mark);
710	}
711	else
712	switch (identifier \| tag)
713	{
714	case ASN_NULL:
715	put_length (0);
716	break;
717
718	case ASN_OBJECT_IDENTIFIER:
719	encode_object_identifier (data);
720	break;
721
722	case ASN_INTEGER32:
723	encode_integer32 (SvIV (data));
724	break;
725
726	case ASN_APPLICATION \| SNMP_UNSIGNED32:
727	case ASN_APPLICATION \| SNMP_COUNTER32:
728	case ASN_APPLICATION \| SNMP_TIMETICKS:
729	case ASN_APPLICATION \| SNMP_COUNTER64:
730	encode_unsigned64 (SvUV (data));
731	break;
732
733	default:
734	encode_octet_string (data);
735	break;
736	}
737
738	}
739
740	/////////////////////////////////////////////////////////////////////////////
741
742	MODULE = Convert::BER::XS PACKAGE = Convert::BER::XS
743
744	PROTOTYPES: ENABLE
745
746	BOOT:
747	{
748	HV *stash = gv_stashpv ("Convert::BER::XS", 1);
749
750	static const struct {
751	const char *name;
752	IV iv;
753	} *civ, const_iv[] = {
754	{ "ASN_BOOLEAN", ASN_BOOLEAN },
755	{ "ASN_INTEGER32", ASN_INTEGER32 },
756	{ "ASN_BIT_STRING", ASN_BIT_STRING },
757	{ "ASN_OCTET_STRING", ASN_OCTET_STRING },
758	{ "ASN_NULL", ASN_NULL },
759	{ "ASN_OBJECT_IDENTIFIER", ASN_OBJECT_IDENTIFIER },
760	{ "ASN_TAG_BER", ASN_TAG_BER },
761	{ "ASN_TAG_MASK", ASN_TAG_MASK },
762	{ "ASN_CONSTRUCTED", ASN_CONSTRUCTED },
763	{ "ASN_UNIVERSAL", ASN_UNIVERSAL >> ASN_CLASS_SHIFT },
764	{ "ASN_APPLICATION", ASN_APPLICATION >> ASN_CLASS_SHIFT },
765	{ "ASN_CONTEXT", ASN_CONTEXT >> ASN_CLASS_SHIFT },
766	{ "ASN_PRIVATE", ASN_PRIVATE >> ASN_CLASS_SHIFT },
767	{ "ASN_CLASS_MASK", ASN_CLASS_MASK },
768	{ "ASN_CLASS_SHIFT", ASN_CLASS_SHIFT },
769	{ "ASN_SEQUENCE", ASN_SEQUENCE },
770	{ "SNMP_IPADDRESS", SNMP_IPADDRESS },
771	{ "SNMP_COUNTER32", SNMP_COUNTER32 },
772	{ "SNMP_UNSIGNED32", SNMP_UNSIGNED32 },
773	{ "SNMP_TIMETICKS", SNMP_TIMETICKS },
774	{ "SNMP_OPAQUE", SNMP_OPAQUE },
775	{ "SNMP_COUNTER64", SNMP_COUNTER64 },
776
777	{ "BER_CLASS" , BER_CLASS },
778	{ "BER_TAG" , BER_TAG },
779	{ "BER_CONSTRUCTED", BER_CONSTRUCTED },
780	{ "BER_DATA" , BER_DATA },
781	};
782
783	for (civ = const_iv + sizeof (const_iv) / sizeof (const_iv [0]); civ > const_iv; civ--)
784	newCONSTSUB (stash, (char *)civ[-1].name, newSViv (civ[-1].iv));
785	}
786
787	SV *
788	ber_decode (SV *ber)
789	CODE:
790	{
791	STRLEN len;
792
793	buf = SvPVbyte (ber, len);
794	cur = buf;
795	end = buf + len;
796
797	RETVAL = decode_ber ();
798	}
799	OUTPUT: RETVAL
800
801	void
802	ber_is (SV tuple, SV klass = &PL_sv_undef, SV tag = &PL_sv_undef, SV constructed = &PL_sv_undef, SV *data = &PL_sv_undef)
803	PROTOTYPE: $;$$$
804	PPCODE:
805	{
806	if (!SvOK (tuple))
807	XSRETURN_NO;
808
809	if (!SvROK (tuple) \|\| SvTYPE (SvRV (tuple)) != SVt_PVAV)
810	croak ("ber_seq: tuple must be ber tuple (array-ref)");
811
812	AV av = (AV )SvRV (tuple);
813
814	XPUSHs (
815	(!SvOK (klass) \|\| SvIV (AvARRAY (av)[BER_CLASS ]) == SvIV (klass))
816	&& (!SvOK (tag) \|\| SvIV (AvARRAY (av)[BER_TAG ]) == SvIV (tag))
817	&& (!SvOK (constructed) \|\| !SvIV (AvARRAY (av)[BER_CONSTRUCTED]) == !SvIV (constructed))
818	&& (!SvOK (data) \|\| sv_eq (AvARRAY (av)[BER_DATA ], data))
819	? &PL_sv_yes : &PL_sv_no);
820	}
821
822	void
823	ber_is_seq (SV *tuple)
824	PPCODE:
825	{
826	if (!SvOK (tuple))
827	XSRETURN_UNDEF;
828
829	if (!SvROK (tuple) \|\| SvTYPE (SvRV (tuple)) != SVt_PVAV)
830	croak ("ber_seq: tuple must be ber tuple (array-ref)");
831
832	AV av = (AV )SvRV (tuple);
833
834	XPUSHs (
835	SvIV (AvARRAY (av)[BER_CLASS ]) == ASN_UNIVERSAL
836	&& SvIV (AvARRAY (av)[BER_TAG ]) == ASN_SEQUENCE
837	&& SvIV (AvARRAY (av)[BER_CONSTRUCTED])
838	? AvARRAY (av)[BER_DATA] : &PL_sv_undef);
839	}
840
841	void
842	ber_is_i32 (SV *tuple, IV value)
843	PPCODE:
844	{
845	if (!SvOK (tuple))
846	XSRETURN_NO;
847
848	if (!SvROK (tuple) \|\| SvTYPE (SvRV (tuple)) != SVt_PVAV)
849	croak ("ber_seq: tuple must be ber tuple (array-ref)");
850
851	AV av = (AV )SvRV (tuple);
852
853	XPUSHs (
854	SvIV (AvARRAY (av)[BER_CLASS ]) == ASN_UNIVERSAL
855	&& SvIV (AvARRAY (av)[BER_TAG ]) == ASN_INTEGER32
856	&& !SvIV (AvARRAY (av)[BER_CONSTRUCTED])
857	&& SvIV (AvARRAY (av)[BER_DATA ]) == value
858	? &PL_sv_yes : &PL_sv_no);
859	}
860
861	void
862	ber_is_oid (SV tuple, SV oid)
863	PPCODE:
864	{
865	if (!SvOK (tuple))
866	XSRETURN_NO;
867
868	if (!SvROK (tuple) \|\| SvTYPE (SvRV (tuple)) != SVt_PVAV)
869	croak ("ber_seq: tuple must be ber tuple (array-ref)");
870
871	AV av = (AV )SvRV (tuple);
872
873	XPUSHs (
874	SvIV (AvARRAY (av)[BER_CLASS ]) == ASN_UNIVERSAL
875	&& SvIV (AvARRAY (av)[BER_TAG ]) == ASN_OBJECT_IDENTIFIER
876	&& !SvIV (AvARRAY (av)[BER_CONSTRUCTED])
877	&& sv_eq (AvARRAY (av)[BER_DATA], oid)
878	? &PL_sv_yes : &PL_sv_no);
879	}
880
881	#############################################################################
882
883	void
884	ber_encode (SV *tuple)
885	PPCODE:
886	{
887	buf_sv = sv_2mortal (NEWSV (0, 256));
888	SvPOK_only (buf_sv);
889	set_buf (buf_sv);
890
891	encode_ber (tuple);
892
893	SvCUR_set (buf_sv, cur - buf);
894	XPUSHs (buf_sv);
895	}
896