view release on metacpan or  search on metacpan

mongo_support.c  view on Meta::CPAN

}

void perl_mongo_serialize_int(buffer *buf, int num) {
  int i = MONGO_32(num);

  if(BUF_REMAINING <= INT_32) {
    perl_mongo_resize_buf(buf, INT_32);
  }

  memcpy(buf->pos, &i, INT_32);
  buf->pos += INT_32;
}

void perl_mongo_serialize_long(buffer *buf, int64_t num) {
  int64_t i = MONGO_64(num);

  if(BUF_REMAINING <= INT_64) {
    perl_mongo_resize_buf(buf, INT_64);
  }

  memcpy(buf->pos, &i, INT_64);
  buf->pos += INT_64;
}

void perl_mongo_serialize_double(buffer *buf, double num) {
  int64_t dest, *dest_p;
  dest_p = &dest;
  memcpy(dest_p, &num, 8);
  dest = MONGO_64(dest);
 
  if(BUF_REMAINING <= DOUBLE_64) {
    perl_mongo_resize_buf(buf, DOUBLE_64);
  }
 
  memcpy(buf->pos, dest_p, DOUBLE_64);
  buf->pos += DOUBLE_64;
}

void perl_mongo_serialize_oid(buffer *buf, char *id) {
  int i;

  if(BUF_REMAINING <= OID_SIZE) {
    perl_mongo_resize_buf(buf, OID_SIZE);
  }

  for(i=0;i<OID_SIZE;i++) {
    char digit1 = id[i*2], digit2 = id[i*2+1];
    digit1 = digit1 >= 'a' && digit1 <= 'f' ? digit1 - 87 : digit1;
    digit1 = digit1 >= 'A' && digit1 <= 'F' ? digit1 - 55 : digit1;
    digit1 = digit1 >= '0' && digit1 <= '9' ? digit1 - 48 : digit1;

    digit2 = digit2 >= 'a' && digit2 <= 'f' ? digit2 - 87 : digit2;
    digit2 = digit2 >= 'A' && digit2 <= 'F' ? digit2 - 55 : digit2;
    digit2 = digit2 >= '0' && digit2 <= '9' ? digit2 - 48 : digit2;

    buf->pos[i] = digit1*16+digit2;
  }
  buf->pos += OID_SIZE;
}

void perl_mongo_serialize_bindata(buffer *buf, SV *sv)
{
  STRLEN len;
  const char *bytes = SvPVbyte (sv, len);

  // length of length+bindata
  perl_mongo_serialize_int(buf, len+4);
  
  // TODO: type
  perl_mongo_serialize_byte(buf, 2);
  
  // length
  perl_mongo_serialize_int(buf, len);
  // bindata
  perl_mongo_serialize_bytes(buf, bytes, len);
}

void perl_mongo_serialize_key(buffer *buf, const char *str, int is_insert) {
  SV *c = get_sv("AnyMongo::BSON::char", 0);

  if(BUF_REMAINING <= strlen(str)+1) {
    perl_mongo_resize_buf(buf, strlen(str)+1);
  }

  if (strlen(str) == 0) {
      croak("empty key name, did you use a $ with double quotes?");
  }

  if (is_insert && strchr(str, '.')) {
      croak("inserts cannot contain the . character");
  }

  if (c && SvPOK(c) && SvPV_nolen(c)[0] == str[0]) {
    *(buf->pos) = '$';
    memcpy(buf->pos+1, str+1, strlen(str)-1);
  }
  else {
    memcpy(buf->pos, str, strlen(str));
  }

  // add \0 at the end of the string
  buf->pos[strlen(str)] = 0;
  buf->pos += strlen(str) + 1;
}


/* the position is not increased, we are just filling
 * in the first 4 bytes with the size.
 */
void perl_mongo_serialize_size(char *start, buffer *buf) {
  int total = buf->pos - start;
  total = MONGO_32(total);

  memcpy(start, &total, INT_32);
}

void perl_mongo_make_id(char *id) {
  //SV *temp;
  char *data = id;

  // the pid is stored in $$
  SV *pid_s = get_sv("$", 0);
  // ...but if it's not, don't crash
  int pid = pid_s ? SvIV(pid_s) : rand();

  int r1 = rand();
  int inc = perl_mongo_inc++;

  unsigned t = (unsigned) time(0);

  char *T = (char*)&t,
    *M = (char*)&r1,
    *P = (char*)&pid,
    *I = (char*)&inc;

mongo_support.c  view on Meta::CPAN

              buf->pos += INT_32;

              code = perl_mongo_call_reader (sv, "code");
              code_str = SvPV(code, code_len);
              perl_mongo_serialize_int(buf, code_len+1);
              perl_mongo_serialize_string(buf, code_str, code_len);

              scope = perl_mongo_call_method (sv, "scope", 0);
              hv_to_bson(buf, scope, NO_PREP, EMPTY_STACK, is_insert);

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

              SvREFCNT_dec(code);
              SvREFCNT_dec(scope);
            }
            else if (sv_isa(sv, "AnyMongo::BSON::Timestamp") || sv_derived_from(sv,"AnyMongo::BSON::Timestamp")) {
              SV *sec, *inc;
              set_type(buf, BSON_TIMESTAMP);
              perl_mongo_serialize_key(buf, key, is_insert);
              
              inc = perl_mongo_call_reader(sv, "inc");
              perl_mongo_serialize_int(buf, SvIV(inc));
              sec = perl_mongo_call_reader(sv, "sec");
              perl_mongo_serialize_int(buf, SvIV(sec));

              SvREFCNT_dec(sec);
              SvREFCNT_dec(inc);
            }
            else if (sv_isa(sv, "AnyMongo::BSON::MinKey") || sv_isa(sv, "MongoDB::MinKey")) {
              set_type(buf, BSON_MINKEY);
              perl_mongo_serialize_key(buf, key, is_insert);
            }
            else if (sv_isa(sv, "AnyMongo::BSON::MaxKey") || sv_isa(sv, "MongoDB::MaxKey")) {
              set_type(buf, BSON_MAXKEY);
              perl_mongo_serialize_key(buf, key, is_insert);
            }
#if PERL_REVISION==5 && PERL_VERSION>=12
            // Perl 5.12 regexes
            else if (sv_isa(sv, "Regexp")) {
              REGEXP * re = SvRX(sv);
              
              serialize_regex(buf, key, re, is_insert);
              serialize_regex_flags(buf, sv);
            }
#endif
            else if (SvTYPE(SvRV(sv)) == SVt_PVMG) {

              MAGIC *remg;

              /* regular expression */
              if ((remg = mg_find((SV*)SvRV(sv), PERL_MAGIC_qr)) != 0) {
                REGEXP *re = (REGEXP *) remg->mg_obj;

                serialize_regex(buf, key, re, is_insert);
                serialize_regex_flags(buf, sv);                
              }
              else {
		/* binary */
                set_type(buf, BSON_BINARY);
                perl_mongo_serialize_key(buf, key, is_insert);
                perl_mongo_serialize_bindata(buf, SvRV(sv));
              }
            }
        } else {
            switch (SvTYPE (SvRV (sv))) {
                case SVt_PVHV:
                    /* hash */
                    set_type(buf, BSON_OBJECT);
                    perl_mongo_serialize_key(buf, key, is_insert);
                    /* don't add a _id to inner objs */
                    hv_to_bson (buf, sv, NO_PREP, stack, is_insert);
                    break;
                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");
    }