Statistics
| Branch: | Tag: | Revision:

root / tools / perl / lib / ExtUtils / Constant.pm @ fa47cac2

History | View | Annotate | Download (14.5 kB)

1
package ExtUtils::Constant;
2
use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
3
$VERSION = 0.22;
4

    
5
=head1 NAME
6

    
7
ExtUtils::Constant - generate XS code to import C header constants
8

    
9
=head1 SYNOPSIS
10

    
11
    use ExtUtils::Constant qw (WriteConstants);
12
    WriteConstants(
13
        NAME => 'Foo',
14
        NAMES => [qw(FOO BAR BAZ)],
15
    );
16
    # Generates wrapper code to make the values of the constants FOO BAR BAZ
17
    #  available to perl
18

    
19
=head1 DESCRIPTION
20

    
21
ExtUtils::Constant facilitates generating C and XS wrapper code to allow
22
perl modules to AUTOLOAD constants defined in C library header files.
23
It is principally used by the C<h2xs> utility, on which this code is based.
24
It doesn't contain the routines to scan header files to extract these
25
constants.
26

    
27
=head1 USAGE
28

    
29
Generally one only needs to call the C<WriteConstants> function, and then
30

    
31
    #include "const-c.inc"
32

    
33
in the C section of C<Foo.xs>
34

    
35
    INCLUDE: const-xs.inc
36

    
37
in the XS section of C<Foo.xs>.
38

    
39
For greater flexibility use C<constant_types()>, C<C_constant> and
40
C<XS_constant>, with which C<WriteConstants> is implemented.
41

    
42
Currently this module understands the following types. h2xs may only know
43
a subset. The sizes of the numeric types are chosen by the C<Configure>
44
script at compile time.
45

    
46
=over 4
47

    
48
=item IV
49

    
50
signed integer, at least 32 bits.
51

    
52
=item UV
53

    
54
unsigned integer, the same size as I<IV>
55

    
56
=item NV
57

    
58
floating point type, probably C<double>, possibly C<long double>
59

    
60
=item PV
61

    
62
NUL terminated string, length will be determined with C<strlen>
63

    
64
=item PVN
65

    
66
A fixed length thing, given as a [pointer, length] pair. If you know the
67
length of a string at compile time you may use this instead of I<PV>
68

    
69
=item SV
70

    
71
A B<mortal> SV.
72

    
73
=item YES
74

    
75
Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
76

    
77
=item NO
78

    
79
Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
80

    
81
=item UNDEF
82

    
83
C<undef>.  The value of the macro is not needed.
84

    
85
=back
86

    
87
=head1 FUNCTIONS
88

    
89
=over 4
90

    
91
=cut
92

    
93
if ($] >= 5.006) {
94
  eval "use warnings; 1" or die $@;
95
}
96
use strict;
97
use Carp qw(croak cluck);
98

    
99
use Exporter;
100
use ExtUtils::Constant::Utils qw(C_stringify);
101
use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet);
102

    
103
@ISA = 'Exporter';
104

    
105
%EXPORT_TAGS = ( 'all' => [ qw(
106
	XS_constant constant_types return_clause memEQ_clause C_stringify
107
	C_constant autoload WriteConstants WriteMakefileSnippet
108
) ] );
109

    
110
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
111

    
112
=item constant_types
113

    
114
A function returning a single scalar with C<#define> definitions for the
115
constants used internally between the generated C and XS functions.
116

    
117
=cut
118

    
119
sub constant_types {
120
  ExtUtils::Constant::XS->header();
121
}
122

    
123
sub memEQ_clause {
124
  cluck "ExtUtils::Constant::memEQ_clause is deprecated";
125
  ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1],
126
					indent=>$_[2]});
127
}
128

    
129
sub return_clause ($$) {
130
  cluck "ExtUtils::Constant::return_clause is deprecated";
131
  my $indent = shift;
132
  ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
133
}
134

    
135
sub switch_clause {
136
  cluck "ExtUtils::Constant::switch_clause is deprecated";
137
  my $indent = shift;
138
  my $comment = shift;
139
  ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment},
140
					@_);
141
}
142

    
143
sub C_constant {
144
  my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
145
    = @_;
146
  ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname,
147
				      default_type => $default_type,
148
				      types => $what, indent => $indent,
149
				      breakout => $breakout}, @items);
