view release on metacpan or  search on metacpan

lib/Crypt/OpenSSL/CA/Inline/C.pm  view on Meta::CPAN

static inline SV* perl_wrap(const char* class, void* pointer) {
     SV*      obj = sv_setref_pv(newSV(0), class, pointer);
     if (! obj) { croak("not enough memory"); }
     SvREADONLY_on(SvRV(obj));
     return obj;
}

#define perl_unwrap(class, typename, obj) \
  ((typename) __perl_unwrap(__FILE__, __LINE__, (class), (obj)))

static inline void* __perl_unwrap(const char* file, int line,
                                  const char* class, SV* obj) {
    if (!(sv_isobject(obj) && sv_isa(obj, class))) {
      croak("%s:%d:perl_unwrap: got an invalid "
                "Perl argument (expected an object blessed "
                "in class ``%s'')", file, line, (class));
    }
    return (void *)(intptr_t)SvIV(SvRV(obj));
}

static inline SV* openssl_buf_to_SV(char* string, int length) {
/* Note that a newmortal is not wanted here, even though
 * caller will typically return the SV* to Perl. This is because XS
 * performs some magic of its own for functions that return an SV (as
 * documented in L<perlxs/Returning SVs, AVs and HVs through RETVAL>)
 * and Inline::C leverages that. */
   SV* retval = newSVpv(string, length);
   OPENSSL_free(string);
   return retval;
}

static inline SV* openssl_string_to_SV(char* string) {
   return openssl_buf_to_SV(string, 0);
}

static inline SV* BIO_mem_to_SV(BIO *mem) {
   SV* retval;
   BUF_MEM* buf;

   BIO_get_mem_ptr(mem, &buf);
   if (! buf) {
        BIO_free(mem);
        croak("BIO_get_mem_ptr failed");
   }
   retval = newSVpv(buf->data, 0);
   if (! retval) {
        BIO_free(mem);
        croak("newSVpv failed");
   }
   BIO_free(mem);
   return retval;
}

#define ERRBUFSZ 512
#define THISPACKAGE "Crypt::OpenSSL::CA"
static void sslcroak(char *fmt, ...) {
    va_list ap;                 /* The argument list hiding behind the
                                   hyphens in the protype above */
    dSP;                        /* Required to be able to perform Perl
                                   callbacks */
    char* argv[3];              /* The list of arguments to pass to the
                                   callback */
    char croakbuf[ERRBUFSZ];    /* The buffer to typeset the main error
                                   message into */
    char errbuf[ERRBUFSZ];      /* The buffer to typeset the auxillary error
                                   messages from OpenSSL into */
    SV* dollar_at;              /* Used to probe $@ to see if everything
                                   went well with the callback */
    unsigned long sslerr;       /* Will iterate through the OpenSSL
                                   error stack */

    va_start(ap, fmt);
    vsnprintf(croakbuf, ERRBUFSZ, fmt, ap);
    croakbuf[ERRBUFSZ - 1] = '\0';
    va_end(ap);

    argv[0] = "-message";
    argv[1] = croakbuf;
    argv[2] = NULL;
    call_argv(THISPACKAGE "::_sslcroak_callback", G_DISCARD, argv);

    argv[0] = "-openssl";
    argv[1] = errbuf;
    while( (sslerr = ERR_get_error()) ) {
        ERR_error_string_n(sslerr, errbuf, ERRBUFSZ);
        errbuf[ERRBUFSZ - 1] = '\0';
        call_argv(THISPACKAGE "::_sslcroak_callback", G_DISCARD, argv);
    }
    argv[0] = "DONE";
    argv[1] = NULL;
    call_argv(THISPACKAGE "::_sslcroak_callback", G_DISCARD, argv);

    dollar_at = get_sv("@", FALSE);
    if (dollar_at && sv_isobject(dollar_at)) {
         // Success!
         croak(Nullch);
    } else {
         // Something went bang, revert to the croakbuf.
         croak("%s", croakbuf);
    }
}

C_BOILERPLATE

=head2 BOOT-time effect

Each C<.so> XS module will be fitted with a C<BOOT> section (see
L<Inline::C/BOOT> which automatically gets executed upon loading it
with L<DynaLoader> or L<XSLoader>. The C<BOOT> section is the same for
all subpackages in L<Crypt::OpenSSL::CA>; it ensures that various
stuff is loaded inside OpenSSL, such as C<ERR_load_crypto_strings()>,
C<OpenSSL_add_all_algorithms()> and all that jazz.  After the boot
code completes, C<$Crypt::OpenSSL::CA::openssl_stuff_loaded> will be
1, so that the following XS modules can skip that when they in turn
get loaded.

=cut

sub _c_boot_section { <<"ENSURE_OPENSSL_STUFF_LOADED" }
    SV* already_loaded = get_sv