« back to all changes in this revision
Viewing changes to GType.xs
- browse files at revision 9
- compare with another revision
- download diff
- download tarball
- view history from revision 9
- Committer: Bazaar Package Importer
- Author(s): Marc 'HE' Brockschmidt
- Date: 2008-03-15 09:40:14 UTC
- mfrom: (1.1.10 upstream)
- Revision ID: james.westby@ubuntu.com-20080315094014-af0fqrtad5fq1u0f
Tags: 1:1.181-1
New upstream release (only changes in the build system irrelevant for
Debian, but for completeness' sake...)
Debian, but for completeness' sake...)
- files added:
- t/make_helper.t
- files modified:
- AUTHORS
added
removed
GType.xs
16
16
* along with this library; if not, write to the Free Software Foundation,
17
17
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA.
18
18
*
19
* $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GType.xs,v 1.78 2007/08/13 18:37:39 kaffeetisch Exp $
19
* $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GType.xs,v 1.85 2008/01/17 20:55:51 kaffeetisch Exp $
20
20
*/
21
21
22
22
=head2 GType / GEnum / GFlags
418
418
{
419
419
if (SvROK (val) && sv_derived_from (val, "Glib::Flags"))
420
420
return SvIV (SvRV (val));
421
if (SvROK (val) && SvTYPE (SvRV(val)) == SVt_PVAV) {
421
if (gperl_sv_is_array_ref (val)) {
422
422
AV* vals = (AV*) SvRV(val);
423
423
gint value = 0;
424
424
int i;
697
697
#ifdef WIN32
698
698
# ifdef _MSC_VER
699
699
# define PORTABLE_STRTOLL(str, end, base) _strtoi64 (str, end, base)
700
# define PORTABLE_LL_FORMAT "%I64d"
700
701
# else
701
702
# define PORTABLE_STRTOLL(str, end, base) strtol (str, end, base)
703
# define PORTABLE_LL_FORMAT "%ld"
702
704
# endif
703
705
#else
704
706
# define PORTABLE_STRTOLL(str, end, base) strtoll (str, end, base)
707
# define PORTABLE_LL_FORMAT "%lld"
705
708
#endif
706
709
707
710
gint64
731
734
STRLEN length;
732
735
SV *sv;
733
736
734
/* newSVpvf doesn't seem to work correctly. */
735
length = sprintf(string, "%lld", value);
737
/* newSVpvf doesn't seem to work correctly.
738
sv = newSVpvf (PORTABLE_LL_FORMAT, value); */
739
length = sprintf(string, PORTABLE_LL_FORMAT, value);
736
740
sv = newSVpv (string, length);
737
741
738
742
return sv;
749
753
#ifdef WIN32
750
754
# ifdef _MSC_VER
751
755
# define PORTABLE_STRTOULL(str, end, base) _strtoui64 (str, end, base)
756
# define PORTABLE_ULL_FORMAT "%I64u"
752
757
# else
753
758
# define PORTABLE_STRTOULL(str, end, base) strtoul (str, end, base)
759
# define PORTABLE_ULL_FORMAT "%lu"
754
760
# endif
755
761
#else
756
762
# define PORTABLE_STRTOULL(str, end, base) strtoull (str, end, base)
763
# define PORTABLE_ULL_FORMAT "%llu"
757
764
#endif
758
765
759
766
guint64
783
790
STRLEN length;
784
791
SV *sv;
785
792
786
/* newSVpvf doesn't seem to work correctly. */
787
length = sprintf(string, "%llu", value);
793
/* newSVpvf doesn't seem to work correctly.
794
sv = newSVpvf (PORTABLE_ULL_FORMAT, value); */
795
length = sprintf(string, PORTABLE_ULL_FORMAT, value);
788
796
sv = newSVpv (string, length);
789
797
790
798
return sv;
1095
1103
PERL_UNUSED_VAR (signal_name);
1096
1104
1097
1105
svp = hv_fetch (hv, "flags", 5, FALSE);
1098
if (svp && (*svp) && SvOK (*svp))
1106
if (svp && gperl_sv_is_defined (*svp))
1099
1107
s->flags = SvGSignalFlags (*svp);
1100
1108
1101
1109
svp = hv_fetch (hv, "param_types", 11, FALSE);
1102
if (svp && (*svp) && SvROK (*svp)
1103
&& SvTYPE (SvRV (*svp)) == SVt_PVAV) {
1110
if (svp && gperl_sv_is_array_ref (*svp)) {
1104
1111
guint i;
1105
1112
AV * av = (AV*) SvRV (*svp);
1106
1113
s->n_params = av_len (av) + 1;
1118
1125
1119
1126
svp = hv_fetch (hv, "class_closure", 13, FALSE);
1120
1127
if (svp && *svp) {
1121
if (SvOK (*svp))
1128
if (gperl_sv_is_defined (*svp))
1122
1129
s->class_closure =
1123
1130
gperl_closure_new (*svp, NULL, FALSE);
1124
1131
/* else the class closure is NULL */
1127
1134
}
1128
1135
1129
1136
svp = hv_fetch (hv, "return_type", 11, FALSE);
1130
if (svp && (*svp) && SvOK (*svp)) {
1137
if (svp && gperl_sv_is_defined (*svp)) {
1131
1138
s->return_type = gperl_type_from_package (SvPV_nolen (*svp));
1132
1139
if (!s->return_type)
1133
1140
croak ("unknown or unregistered return type %s",
1170
1177
1171
1178
/* parse the key's value... */
1172
1179
value = hv_iterval (signals, he);
1173
if (SvROK (value) && SvTYPE (SvRV (value)) == SVt_PVHV) {
1180
if (gperl_sv_is_hash_ref (value)) {
1174
1181
/*
1175
1182
* value is a hash describing a new signal.
1176
1183
*/
1202
1209
signal_name);
1203
1210
1204
1211
} else if ((SvPOK (value) && SvLEN (value) > 0) ||
1205
(SvROK (value) && SvTYPE (SvRV (value)) == SVt_PVCV)) {
1212
gperl_sv_is_code_ref (value)) {
1206
1213
/*
1207
1214
* a subroutine reference or method name to override
1208
1215
* the class closure for this signal.
1333
1340
GParamSpec * pspec = NULL;
1334
1341
if (sv_derived_from (sv, "Glib::ParamSpec"))
1335
1342
pspec = SvGParamSpec (sv);
1336
else if (SVt_PVHV == SvTYPE (SvRV (sv))) {
1343
else if (gperl_sv_is_hash_ref (sv)) {
1337
1344
HV * hv = (HV*) SvRV (sv);
1338
1345
SV ** svp;
1339
1346
SV * setter = NULL;
1422
1429
1423
1430
for (i = 0; i <= av_len (interfaces); i++) {
1424
1431
SV ** svp = av_fetch (interfaces, i, FALSE);
1425
if (!svp && !SvOK (*svp))
1426
croak ("%s is not a valid interface name",
1427
SvPV_nolen (*svp));
1432
if (!svp || !gperl_sv_is_defined (*svp))
1433
croak ("encountered undefined interface name");
1428
1434
1429
1435
/* call the interface's setup function on this class. */
1430
1436
{
2167
2173
/* mark this type as "one of ours". */
2168
2174
g_type_set_qdata (new_type, gperl_type_reg_quark (), (gpointer) TRUE);
2169
2175
2170
/* instantiate the class right now. perl doesn't let classes go
2171
* away once they've been defined, so we'll just leak this ref and
2172
* let the GObjectClass live as long as the program. in fact,
2173
* because we don't really have class_init handlers like C, we
2174
* really don't want the class to die and be reinstantiated, because
2175
* some of the setup (namely the stuff coming up) will never happen
2176
* again.
2177
* this statement will cause an arbitrary amount of stuff to happen.
2178
*/
2179
g_type_class_ref (new_type); /* leak */
2180
2181
2176
/* now look for things we should initialize presently, e.g.
2182
2177
* signals and properties and interfaces and such, things that
2183
2178
* would generally go into a class_init. */
2184
2179
for (i = 3 ; i < items ; i += 2) {
2185
2180
char * key = SvPV_nolen (ST (i));
2186
2181
if (strEQ (key, "signals")) {
2187
if (SvROK (ST (i+1)) && SvTYPE (SvRV (ST (i+1))) == SVt_PVHV)
2182
if (gperl_sv_is_hash_ref (ST (i+1)))
2188
2183
add_signals (new_type, (HV*)SvRV (ST (i+1)));
2189
2184
else
2190
2185
croak ("signals must be a hash of signalname => signalspec pairs");
2191
2186
} else if (strEQ (key, "properties")) {
2192
if (SvROK (ST (i+1)) && SvTYPE (SvRV (ST (i+1))) == SVt_PVAV)
2187
if (gperl_sv_is_array_ref (ST (i+1)))
2193
2188
add_properties (new_type, (AV*)SvRV (ST (i+1)));
2194
2189
else
2195
2190
croak ("properties must be an array of GParamSpecs");
2196
2191
} else if (strEQ (key, "interfaces")) {
2197
if (SvROK (ST (i+1)) && SvTYPE (SvRV (ST (i+1))) == SVt_PVAV)
2192
if (gperl_sv_is_array_ref (ST (i+1)))
2198
2193
add_interfaces (new_type, (AV*)SvRV (ST (i+1)));
2199
2194
else
2200
2195
croak ("interfaces must be an array of package names");
2201
2196
}
2202
2197
}
2198
2199
/* instantiate the class right now. perl doesn't let classes go
2200
* away once they've been defined, so we'll just leak this ref and
2201
* let the GObjectClass live as long as the program. in fact,
2202
* because we don't really have class_init handlers like C, we
2203
* really don't want the class to die and be reinstantiated, because
2204
* some of the setup (namely all the class setup we just did and
2205
* the override installation coming up) will never happen
2206
* again.
2207
* this statement will cause an arbitrary amount of stuff to happen.
2208
*/
2209
g_type_class_ref (new_type); /* leak */
2203
2210
2204
2211
/* vfuncs cause a bit of a problem, because the normal mechanisms of
2205
2212
* GObject don't give us a predefined way to handle them. here we
2273
2280
sv = (SV*)ST (i+2);
2274
2281
/* default to the i based numbering */
2275
2282
values[i].value = i + 1;
2276
if (SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)
2283
if (gperl_sv_is_array_ref (sv))
2277
2284
{
2278
2285
/* [ name => value ] syntax */
2279
2286
AV * av = (AV*)SvRV(sv);
2280
2287
/* value_name */
2281
2288
av2sv = av_fetch (av, 0, 0);
2282
if (av2sv && *av2sv && SvOK(*av2sv))
2289
if (av2sv && gperl_sv_is_defined (*av2sv))
2283
2290
values[i].value_name = SvPV_nolen (*av2sv);
2284
2291
else
2285
2292
croak ("invalid enum name and value pair, no name provided");
2286
2293
/* custom value */
2287
2294
av2sv = av_fetch (av, 1, 0);
2288
if (av2sv && *av2sv && SvOK(*av2sv))
2295
if (av2sv && gperl_sv_is_defined (*av2sv))
2289
2296
values[i].value = SvIV (*av2sv);
2290
2297
}
2291
else if (SvOK (sv))
2298
else if (gperl_sv_is_defined (sv))
2292
2299
{
2293
2300
/* name syntax */
2294
2301
values[i].value_name = SvPV_nolen (sv);
2359
2366
sv = (SV*)ST (i+2);
2360
2367
/* default to the i based numbering */
2361
2368
values[i].value = 1 << i;
2362
if (SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)
2369
if (gperl_sv_is_array_ref (sv))
2363
2370
{
2364
2371
/* [ name => value ] syntax */
2365
2372
AV * av = (AV*)SvRV(sv);
2366
2373
/* value_name */
2367
2374
av2sv = av_fetch (av, 0, 0);
2368
if (av2sv && *av2sv && SvOK(*av2sv))
2375
if (av2sv && gperl_sv_is_defined (*av2sv))
2369
2376
values[i].value_name = SvPV_nolen (*av2sv);
2370
2377
else
2371
2378
croak ("invalid flag name and value pair, no name provided");
2372
2379
/* custom value */
2373
2380
av2sv = av_fetch (av, 1, 0);
2374
if (av2sv && *av2sv && SvOK(*av2sv))
2381
if (av2sv && gperl_sv_is_defined (*av2sv))
2375
2382
values[i].value = SvIV (*av2sv);
2376
2383
}
2377
else if (SvOK (sv))
2384
else if (gperl_sv_is_defined (sv))
2378
2385
{
2379
2386
/* name syntax */
2380
2387
values[i].value_name = SvPV_nolen (sv);
2559
2566
this function will croak.
2560
2567
2561
2568
Returns the values as a list of hashes, one hash for each value, containing
2562
that value's name and nickname.
2569
the value, name and nickname, eg. for Glib::SignalFlags
2570
2571
{ value => 8,
2572
name => 'G_SIGNAL_NO_RECURSE',
2573
nick => 'no-recurse'
2574
}
2563
2575
2564
2576
=cut
2565
2577
void
2574
2586
croak ("%s is not registered with either GPerl or GLib",
2575
2587
package);
2576
2588
/*
2577
* unfortunately, GFlagsValue and GEnumValue different structures
2578
* that happen to have identical definitions, so even though it
2579
* is very inviting to use the same code for them, it's not
2580
* technically a good idea.
2589
* GFlagsValue and GEnumValue are nearly the same, but differ in
2590
* that GFlagsValue is a guint for the value, but GEnumValue is gint
2591
* (and some enums do indeed use negatives, eg. GtkResponseType).
2581
2592
*/
2582
2593
if (G_TYPE_IS_ENUM (type)) {
2583
2594
GEnumValue * v = gperl_type_enum_get_values (type);
2584
2595
for ( ; v && v->value_nick && v->value_name ; v++) {
2585
2596
HV * hv = newHV ();
2597
hv_store (hv, "value",5, newSViv (v->value), 0);
2586
2598
hv_store (hv, "nick", 4, newSVpv (v->value_nick, 0), 0);
2587
2599
hv_store (hv, "name", 4, newSVpv (v->value_name, 0), 0);
2588
2600
XPUSHs (sv_2mortal (newRV_noinc ((SV*)hv)));
2591
2603
GFlagsValue * v = gperl_type_flags_get_values (type);
2592
2604
for ( ; v && v->value_nick && v->value_name ; v++) {
2593
2605
HV * hv = newHV ();
2606
hv_store (hv, "value",5, newSVuv (v->value), 0);
2594
2607
hv_store (hv, "nick", 4, newSVpv (v->value_nick, 0), 0);
2595
2608
hv_store (hv, "name", 4, newSVpv (v->value_name, 0), 0);
2596
2609
XPUSHs (sv_2mortal (newRV_noinc ((SV*)hv)));
Loggerhead is a web-based interface for Breezy
Version: 2.0.1