150
}
151

    
152
=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME
153

    
154
A function to generate the XS code to implement the perl subroutine
155
I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
156
This XS code is a wrapper around a C subroutine usually generated by
157
C<C_constant>, and usually named C<constant>.
158

    
159
I<TYPES> should be given either as a comma separated list of types that the
160
C subroutine C<constant> will generate or as a reference to a hash. It should
161
be the same list of types as C<C_constant> was given.
162
[Otherwise C<XS_constant> and C<C_constant> may have different ideas about
163
the number of parameters passed to the C function C<constant>]
164

    
165
You can call the perl visible subroutine something other than C<constant> if
166
you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to
167
the name of the perl visible subroutine, unless you give the parameter
168
I<C_SUBNAME>.
169

    
170
=cut
171

    
172
sub XS_constant {
173
  my $package = shift;
174
  my $what = shift;
175
  my $XS_subname = shift;
176
  my $C_subname = shift;
177
  $XS_subname ||= 'constant';
178
  $C_subname ||= $XS_subname;
179

    
180
  if (!ref $what) {
181
    # Convert line of the form IV,UV,NV to hash
182
    $what = {map {$_ => 1} split /,\s*/, ($what)};
183
  }
184
  my $params = ExtUtils::Constant::XS->params ($what);
185
  my $type;
186

    
187
  my $xs = <<"EOT";
188
void
189
$XS_subname(sv)
190
    PREINIT:
191
#ifdef dXSTARG
192
	dXSTARG; /* Faster if we have it.  */
193
#else
194
	dTARGET;
195
#endif
196
	STRLEN		len;
197
        int		type;
198
EOT
199

    
200
  if ($params->{IV}) {
201
    $xs .= "	IV		iv;\n";
202
  } else {
203
    $xs .= "	/* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
204
  }
205
  if ($params->{NV}) {
206
    $xs .= "	NV		nv;\n";
207
  } else {
208
    $xs .= "	/* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
209
  }
210
  if ($params->{PV}) {
211
    $xs .= "	const char	*pv;\n";
212
  } else {
213
    $xs .=
214
      "	/* const char\t*pv;\tUncomment this if you need to return PVs */\n";
215
  }
216

    
217
  $xs .= << 'EOT';
218
    INPUT:
219
	SV *		sv;
220
        const char *	s = SvPV(sv, len);
221
EOT
222
  if ($params->{''}) {
223
  $xs .= << 'EOT';
224
    INPUT:
225
	int		utf8 = SvUTF8(sv);
226
EOT
227
  }
228
  $xs .= << 'EOT';
229
    PPCODE:
230
EOT
231

    
232
  if ($params->{IV} xor $params->{NV}) {
233
    $xs .= << "EOT";
234
        /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
235
           if you need to return both NVs and IVs */
236
EOT
237
  }
238
  $xs .= "	type = $C_subname(aTHX_ s, len";
239
  $xs .= ', utf8' if $params->{''};
240
  $xs .= ', &iv' if $params->{IV};
241
  $xs .= ', &nv' if $params->{NV};
242
  $xs .= ', &pv' if $params->{PV};
243
  $xs .= ', &sv' if $params->{SV};
244
  $xs .= ");\n";
245

    
246
  # If anyone is insane enough to suggest a package name containing %
247
  my $package_sprintf_safe = $package;
248
  $package_sprintf_safe =~ s/%/%%/g;
249

    
250
  $xs .= << "EOT";
251
      /* Return 1 or 2 items. First is error message, or undef if no error.
252
           Second, if present, is found value */
253
        switch (type) {
254
        case PERL_constant_NOTFOUND:
255
          sv =
256
	    sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s));
257
          PUSHs(sv);
258
          break;
259
        case PERL_constant_NOTDEF:
260
          sv = sv_2mortal(newSVpvf(
261
	    "Your vendor has not defined $package_sprintf_safe macro %s, used",
262
				   s));
263
          PUSHs(sv);
264
          break;
265
EOT
266

    
267
  foreach $type (sort keys %XS_Constant) {
268
    # '' marks utf8 flag needed.
269
    next if $type eq '';
270
    $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
271
      unless $what->{$type};
272
    $xs .= "        case PERL_constant_IS$type:\n";
273
    if (length $XS_Constant{$type}) {
274
      $xs .= << "EOT";
275
          EXTEND(SP, 1);
276
          PUSHs(&PL_sv_undef);
277
          $XS_Constant{$type};
278
EOT
279
    } else {
280
      # Do nothing. return (), which will be correctly interpreted as
281
      # (undef, undef)
282
    }
283
    $xs .= "          break;\n";
284
    unless ($what->{$type}) {
285
      chop $xs; # Yes, another need for chop not chomp.
286
      $xs .= " */\n";
287
    }
288
  }
