AnyMongo

 view release on metacpan or  search on metacpan

mongo_support.c  view on Meta::CPAN

    PUTBACK;
    FREETMPS;
    LEAVE;

    return ret;
}

SV *
perl_mongo_construct_instance_with_magic (const char *klass, void *ptr, ...)
{
    SV *ret;
    va_list ap;

    va_start (ap, ptr);
    ret = perl_mongo_construct_instance_va (klass, ap);
    va_end (ap);

    perl_mongo_attach_ptr_to_instance (ret, ptr);

    return ret;
}

static SV *bson_to_av (buffer *buf);

void perl_mongo_make_oid(char *twelve, char *twenty4) {
  int i;
  char *id_str = twelve;
  char *movable = twenty4;

  for(i=0; i<12; i++) {
    int x = *id_str;
    if (*id_str < 0) {
      x = 256 + *id_str;
    }
    sprintf(movable, "%02x", x);
    movable += 2;
    id_str++;
  }
  twenty4[24] = '\0';
}

static SV *
oid_to_sv (buffer *buf)
{
    HV *stash, *id_hv;
    char oid_s[25];
    perl_mongo_make_oid(buf->pos, oid_s);

    id_hv = newHV();
    hv_store(id_hv, "value", strlen("value"), newSVpvn(oid_s, 24), 0);

    stash = gv_stashpv("AnyMongo::BSON::OID", 0);
    return sv_bless(newRV_noinc((SV *)id_hv), stash);
}

