1 /*
2 * astTypemap.c
3
4 * Purpose:
5 * Helper code for AST object typemap processing and object handling
6
7 * Description:
8 * This file implements functions useful for converting AST C structs
9 * to Perl objects and Perl objects back to the corresponding C struct.
10 * Mainly used in the typemap file but can be used to simplify processing
11 * of PPCODE return arguments.
12 *
13 * In order to use these functions in a typemap file, declare each
14 * AST struct as a T_ASTOBJ and define the following INPUT and OUTPUT
15 * entries:
16 *
17 * TYPEMAP
18 * AstObject * T_ASTOBJ
19 *
20 * INPUT
21 * T_ASTOBJ
22 * if (sv_derived_from($arg, ntypeToClass(\"${ntype}\"))) {
23 * IV tmp = extractAstIntPointer( $arg );
24 * $var = INT2PTR($type,tmp);
25 * }
26 * else
27 * Perl_croak(aTHX_ \"$var is not of class %s\",ntypeToClass(\"${ntype}\"))
28 *
29 * OUTPUT
30 * T_ASTOBJ
31 * $arg = createPerlObject(\"${ntype}\", (void*)$var);
32
33 * Copyright:
34 * Copyright (C) 2004-2005 Tim Jenness.
35 * All Rights Reserved.
36
37 * Authors:
38 * TIMJ: Tim Jenness (JAC)
39
40 * History:
41 * 24-FEB-2004 (TIMJ):
42 * Original version
43 *
44 */
45
46 /* prototypes */
47 #ifdef __cplusplus
48 extern "C" {
49 #endif
50 #include "EXTERN.h" /* std perl include */
51 #include "perl.h" /* std perl include */
52 #include "XSUB.h" /* XSUB include */
53 #include "ppport.h"
54 #ifdef __cplusplus
55 }
56 #endif
57
58 #include "ast.h"
59 #include "astTypemap.h"
60
61 /* The name of the attribute in the perl object that handles the
62 IV representation of a pointer. */
63 static char pntrAttrib[9] = "_pointer";
64
65 /* The root namespace we are dealing with */
66 static char NAMESPACE[14] = "Starlink::AST";
67
68 /*
69 Given the XS version of the class name (which is directly related
70 to the struct name - AstObject * maps to AstObjectPtr), and a
71 pointer to an ast object, return an a reference to a Perl hash
72 blessed into the appropriate namespace. For example AstChannelPtr
73 will become Starlink::AST::Channel namespace.
74
75 See function ntypeToClass function for details of the XS to
76 namespace mapping.
77
78 If var is NULL the assumption is that you are creating the object
79 before storing the AstObject. Use the setPerlAstObject() function
80 to store the AST pointer at a later date.
81
82 */
83
createPerlObject(const char * xsntype,AstObject * var)84 SV* createPerlObject( const char * xsntype, AstObject * var ) {
85 HV * hash_object = newHV();
86 SV * rv;
87 SV * myobject;
88
89 /* Now create a reference to the hash object
90 Do not increment the reference count since at the end of this
91 we still only want a single reference to the hash to exist */
92 rv = newRV_noinc( (SV*)hash_object );
93
94 /* Bless the reference into a class. We translate the XS ntype
95 value into an appropriate Perl namespace */
96 myobject = sv_bless(rv, gv_stashpv( ntypeToClass(xsntype), 1));
97
98 /* Store the pointer if we were given one */
99 if (var != NULL) {
100 setPerlAstObject( myobject, var );
101 }
102
103 return myobject;
104 }
105
106
107 /*
108 * Given a perl object created by createPerlObject, store the
109 * pointer associated with an AST object in the appropriate place.
110 * Can be called by external function if you want to create a perl
111 * object (to store something else) prior to instantiating the
112 * C level AST object. */
113
setPerlAstObject(SV * myobject,AstObject * var)114 void setPerlAstObject ( SV * myobject, AstObject * var ) {
115 SV * pval;
116
117 /* extract the pointer to an int and store it in an SV */
118 pval = newSViv( PTR2IV(var) );
119
120 /* Now store it in the object */
121 setPerlObjectAttr( myobject, pntrAttrib, pval );
122
123 }
124
125 /* Given an AST object, return an IV containing the pointer to the
126 corresponding AST struct. Must use INT2PTR to convert this
127 value to an actual pointer.
128
129 */
130
extractAstIntPointer(SV * arg)131 IV extractAstIntPointer( SV * arg ) {
132 SV ** elem;
133 HV * hash_object;
134
135 /* Make sure we have a ref to a hash and get hold of hash */
136 /* Code comes from T_HVREF typemap entry */
137 if (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVHV)
138 hash_object = (HV*)SvRV(arg);
139 else
140 Perl_croak(aTHX_ "Arg is not a hash reference");
141
142 /* Fetch the integer from the hash */
143 elem = hv_fetch( hash_object, pntrAttrib, strlen(pntrAttrib), 0);
144
145 /* make sure we got something */
146 if (elem == NULL ) {
147 Perl_croak(aTHX_ "Error extracting _pointer attribute from object");
148 }
149
150 /* extract the actual IV from the element */
151 return SvIV( *elem );
152 }
153
154
155 /* Convert an XS ntype value (eg AstFitsChanPtr) to an appropriate user
156 friendly perl namespace (eg Starlink::AST::FitsChan)
157
158 Note that "AstObjectPtr" is special-cased to "Starlink::AST"
159
160 Note also that if you supply an ntype that looks like a fully qualified
161 class already (ie it matches the root namespace) then the class is
162 returned unaffected). This allows you to use the object creation
163 code outside of a typemap entry where you are manually creating the
164 object using a constructor that supplies the correct class.
165
166 */
167
ntypeToClass(const char * ntype)168 char * ntypeToClass ( const char * ntype ) {
169 SV * buffer;
170 int len;
171 const char * offset;
172
173 /* Do we have Starlink::AST in the name already? */
174 if (strstr( ntype, NAMESPACE) != NULL ) {
175 buffer = sv_2mortal( newSVpv("",0));
176 sv_catpvn( buffer, ntype, strlen(ntype) );
177 return SvPVX(buffer);
178 }
179
180 /* Easy case - we want the default namespace */
181 if ( strcmp(ntype, "AstObjectPtr" ) == 0 ) {
182 return NAMESPACE;
183 }
184
185 /* Bit harder - convert we need to extract the bit between the
186 Ast and the Ptr and append that to NAMESPACE:: */
187
188 /* Get a mortal SV so I do not need to worry about strcpy et al */
189 buffer = sv_2mortal(newSVpv("",0));
190
191 /* Copy in all the bits */
192 sv_catpvn( buffer, NAMESPACE, strlen(NAMESPACE) );
193 sv_catpvn( buffer, "::", 2 );
194 len = strlen(ntype) - 6; /* Length without "Ast" and "Ptr" */
195 offset = ntype + 3; /* jump in 3 characters */
196 sv_catpvn( buffer, offset, len ); /* append substring */
197
198 /* now return the pointer */
199 return SvPVX( buffer );
200 }
201
202 /* An internal hash object attribute accessor return the relevant SV given
203 a reference to the object and a attribute name.
204
205 Returns NULL if no value is stored or if the supplied SV is not a reference.
206
207 Does not set astError. Croaks if the SV is defined but is not of the
208 correct type.
209 */
210
getPerlObjectAttr(SV * myobject,const char * attr)211 SV* getPerlObjectAttr ( SV * myobject, const char * attr ) {
212 SV** elem;
213 HV * hash_object;
214
215 if (myobject == NULL || !SvOK(myobject) ) {
216 return NULL;
217 }
218
219 /* Make sure we have a reference to a hash */
220 if (SvROK(myobject) && SvTYPE(SvRV(myobject))==SVt_PVHV)
221 hash_object = (HV*)SvRV(myobject);
222 else
223 Perl_croak(aTHX_ "Ast object must be a reference to a hash");
224
225 /* retrieve the element */
226 elem = hv_fetch( hash_object, attr, strlen(attr), 0);
227
228 /* trap for undef */
229 if (elem == NULL || !SvOK(*elem) ) {
230 return NULL;
231 } else {
232 return *elem;
233 }
234 }
235
236
237 /* Given a Perl object created by createPerlObject, store an SV into
238 * a specific attribute. Reverse of getPerlObjectAttr.
239 *
240 * Croaks on error.
241 */
242
setPerlObjectAttr(SV * myobject,const char * attr,SV * value)243 void setPerlObjectAttr ( SV * myobject, const char * attr, SV * value ) {
244 SV** retval;
245 HV * hash_object;
246
247 if (myobject == NULL || !SvOK(myobject) ) {
248 Perl_croak(aTHX_ "Must supply a valid SV/object to setPerlObjectAttr");
249 }
250
251 /* Make sure we have a reference to a hash */
252 if (SvROK(myobject) && SvTYPE(SvRV(myobject))==SVt_PVHV)
253 hash_object = (HV*)SvRV(myobject);
254 else
255 Perl_croak(aTHX_ "Ast object must be a reference to a hash");
256
257
258 /* Store that SV into a hash using the appropriate key */
259 retval = hv_store( hash_object, attr, strlen(attr),
260 value,0);
261
262 /* If the store fails, free up the SV created earlier and croak */
263 if (retval == NULL ) {
264 SvREFCNT_dec( value );
265 Perl_croak(aTHX_ "Error storing AstObject pointer into hash\n");
266 }
267 }
268
269
270 /*
271 * Copies the contents of $@ into the AST error system. Tests $@ before
272 * trying to read it. Returns 0 if $@ contained something (ie an error
273 * that is suitable for return to ast) and 1 if $@ was empty. This
274 * allows you to call this method immediately after an eval.
275 *
276 * $@ is split across multiple lines.
277 */
278
279 # define ASTPERL_ERRBUFF 72
280
ReportPerlError(int astcode)281 int ReportPerlError( int astcode ) {
282 char * dollarat;
283 int lengthat;
284 int strindex = 0;
285 char errbuff[ASTPERL_ERRBUFF]; /* Eval error message buffer */
286 int retval;
287
288 /* Check the status of the eval */
289 if (SvTRUE(GvSV(PL_errgv))) {
290
291 /* This code stolen from my Perl DRAMA interface */
292
293 /* Get the error message */
294 dollarat = SvPV(GvSV(PL_errgv), PL_na);
295 lengthat = strlen(dollarat);
296
297 /* and split into chunks. Really need the equivalent of Text::Wrap */
298 while (strindex < lengthat ) {
299 int length = ASTPERL_ERRBUFF-1;
300 if (strindex + length >= lengthat ) {
301 length = lengthat - strindex;
302 }
303 Copy(dollarat+strindex,errbuff,length,char);
304 errbuff[length] = '\0';
305 /* Remove newline character from end of string */
306 if (errbuff[length-1] == '\n') errbuff[length-1] = '\0';
307
308 astError( astcode, "%s", errbuff );
309
310 strindex += length;
311 }
312
313 /* bad ast return value */
314 retval = 0;
315 } else {
316 /* everything okay */
317 retval = 1;
318 }
319 return retval;
320 }
321