289
  $xs .= << "EOT";
290
        default:
291
          sv = sv_2mortal(newSVpvf(
292
	    "Unexpected return type %d while processing $package_sprintf_safe macro %s, used",
293
               type, s));
294
          PUSHs(sv);
295
        }
296
EOT
297

    
298
  return $xs;
299
}
300

    
301

    
302
=item autoload PACKAGE, VERSION, AUTOLOADER
303

    
304
A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
305
I<VERSION> is the perl version the code should be backwards compatible with.
306
It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
307
is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
308
names that the constant() routine doesn't recognise.
309

    
310
=cut
311

    
312
# ' # Grr. syntax highlighters that don't grok pod.
313

    
314
sub autoload {
315
  my ($module, $compat_version, $autoloader) = @_;
316
  $compat_version ||= $];
317
  croak "Can't maintain compatibility back as far as version $compat_version"
318
    if $compat_version < 5;
319
  my $func = "sub AUTOLOAD {\n"
320
  . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
321
  . "    # XS function.";
322
  $func .= "  If a constant is not found then control is passed\n"
323
  . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
324

    
325

    
326
  $func .= "\n\n"
327
  . "    my \$constname;\n";
328
  $func .=
329
    "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
330

    
331
  $func .= <<"EOT";
332
    (\$constname = \$AUTOLOAD) =~ s/.*:://;
333
    croak "&${module}::constant not defined" if \$constname eq 'constant';
334
    my (\$error, \$val) = constant(\$constname);
335
EOT
336

    
337
  if ($autoloader) {
338
    $func .= <<'EOT';
339
    if ($error) {
340
	if ($error =~  /is not a valid/) {
341
	    $AutoLoader::AUTOLOAD = $AUTOLOAD;
342
	    goto &AutoLoader::AUTOLOAD;
343
	} else {
344
	    croak $error;
345
	}
346
    }
347
EOT
348
  } else {
349
    $func .=
350
      "    if (\$error) { croak \$error; }\n";
351
  }
352

    
353
  $func .= <<'END';
354
    {
355
	no strict 'refs';
356
	# Fixed between 5.005_53 and 5.005_61
357
#XXX	if ($] >= 5.00561) {
358
#XXX	    *$AUTOLOAD = sub () { $val };
359
#XXX	}
360
#XXX	else {
361
	    *$AUTOLOAD = sub { $val };
362
#XXX	}
363
    }
364
    goto &$AUTOLOAD;
365
}
366

    
367
END
368

    
369
  return $func;
370
}
371

    
372

    
373
=item WriteMakefileSnippet
374

    
375
WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 
376

    
377
A function to generate perl code for Makefile.PL that will regenerate
378
the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
379
with the addition of C<INDENT> to specify the number of leading spaces
380
(default 2).
381

    
382
Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
383
C<XS_FILE> are recognised.
384

    
385
=cut
386

    
387
sub WriteMakefileSnippet {
388
  my %args = @_;
389
  my $indent = $args{INDENT} || 2;
390

    
391
  my $result = <<"EOT";
392
ExtUtils::Constant::WriteConstants(
393
                                   NAME         => '$args{NAME}',
394
                                   NAMES        => \\\@names,
395
                                   DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
396
EOT
397
  foreach (qw (C_FILE XS_FILE)) {
398
    next unless exists $args{$_};
399
    $result .= sprintf "                                   %-12s => '%s',\n",
400
      $_, $args{$_};
401
  }
402
  $result .= <<'EOT';
403
                                );
404
EOT
405

    
406
  $result =~ s/^/' 'x$indent/gem;
407
  return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE},
408
					     indent=>$indent,},
409
					    @{$args{NAMES}})
410
    . $result;
