view release on metacpan or  search on metacpan

XS.xs  view on Meta::CPAN

fail:
  SvREFCNT_dec (sv);
  return &PL_sv_undef;
}

static SV *
decode_tagged (dec_t *dec)
{
  SV *sv = 0;
  UV tag = decode_uint (dec);

  WANT (1);

  switch (tag)
    {
      case CBOR_TAG_MAGIC:
        sv = decode_sv (dec);
        break;

      case CBOR_TAG_INDIRECTION:
        sv = newRV_noinc (decode_sv (dec));
        break;

      case CBOR_TAG_STRINGREF_NAMESPACE:
        {
          // do not use SAVETMPS/FREETMPS, as these will
          // erase mortalised caches, e.g. "shareable"
          ENTER;

          SAVESPTR (dec->stringref);
          dec->stringref = (AV *)sv_2mortal ((SV *)newAV ());

          sv = decode_sv (dec);

          LEAVE;
        }
        break;

      case CBOR_TAG_STRINGREF:
        {
          if ((*dec->cur >> MAJOR_SHIFT) != (MAJOR_POS_INT >> MAJOR_SHIFT))
            ERR ("corrupted CBOR data (stringref index not an unsigned integer)");

          UV idx = decode_uint (dec);

          if (!dec->stringref || idx >= (UV)(1 + AvFILLp (dec->stringref)))
            ERR ("corrupted CBOR data (stringref index out of bounds or outside namespace)");

          sv = newSVsv (AvARRAY (dec->stringref)[idx]);
        }
        break;

      case CBOR_TAG_VALUE_SHAREABLE:
        {
          if (ecb_expect_false (!dec->shareable))
            dec->shareable = (AV *)sv_2mortal ((SV *)newAV ());

          if (ecb_expect_false (dec->cbor.flags & (F_ALLOW_CYCLES | F_ALLOW_WEAK_CYCLES)))
            {
              // if cycles are allowed, then we store an AV as value
              // while it is being decoded, and gather unresolved
              // references in it, to be re4solved after decoding.
              int idx, i;
              AV *av = newAV ();
              av_push (dec->shareable, (SV *)av);
              idx = AvFILLp (dec->shareable);

              sv = decode_sv (dec);

              // the AV now contains \undef for all unresolved references,
              // so we fix them up here.
              for (i = 0; i <= AvFILLp (av); ++i)
                SvRV_set (AvARRAY (av)[i], SvREFCNT_inc_NN (SvRV (sv)));

              // weaken all recursive references
              if (dec->cbor.flags & F_ALLOW_WEAK_CYCLES)
                for (i = 0; i <= AvFILLp (av); ++i)
                  sv_rvweaken (AvARRAY (av)[i]);

              // now replace the AV by a reference to the completed value
              SvREFCNT_dec_NN ((SV *)av);
              AvARRAY (dec->shareable)[idx] = SvREFCNT_inc_NN (sv);
            }
          else
            {
              av_push (dec->shareable, &PL_sv_undef);
              int idx = AvFILLp (dec->shareable);
              sv = decode_sv (dec);
              AvARRAY (dec->shareable)[idx] = SvREFCNT_inc_NN (sv);
            }
        }
        break;

      case CBOR_TAG_VALUE_SHAREDREF:
        {
          if ((*dec->cur >> MAJOR_SHIFT) != (MAJOR_POS_INT >> MAJOR_SHIFT))
            ERR ("corrupted CBOR data (sharedref index not an unsigned integer)");

          UV idx = decode_uint (dec);

          if (!dec->shareable || idx >= (UV)(1 + AvFILLp (dec->shareable)))
            ERR ("corrupted CBOR data (sharedref index out of bounds)");

          sv = AvARRAY (dec->shareable)[idx];

          // reference to cycle, we create a new \undef and use that, and also
          // registerr it in the AV for later fixing
          if (ecb_expect_false (SvTYPE (sv) == SVt_PVAV))
            {
              AV *av = (AV *)sv;
              sv = newRV_noinc (&PL_sv_undef);
              av_push (av, SvREFCNT_inc_NN (sv));
            }
          else if (ecb_expect_false (sv == &PL_sv_undef)) // not yet decoded, but cycles not allowed
            ERR ("cyclic CBOR data structure found, but allow_cycles is not enabled");
          else // we decoded the object earlier, no cycle
            sv = newSVsv (sv);
        }
        break;

      case CBOR_TAG_PERL_OBJECT:
        {
          if (dec->cbor.flags & F_FORBID_OBJECTS)
            goto filter;

          sv = decode_sv (dec);

          if (!SvROK (sv) || SvTYPE (SvRV (sv)) != SVt_PVAV)
            ERR ("corrupted CBOR data (non-array perl object)");

          AV *av = (AV *)SvRV (sv);
          int len = av_len (av) + 1;
          HV *stash = gv_stashsv (*av_fetch (av, 0, 1), 0);

          if (!stash)
            ERR ("cannot decode perl-object (package does not exist)");

          GV *method = gv_fetchmethod_autoload (stash, "THAW", 0);
          
          if (!method)
            ERR ("cannot decode perl-object (package does not have a THAW method)");
          
          dSP;

          ENTER; SAVETMPS;
          PUSHMARK (SP);
          EXTEND (SP, len + 1);
          // we re-bless the reference to get overload and other niceties right
          PUSHs (*av_fetch (av, 0, 1));
          PUSHs (sv_cbor);

          int i;

          for (i = 1; i < len; ++i)
            PUSHs (*av_fetch (av, i, 1));

          PUTBACK;
          call_sv ((SV *)GvCV (method), G_SCALAR | G_EVAL);
          SPAGAIN;

          if (SvTRUE (ERRSV))
            {
              FREETMPS; LEAVE;
              ERR_ERRSV;
            }

          SvREFCNT_dec_NN (sv);
          sv = SvREFCNT_inc (POPs);

          PUTBACK;

          FREETMPS; LEAVE;
        }
        break;

      default: