/*
* Copyright (c) 2004-2011 by the cairo perl team (see the file README)
*
* Licensed under the LGPL, see LICENSE file for more information.
*
* $Id$
*/
#include <cairo-perl.h>
#include <cairo-perl-private.h>
#include "ppport.h"
#define MY_MAGIC_SIG 0xCAFE /* Let's hope this is unique enough */
static MAGIC *
cairo_perl_mg_find (SV *sv, int type)
{
if (sv) {
MAGIC *mg;
for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
if (mg->mg_type == type && mg->mg_private == MY_MAGIC_SIG)
return mg;
}
}
return NULL;
}
static void *
cairo_perl_mg_get (SV * sv)
{
MAGIC * mg;
if (!cairo_perl_sv_is_ref (sv) ||
!(mg = cairo_perl_mg_find (SvRV (sv), PERL_MAGIC_ext)))
return NULL;
return mg->mg_ptr;
}
/* ------------------------------------------------------------------------- */
static SV *
create_tie (SV * sv, void * object, const char * package)
{
SV * tie;
HV * stash;
MAGIC * mg;
/* Create a tied reference. */
tie = newRV_noinc (sv);
stash = gv_stashpv (package, TRUE);
sv_bless (tie, stash);
sv_magic (sv, tie, PERL_MAGIC_tied, Nullch, 0);
/* Associate the array with the original path via magic. */
sv_magic (sv, 0, PERL_MAGIC_ext, (const char *) object, 0);
mg = mg_find (sv, PERL_MAGIC_ext);
/* Mark the mg as belonging to us. */
mg->mg_private = MY_MAGIC_SIG;
#if PERL_REVISION <= 5 && PERL_VERSION <= 6
/* perl 5.6.x doesn't actually set mg_ptr when namlen == 0, so do it
* now. */
mg->mg_ptr = (char *) object;
#endif /* 5.6.x */
return tie;
}
static SV *
create_tied_av (void * object, const char * package)
{
return create_tie ((SV *) newAV (), object, package);
}
static SV *
create_tied_hv (void * object, const char * package)
{
return create_tie ((SV *) newHV (), object, package);
}
/* ------------------------------------------------------------------------- */
#define FETCH_POINT(i) \
if ((svp = av_fetch (points, i, 0)) && \
cairo_perl_sv_is_defined (*svp)) \
{ \
point = (AV *) SvRV (*svp); \
if ((svp = av_fetch (point, 0, 0))) \
data[i+1].point.x = SvNV (*svp); \
if ((svp = av_fetch (point, 1, 0))) \
data[i+1].point.y = SvNV (*svp); \
}
static void
fill_data_from_array (cairo_path_data_t * data, cairo_path_data_type_t type, AV * points)
{
SV ** svp;
AV * point;
switch (type) {
case CAIRO_PATH_MOVE_TO:
data->header.type = CAIRO_PATH_MOVE_TO;
data->header.length = 2;
FETCH_POINT (0);
break;
case CAIRO_PATH_LINE_TO:
data->header.type = CAIRO_PATH_LINE_TO;
data->header.length = 2;
FETCH_POINT (0);
break;
case CAIRO_PATH_CURVE_TO:
data->header.type = CAIRO_PATH_CURVE_TO;
data->header.length = 4;
FETCH_POINT (0);
FETCH_POINT (1);
FETCH_POINT (2);
break;
case CAIRO_PATH_CLOSE_PATH:
data->header.type = CAIRO_PATH_CLOSE_PATH;
data->header.length = 1;
break;
}
}
/* This uses cairo_perl_alloc_temp. So the return value is only valid until
* the next FREETMPS occurs. At the moment, the only cairo function that
* *takes* a cairo_path_t is cairo_append_path, and it acts on the path
* immediately and does not store it. So that's fine. */
static cairo_path_t *
path_from_array (SV * sv)
{
AV *av;
int i, num_data;
cairo_path_t *path;
cairo_path_data_t *data;
if (!cairo_perl_sv_is_array_ref (sv))
croak ("a Cairo::Path has to be an array reference");
av = (AV *) SvRV (sv);
num_data = 0;
for (i = 0; i <= av_len (av); i++) {
SV **svp;
HV *hv;
svp = av_fetch (av, i, 0);
if (!svp || !cairo_perl_sv_is_hash_ref (*svp))
croak ("a Cairo::Path has to contain hash references");
hv = (HV *) SvRV (*svp);
svp = hv_fetch (hv, "type", 4, 0);
if (!svp || !cairo_perl_sv_is_defined (*svp))
croak ("hash references inside a Cairo::Path must have a 'type' key");
switch (cairo_path_data_type_from_sv (*svp)) {
case CAIRO_PATH_MOVE_TO:
case CAIRO_PATH_LINE_TO:
num_data += 2;
break;
case CAIRO_PATH_CURVE_TO:
num_data += 4;
break;
case CAIRO_PATH_CLOSE_PATH:
num_data += 1;
break;
}
}
path = cairo_perl_alloc_temp (sizeof (cairo_path_t));
path->num_data = num_data;
path->data = cairo_perl_alloc_temp (path->num_data * sizeof (cairo_path_data_t));
path->status = CAIRO_STATUS_SUCCESS;
data = path->data;
for (i = 0; i <= av_len (av); i++) {
SV **svp;
HV *hv;
AV *points;
svp = av_fetch (av, i, 0);
hv = (HV *) SvRV (*svp);
svp = hv_fetch (hv, "points", 6, 0);
if (!svp || !cairo_perl_sv_is_array_ref (*svp))
croak ("hash references inside a Cairo::Path must "
"contain a 'points' key which contains an array "
"reference of points");
points = (AV *) SvRV (*svp);
svp = hv_fetch (hv, "type", 4, 0);
fill_data_from_array (data, cairo_path_data_type_from_sv (*svp), points);
data += data->header.length;
}
return path;
}
SV *
newSVCairoPath (cairo_path_t * path)
{
return create_tied_av (path, "Cairo::Path");
}
cairo_path_t *
SvCairoPath (SV * sv)
{
cairo_path_t * path;
path = cairo_perl_mg_get (sv);
if (!path) {
path = path_from_array (sv);
}
return path;
}
/* ------------------------------------------------------------------------- */
static SV *
newSVCairoPathData (cairo_path_data_t * data)
{
return create_tied_hv (data, "Cairo::Path::Data");
}
static cairo_path_data_t *
SvCairoPathData (SV * sv)
{
return cairo_perl_mg_get (sv);
}
/* ------------------------------------------------------------------------- */
static SV *
newSVCairoPathPoints (cairo_path_data_t * data)
{
return create_tied_av (data, "Cairo::Path::Points");
}
static cairo_path_data_t *
SvCairoPathPoints (SV * sv)
{
return cairo_perl_mg_get (sv);
}
/* ------------------------------------------------------------------------- */
static SV *
newSVCairoPathPoint (cairo_path_data_t * data)
{
return create_tied_av (data, "Cairo::Path::Point");
}
static cairo_path_data_t *
SvCairoPathPoint (SV * sv)
{
return cairo_perl_mg_get (sv);
}
/* ------------------------------------------------------------------------- */
static IV
n_points (cairo_path_data_t * data)
{
switch (data->header.type) {
case CAIRO_PATH_MOVE_TO:
case CAIRO_PATH_LINE_TO:
return 1;
case CAIRO_PATH_CURVE_TO:
return 3;
case CAIRO_PATH_CLOSE_PATH:
return 0;
}
return -1;
}
/* ------------------------------------------------------------------------- */
MODULE = Cairo::Path PACKAGE = Cairo::Path
void DESTROY (SV * sv)
PREINIT:
cairo_path_t *path;
CODE:
path = SvCairoPath (sv);
if (path) {
#if PERL_REVISION <= 5 && PERL_VERSION <= 6
/* Unset mg_ptr to prevent perl 5.6.x from trying to free it again. */
MAGIC *mg = cairo_perl_mg_find (SvRV (sv), PERL_MAGIC_ext);
mg->mg_ptr = NULL;
#endif /* 5.6.x */
cairo_path_destroy (path);
}
IV FETCHSIZE (cairo_path_t * path)
PREINIT:
int i;
CODE:
RETVAL = 0;
for (i = 0; i < path->num_data; i += path->data[i].header.length)
RETVAL++;
OUTPUT:
RETVAL
SV * FETCH (cairo_path_t * path, IV index)
PREINIT:
int i, counter = 0;
CODE:
RETVAL = &PL_sv_undef;
for (i = 0; i < path->num_data; i += path->data[i].header.length) {
if (counter++ == index) {
cairo_path_data_t *data = &path->data[i];
RETVAL = newSVCairoPathData (data);
break;
}
}
OUTPUT:
RETVAL
# --------------------------------------------------------------------------- #
MODULE = Cairo::Path PACKAGE = Cairo::Path::Data
#if PERL_REVISION <= 5 && PERL_VERSION <= 6
void DESTROY (SV * sv)
CODE:
/* Unset mg_ptr to prevent perl 5.6.x from trying to free it. */
MAGIC *mg = cairo_perl_mg_find (SvRV (sv), PERL_MAGIC_ext);
if (mg)
mg->mg_ptr = NULL;
#endif /* 5.6.x */
SV * FETCH (SV * sv, const char * key)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathData (sv);
if (strEQ (key, "type")) {
RETVAL = cairo_path_data_type_to_sv (data->header.type);
} else if (strEQ (key, "points")) {
RETVAL = newSVCairoPathPoints (data);
} else {
croak ("Unknown key '%s' for Cairo::Path::Data", key);
RETVAL = NULL;
}
OUTPUT:
RETVAL
SV * STORE (SV * sv, const char * key, SV * value)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathData (sv);
if (strEQ (key, "points")) {
RETVAL = newSVCairoPathPoints (data);
fill_data_from_array (data, data->header.type, (AV *) SvRV (value));
} else {
croak ("Unhandled key '%s' for Cairo::Path::Data; "
"only changing 'points' is supported", key);
RETVAL = NULL;
}
OUTPUT:
RETVAL
bool EXISTS (sv, const char * key)
CODE:
if (strEQ (key, "type")) {
RETVAL = TRUE;
} else if (strEQ (key, "points")) {
RETVAL = TRUE;
} else {
RETVAL = FALSE;
}
OUTPUT:
RETVAL
const char * FIRSTKEY (sv)
CODE:
RETVAL = "type";
OUTPUT:
RETVAL
const char * NEXTKEY (sv, const char * lastkey)
CODE:
if (strEQ (lastkey, "type")) {
RETVAL = "points";
} else {
RETVAL = NULL;
}
OUTPUT:
RETVAL
# --------------------------------------------------------------------------- #
MODULE = Cairo::Path PACKAGE = Cairo::Path::Points
#if PERL_REVISION <= 5 && PERL_VERSION <= 6
void DESTROY (SV * sv)
CODE:
/* Unset mg_ptr to prevent perl 5.6.x from trying to free it. */
MAGIC *mg = cairo_perl_mg_find (SvRV (sv), PERL_MAGIC_ext);
if (mg)
mg->mg_ptr = NULL;
#endif /* 5.6.x */
IV FETCHSIZE (SV * sv)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathPoints (sv);
RETVAL = n_points (data);
OUTPUT:
RETVAL
SV * FETCH (SV * sv, IV index)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathPoints (sv);
if (index >= 0 && index < n_points (data)) {
RETVAL = newSVCairoPathPoint (&data[index + 1]);
} else {
RETVAL = &PL_sv_undef;
}
OUTPUT:
RETVAL
SV * STORE (SV * sv, IV index, SV * value)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathPoints (sv);
if (index >= 0 && index < n_points (data)) {
cairo_path_data_t * point;
AV * av;
SV ** svp;
point = &data[index + 1];
RETVAL = newSVCairoPathPoint (point);
av = (AV *) SvRV (value);
if ((svp = av_fetch (av, 0, 0)))
point->point.x = SvNV (*svp);
if ((svp = av_fetch (av, 1, 0)))
point->point.y = SvNV (*svp);
} else {
RETVAL = &PL_sv_undef;
}
OUTPUT:
RETVAL
# --------------------------------------------------------------------------- #
MODULE = Cairo::Path PACKAGE = Cairo::Path::Point
#if PERL_REVISION <= 5 && PERL_VERSION <= 6
void DESTROY (SV * sv)
CODE:
/* Unset mg_ptr to prevent perl 5.6.x from trying to free it. */
MAGIC *mg = cairo_perl_mg_find (SvRV (sv), PERL_MAGIC_ext);
if (mg)
mg->mg_ptr = NULL;
#endif /* 5.6.x */
IV FETCHSIZE (sv)
CODE:
RETVAL = 2;
OUTPUT:
RETVAL
SV * FETCH (SV * sv, IV index)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathPoint (sv);
switch (index) {
case 0:
RETVAL = newSVnv (data->point.x);
break;
case 1:
RETVAL = newSVnv (data->point.y);
break;
default:
RETVAL = &PL_sv_undef;
break;
}
OUTPUT:
RETVAL
SV * STORE (SV * sv, IV index, NV value)
PREINIT:
cairo_path_data_t * data;
CODE:
data = SvCairoPathPoint (sv);
switch (index) {
case 0:
RETVAL = newSVnv (data->point.x = value);
break;
case 1:
RETVAL = newSVnv (data->point.y = value);
break;
default:
RETVAL = &PL_sv_undef;
break;
}
OUTPUT:
RETVAL