411
}
412

    
413
=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
414

    
415
Writes a file of C code and a file of XS code which you should C<#include>
416
and C<INCLUDE> in the C and XS sections respectively of your module's XS
417
code.  You probably want to do this in your C<Makefile.PL>, so that you can
418
easily edit the list of constants without touching the rest of your module.
419
The attributes supported are
420

    
421
=over 4
422

    
423
=item NAME
424

    
425
Name of the module.  This must be specified
426

    
427
=item DEFAULT_TYPE
428

    
429
The default type for the constants.  If not specified C<IV> is assumed.
430

    
431
=item BREAKOUT_AT
432

    
433
The names of the constants are grouped by length.  Generate child subroutines
434
for each group with this number or more names in.
435

    
436
=item NAMES
437

    
438
An array of constants' names, either scalars containing names, or hashrefs
439
as detailed in L<"C_constant">.
440

    
441
=item PROXYSUBS
442

    
443
If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>.
444

    
445
=item C_FH
446

    
447
A filehandle to write the C code to.  If not given, then I<C_FILE> is opened
448
for writing.
449

    
450
=item C_FILE
451

    
452
The name of the file to write containing the C code.  The default is
453
C<const-c.inc>.  The C<-> in the name ensures that the file can't be
454
mistaken for anything related to a legitimate perl package name, and
455
not naming the file C<.c> avoids having to override Makefile.PL's
456
C<.xs> to C<.c> rules.
457

    
458
=item XS_FH
459

    
460
A filehandle to write the XS code to.  If not given, then I<XS_FILE> is opened
461
for writing.
462

    
463
=item XS_FILE
464

    
465
The name of the file to write containing the XS code.  The default is
466
C<const-xs.inc>.
467

    
468
=item XS_SUBNAME
469

    
470
The perl visible name of the XS subroutine generated which will return the
471
constants. The default is C<constant>.
472

    
473
=item C_SUBNAME
474

    
475
The name of the C subroutine generated which will return the constants.
476
The default is I<XS_SUBNAME>.  Child subroutines have C<_> and the name
477
length appended, so constants with 10 character names would be in
478
C<constant_10> with the default I<XS_SUBNAME>.
479

    
480
=back
481

    
482
=cut
483

    
484
sub WriteConstants {
485
  my %ARGS =
486
    ( # defaults
487
     C_FILE =>       'const-c.inc',
488
     XS_FILE =>      'const-xs.inc',
489
     XS_SUBNAME =>   'constant',
490
     DEFAULT_TYPE => 'IV',
491
     @_);
492

    
493
  $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
494

    
495
  croak "Module name not specified" unless length $ARGS{NAME};
496

    
497
  my $c_fh = $ARGS{C_FH};
498
  if (!$c_fh) {
499
      if ($] <= 5.008) {
500
	  # We need these little games, rather than doing things
501
	  # unconditionally, because we're used in core Makefile.PLs before
502
	  # IO is available (needed by filehandle), but also we want to work on
503
	  # older perls where undefined scalars do not automatically turn into
504
	  # anonymous file handles.
505
	  require FileHandle;
506
	  $c_fh = FileHandle->new();
507
      }
508
      open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
509
  }
510

    
511
  my $xs_fh = $ARGS{XS_FH};
512
  if (!$xs_fh) {
513
      if ($] <= 5.008) {
514
	  require FileHandle;
515
	  $xs_fh = FileHandle->new();
516
      }
517
      open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
518
  }
519

    
520
  # As this subroutine is intended to make code that isn't edited, there's no
521
  # need for the user to specify any types that aren't found in the list of
522
  # names.
523
  
524
  if ($ARGS{PROXYSUBS}) {
525
      require ExtUtils::Constant::ProxySubs;
526
      $ARGS{C_FH} = $c_fh;
527
      $ARGS{XS_FH} = $xs_fh;
528
      ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
529
  } else {
530
      my $types = {};
531

    
532
      print $c_fh constant_types(); # macro defs
533
      print $c_fh "\n";
534

    
535
      # indent is still undef. Until anyone implements indent style rules with
536
      # it.
537
      foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
538
						   subname => $ARGS{C_SUBNAME},
539
						   default_type =>
540
						       $ARGS{DEFAULT_TYPE},
541
						       types => $types,
542
						       breakout =>
543
						       $ARGS{BREAKOUT_AT}},
544
						  @{$ARGS{NAMES}})) {
545
	  print $c_fh $_, "\n"; # C constant subs
546
      }
547
      print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
548
				$ARGS{C_SUBNAME});
549
  }
550

    
551
  close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
552
  close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
553
}
554

    
555
1;
556
__END__
557

    
558
=back
559

    
560
=head1 AUTHOR
561

    
562
Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
563
others
564

    
565
=cut