static SV *
elem_to_sv (int type, buffer *buf)
{
  SV *value = 0;
  
  SV *flag = get_sv("AnyMongo::BSON::utf8_flag_on", 0);

  switch(type) {
  case BSON_OID: {
    value = oid_to_sv(buf);
    buf->pos += OID_SIZE;
    break;
  }
  case BSON_DOUBLE: {
    double d = *(double*)buf->pos;
    int64_t i, *i_p;
    i_p = &i;

    memcpy(i_p, &d, DOUBLE_64);
    i = MONGO_64(i);
    memcpy(&d, i_p, DOUBLE_64);
 
    value = newSVnv(d);
    buf->pos += DOUBLE_64;
    break;
  }
  case BSON_SYMBOL:
  case BSON_STRING: {
    int len = MONGO_32(*((int*)buf->pos));
    buf->pos += INT_32;

    // this makes a copy of the buffer
    // len includes \0
    value = newSVpvn(buf->pos, len-1);
    
    if (!flag || !SvIOK(flag) || SvIV(flag) != 0) {
      SvUTF8_on(value);
    }

    buf->pos += len; 
    break;
  }
  case BSON_OBJECT: {
    value = perl_mongo_bson_to_sv(buf);
    break;
  }
  case BSON_ARRAY: {
    value = bson_to_av(buf);
    break;
  }
  case BSON_BINARY: {
    int len = MONGO_32(*(int*)buf->pos);
    char type;

    buf->pos += INT_32;

    // we should do something with type
    type = *buf->pos++;

    if (type == 2) {
      int len2 = MONGO_32(*(int*)buf->pos);
      if (len2 == len - 4) {
        len = len2;
        buf->pos += INT_32;
      }
    }

mongo_support.c  view on Meta::CPAN

    AV *array, *keys, *values;
    
    /* skip 4 bytes for size */
    start = buf->pos-buf->start;
    buf->pos += INT_32;
    
    /*
     * a Tie::IxHash is of the form:
     * [ {hash}, [keys], [order], 0 ]
     */
    array = (AV*)SvRV(sv);

    // check if we're in an infinite loop
    if (!(stack = check_circular_ref(array, stack))) {
      Safefree(buf->start);
      croak("circular ref");
    }

    /* keys in order, from position 1 */
    keys_sv = av_fetch(array, 1, 0);
    keys = (AV*)SvRV(*keys_sv);

    /* values in order, from position 2 */
    values_sv = av_fetch(array, 2, 0);
    values = (AV*)SvRV(*values_sv);

    if (ids) {
      /* check if the hash in position 0 contains an _id */
      SV **hash_sv = av_fetch(array, 0, 0);
      if (hv_exists((HV*)SvRV(*hash_sv), "_id", strlen("_id"))) {
        /*
         * if so, the value of the _id key is its index
         * in the values array.
         */
        SV **index = hv_fetch((HV*)SvRV(*hash_sv), "_id", strlen("_id"), 0);
        SV **id = av_fetch(values, SvIV(*index), 0);
        /*
         * add it to the bson and the ids array
         */
        append_sv(buf, "_id", *id, stack, is_insert);
        av_push(ids, *id);
      }
      else {
        perl_mongo_prep(buf, ids);
      }
    }
    
    for (i=0; i<=av_len(keys); i++) {
        SV **k, **v;
        STRLEN len;
        const char *str;

        if (!(k = av_fetch(keys, i, 0)) ||
            !(v = av_fetch(values, i, 0))) {
            croak ("failed to fetch associative array value");
        }

        str = SvPV(*k, len);

        if (isUTF8(str, len)) {
          str = SvPVutf8(*k, len);
        }

        append_sv(buf, str, *v, stack, is_insert);
    }

    perl_mongo_serialize_null(buf);
    perl_mongo_serialize_size(buf->start+start, buf);

    // free the ixhash elem
    Safefree(stack);
}

static int isUTF8(const char *s, int len) {
  int i;

  for (i=0; i<len; i++) {
    if (i+3 < len &&
        (s[i] & 248) == 240 &&
        (s[i+1] & 192) == 128 &&
        (s[i+2] & 192) == 128 &&
        (s[i+3] & 192) == 128) {
      i += 3;
    }
    else if (i+2 < len && 
             (s[i] & 240) == 224 &&
             (s[i+1] & 192) == 128 &&
             (s[i+2] & 192) == 128) {
      i += 2;
    }
    else if (i+1 < len &&
             (s[i] & 224) == 192 &&
             (s[i+1] & 192) == 128) {
      i += 1;
    }
    else if ((s[i] & 128) != 0) {
      return 0;
    }
  }
  return 1;
}


static void
append_sv (buffer *buf, const char *key, SV *sv, stackette *stack, int is_insert)
{
    if (!SvOK(sv)) {
      if (SvGMAGICAL(sv)) {
        mg_get(sv);
      }
      else {
        set_type(buf, BSON_NULL);
        perl_mongo_serialize_key(buf, key, is_insert);
        return;
      }
    }

    if (SvROK (sv)) {
        if (sv_isobject (sv)) {
            /* OIDs */
            if (sv_derived_from (sv, "AnyMongo::BSON::OID")) {

mongo_support.c  view on Meta::CPAN

                case SVt_PVAV:
                    /* array */
                    set_type(buf, BSON_ARRAY);
                    perl_mongo_serialize_key(buf, key, is_insert);
                    av_to_bson (buf, (AV *)SvRV (sv), stack, is_insert);
                    break;
                case SVt_PV:
                    /* binary */
                    set_type(buf, BSON_BINARY);
                    perl_mongo_serialize_key(buf, key, is_insert);
                    perl_mongo_serialize_bindata(buf, SvRV(sv));
                    break;
                default:
                    sv_dump(SvRV(sv));
                    croak ("type (ref) unhandled");
            }
        }
    } else {
        switch (SvTYPE (sv)) {
	    /* double */
            case SVt_NV: 
            case SVt_PVNV: {
              if (SvNOK(sv)) {
                set_type(buf, BSON_DOUBLE);
                perl_mongo_serialize_key(buf, key, is_insert);
                perl_mongo_serialize_double(buf, (double)SvNV (sv));
                break;
              }
            }
            /* int */
            case SVt_IV:
            case SVt_PVIV: 
            case SVt_PVLV:
            case SVt_PVMG: {
              if (SvIOK(sv)) {
#if defined(USE_64_BIT_INT)
                set_type(buf, BSON_LONG);
                perl_mongo_serialize_key(buf, key, is_insert);
                perl_mongo_serialize_long(buf, (int64_t)SvIV(sv));
#else
                set_type(buf, BSON_INT);
                perl_mongo_serialize_key(buf, key, is_insert);
                perl_mongo_serialize_int(buf, (int)SvIV(sv));
#endif
                break;
              }

            }
	    /* string */
            case SVt_PV:
                if (sv_len (sv) != strlen (SvPV_nolen (sv))) {
                    set_type(buf, BSON_BINARY);
                    perl_mongo_serialize_key(buf, key, is_insert);
                    perl_mongo_serialize_bindata(buf, sv);
                }
                else {
                    STRLEN len;
                    const char *str = SvPV(sv, len);

                    if (!isUTF8(str, len)) {
                      str = SvPVutf8(sv, len);
                    }


                    set_type(buf, BSON_STRING);
                    perl_mongo_serialize_key(buf, key, is_insert);
                    perl_mongo_serialize_int(buf, len+1);
                    perl_mongo_serialize_string(buf, str, len);
                }
                break;
            default:
                sv_dump(sv);
                croak ("type (sv) unhandled");
        }
    }
}

static void serialize_regex(buffer *buf, const char *key, REGEXP *re, int is_insert) {
  set_type(buf, BSON_REGEX);
  perl_mongo_serialize_key(buf, key, is_insert);
  perl_mongo_serialize_string(buf, RX_PRECOMP(re), RX_PRELEN(re));
}

static void serialize_regex_flags(buffer *buf, SV *sv) {
  char flags[] = {0,0,0,0,0,0};
  int i = 0, f = 0;
  STRLEN string_length;
  char *string = SvPV(sv, string_length);
                
  for(i = 2; i < string_length && string[i] != '-'; i++) {
    if (string[i] == 'i' ||
        string[i] == 'm' ||
        string[i] == 'x' ||
        string[i] == 'l' ||
        string[i] == 's' ||
        string[i] == 'u') {
      flags[f++] = string[i];
    }
    else if(string[i] == ':') {
      break;
    }
  }

  perl_mongo_serialize_string(buf, flags, strlen(flags));
}


void
perl_mongo_sv_to_bson (buffer *buf, SV *sv, AV *ids)
{
    if (!SvROK (sv)) {
        croak ("not a reference");
    }

    switch (SvTYPE (SvRV (sv))) {
    case SVt_PVHV:
        hv_to_bson (buf, sv, ids, EMPTY_STACK, ids != 0);
        break;
    case SVt_PVAV: {
        if (sv_isa(sv, "Tie::IxHash")) {
            ixhash_to_bson(buf, sv, ids, EMPTY_STACK, ids != 0);
        }
        else {
            /*
             * this is a special case of array:
             * ("foo" => "bar", "baz" => "bat")
             * which is, as far as i can tell,
             * indistinguishable from a "normal"
             * array.
             */

            I32 i;
            AV *av = (AV *)SvRV (sv);
            int start;
            
            if ((av_len (av) % 2) == 0) {
                croak ("odd number of elements in structure");
            }
            
            start = buf->pos-buf->start;
            buf->pos += INT_32;
            
            /* 
             * the best (and not very good) way i can think of for 
             * checking for ids is to go through the array once
             * looking for them... blah
             */
            if (ids) {
                int has_id = 0;
                for (i = 0; i <= av_len(av); i+= 2) {
                    SV **key = av_fetch(av, i, 0);
                    if (strcmp(SvPV_nolen(*key), "_id") == 0) {
                        SV **val = av_fetch(av, i+1, 0);
                        has_id = 1;
                        append_sv(buf, "_id", *val, EMPTY_STACK, ids != 0);
                        av_push(ids, *val);
                        break;
                    }
                }
                if (!has_id) {
                    perl_mongo_prep(buf, ids);
                }
            }

            for (i = 0; i <= av_len (av); i += 2) {
                SV **key, **val;
                STRLEN len;
                const char *str;

                if ( !((key = av_fetch (av, i, 0)) && (val = av_fetch (av, i + 1, 0))) ) {
                    croak ("failed to fetch array element");
                }

                str = SvPV(*key, len);

                if (!isUTF8(str, len)) {
                    str = SvPVutf8(*key, len);
                }
                append_sv (buf, str, *val, EMPTY_STACK, ids != 0);
            }

            perl_mongo_serialize_null(buf);
            perl_mongo_serialize_size(buf->start+start, buf);
        }
        break;
    }
    default:
        sv_dump(sv);
        croak ("type unhandled");
    }
}