This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.06.
[perl5.git] / ext / Devel / PPPort / PPPort_pm.PL
1 ################################################################################
2 #
3 #  PPPort_pm.PL -- generate PPPort.pm
4 #
5 ################################################################################
6 #
7 #  $Revision: 33 $
8 #  $Author: mhx $
9 #  $Date: 2005/01/31 08:10:55 +0100 $
10 #
11 ################################################################################
12 #
13 #  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
14 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
15 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
16 #
17 #  This program is free software; you can redistribute it and/or
18 #  modify it under the same terms as Perl itself.
19 #
20 ################################################################################
21
22 use strict;
23 $^W = 1;
24 require "parts/ppptools.pl";
25
26 my $INCLUDE = 'parts/inc';
27 my $DPPP = 'DPPP_';
28
29 my %embed = map { ( $_->{name} => $_ ) }
30             parse_embed(qw(parts/embed.fnc parts/apidoc.fnc));
31
32 my(%provides, %prototypes, %explicit);
33
34 my $data = do { local $/; <DATA> };
35 $data =~ s{^\%(include)\s+(\w+)((?:[^\S\r\n]+.*?)?)\s*$}
36           {eval "$1('$2', $3)" or die $@}gem;
37
38 $data = expand($data);
39
40 my @api = sort { lc $a cmp lc $b } keys %provides;
41
42 $data =~ s{^(.*)__PROVIDED_API__(\s*?)^}
43           {join '', map "$1$_\n", @api}gem;
44
45 {
46   my $len = 0;
47   for (keys %explicit) {
48     length > $len and $len = length;
49   }
50   my $format = sprintf "%%-%ds  %%-%ds  %%-%ds", $len+2, $len+5, $len+12;
51   $len = 3*$len + 23;
52
53 $data =~ s/^(.*)__EXPLICIT_API__(\s*?)^/
54            sprintf("$1$format\n", 'Function', 'Static Request', 'Global Request') .
55            $1 . '-'x$len . "\n" .
56            join('', map { sprintf "$1$format\n", "$_()", "NEED_$_", "NEED_${_}_GLOBAL" }
57                     sort keys %explicit)
58           /gem;
59 }
60
61 my %raw_base = %{&parse_todo('parts/base')};
62 my %raw_todo = %{&parse_todo('parts/todo')};
63
64 my %todo;
65 for (keys %raw_todo) {
66   push @{$todo{$raw_todo{$_}}}, $_;
67 }
68
69 # check consistency
70 for (@api) {
71   if (exists $raw_todo{$_}) {
72     if ($raw_base{$_} eq $raw_todo{$_}) {
73       warn "$INCLUDE/$provides{$_} provides $_, which is still marked "
74            . "todo for " . format_version($raw_todo{$_}) . "\n";
75     }
76     else {
77       check(2, "$_ was ported back to " . format_version($raw_todo{$_}) .
78                " (baseline revision: " . format_version($raw_base{$_}) . ").");
79     }
80   }
81 }
82
83 my @perl_api;
84 for (keys %provides) {
85   next if exists $embed{$_};
86   push @perl_api, $_;
87   check(2, "No API definition for provided element $_ found.");
88 }
89
90 push @perl_api, keys %embed;
91
92 for (@perl_api) {
93   if (exists $provides{$_} && !exists $raw_base{$_}) {
94     check(2, "Mmmh, $_ doesn't seem to need backporting.");
95   }
96   my $line = "$_|" . (exists $provides{$_} && exists $raw_base{$_} ? $raw_base{$_} : '') . '|';
97   $line .= ($raw_todo{$_} || '') . '|';
98   $line .= 'p' if exists $provides{$_};
99   if (exists $embed{$_}) {
100     my $e = $embed{$_};
101     if (exists $e->{flags}{p}) {
102       my $args = $e->{args};
103       $line .= 'v' if @$args && $args->[-1][0] eq '...';
104     }
105     $line .= 'n' if exists $e->{flags}{n};
106   }
107   $_ = $line;
108 }
109
110 $data =~ s/^([\t ]*)__PERL_API__(\s*?)$/
111            join "\n", map "$1$_", sort @perl_api
112           /gem;
113
114 my @todo;
115 for (reverse sort keys %todo) {
116   my $ver = format_version($_);
117   my $todo = "=item perl $ver\n\n";
118   for (sort @{$todo{$_}}) {
119     $todo .= "  $_\n";
120   }
121   push @todo, $todo;
122 }
123
124 $data =~ s{^__UNSUPPORTED_API__(\s*?)^}
125           {join "\n", @todo}gem;
126
127 $data =~ s{__MIN_PERL__}{5.003}g;
128 $data =~ s{__MAX_PERL__}{5.9.2}g;
129
130 open FH, ">PPPort.pm" or die "PPPort.pm: $!\n";
131 print FH $data;
132 close FH;
133
134 exit 0;
135
136 sub include
137 {
138   my($file, $opt) = @_;
139
140   print "including $file\n";
141
142   my $data = parse_partspec("$INCLUDE/$file");
143
144   for (@{$data->{provides}}) {
145     if (exists $provides{$_}) {
146       if ($provides{$_} ne $file) {
147         warn "$file: $_ already provided by $provides{$_}\n";
148       }
149     }
150     else {
151       $provides{$_} = $file;
152     }
153   }
154
155   for (keys %{$data->{prototypes}}) {
156     $prototypes{$_} = $data->{prototypes}{$_};
157     $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg;
158   }
159
160   my $out = $data->{implementation};
161
162   if (exists $opt->{indent}) {
163     $out =~ s/^/$opt->{indent}/gm;
164   }
165
166   return $out;
167 }
168
169 sub expand
170 {
171   my $code = shift;
172   $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem;
173   $code =~ s{^\s*
174               __UNDEFINED__
175               \s+
176               (
177                 ( \w+ )
178                 (?: \( [^)]* \) )?
179               )
180               [^\r\n\S]*
181               (
182                 (?:[^\r\n\\]|\\[^\r\n])*
183                 (?:
184                   \\
185                   (?:\r\n|[\r\n])
186                   (?:[^\r\n\\]|\\[^\r\n])*
187                 )*
188               )
189             \s*$}
190             {expand_undefined($2, $1, $3)}gemx;
191   return $code;
192 }
193
194 sub expand_undefined
195 {
196   my($macro, $withargs, $def) = @_;
197   my $rv = "#ifndef $macro\n#  define ";
198
199   if (defined $def) {
200     $rv .= sprintf "%-30s %s", $withargs, $def;
201   }
202   else {
203     $rv .= $withargs;
204   }
205
206   $rv .= "\n#endif\n";
207
208   return $rv;
209 }
210
211 sub expand_pp_expressions
212 {
213   my $pp = shift;
214   $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge;
215   return $pp;
216 }
217
218 sub expand_pp_expr
219 {
220   my $expr = shift;
221
222   if ($expr =~ /^\s*need\s*(\w+)\s*$/i) {
223     my $func = $1;
224     my $e = $embed{$func} or die "unknown API function '$func' in NEED\n";
225     my $proto = make_prototype($e);
226     if (exists $prototypes{$func}) {
227       if (compare_prototypes($proto, $prototypes{$func})) {
228         check(1, "differing prototypes for $func:\n  API: $proto\n  PPP: $prototypes{$func}");
229         $proto = $prototypes{$func};
230       }
231     }
232     else {
233       warn "found no prototype for $func\n";;
234     }
235
236     $explicit{$func} = 1;
237
238     $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
239     my $embed = make_embed($e);
240
241     return "defined(NEED_$func)\n"
242          . "static $proto;\n"
243          . "static\n"
244          . "#else\n"
245          . "extern $proto;\n"
246          . "#endif\n"
247          . "\n"
248          . "$embed\n"
249          . "\n"
250          . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)";
251   }
252
253   die "cannot expand preprocessor expression '$expr'\n";
254 }
255
256 sub make_embed
257 {
258   my $f = shift;
259   my $n = $f->{name};
260   my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };
261
262   if ($f->{flags}{n}) {
263     if ($f->{flags}{p}) {
264       return "#define $n $DPPP(my_$n)\n" .
265              "#define Perl_$n $DPPP(my_$n)";
266     }
267     else {
268       return "#define $n $DPPP(my_$n)";
269     }
270   }
271   else {
272     my $undef = <<UNDEF;
273 #ifdef $n
274 #  undef $n
275 #endif
276 UNDEF
277     if ($f->{flags}{p}) {
278       if ($f->{flags}{f}) {
279         return "#define Perl_$n $DPPP(my_$n)";
280       }
281       else {
282         return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
283                         "#define Perl_$n $DPPP(my_$n)";
284       }
285     }
286     else {
287       return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
288     }
289   }
290 }
291
292 sub check
293 {
294   my $level = shift;
295
296   if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
297     print STDERR @_, "\n";
298   }
299 }
300
301 __DATA__
302 ################################################################################
303 #
304 #  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
305 #
306 ################################################################################
307 #
308 #  Perl/Pollution/Portability
309 #
310 ################################################################################
311 #
312 #  $Revision: 33 $
313 #  $Author: mhx $
314 #  $Date: 2005/01/31 08:10:55 +0100 $
315 #
316 ################################################################################
317 #
318 #  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
319 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
320 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
321 #
322 #  This program is free software; you can redistribute it and/or
323 #  modify it under the same terms as Perl itself.
324 #
325 ################################################################################
326
327 =head1 NAME
328
329 Devel::PPPort - Perl/Pollution/Portability
330
331 =head1 SYNOPSIS
332
333     Devel::PPPort::WriteFile();   # defaults to ./ppport.h
334     Devel::PPPort::WriteFile('someheader.h');
335
336 =head1 DESCRIPTION
337
338 Perl's API has changed over time, gaining new features, new functions,
339 increasing its flexibility, and reducing the impact on the C namespace
340 environment (reduced pollution). The header file written by this module,
341 typically F<ppport.h>, attempts to bring some of the newer Perl API
342 features to older versions of Perl, so that you can worry less about
343 keeping track of old releases, but users can still reap the benefit.
344
345 C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
346 only purpose is to write the F<ppport.h> C header file. This file
347 contains a series of macros and, if explicitly requested, functions that
348 allow XS modules to be built using older versions of Perl. Currently,
349 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
350
351 This module is used by C<h2xs> to write the file F<ppport.h>. 
352
353 =head2 Why use ppport.h?
354  
355 You should use F<ppport.h> in modern code so that your code will work
356 with the widest range of Perl interpreters possible, without significant
357 additional work.
358
359 You should attempt older code to fully use F<ppport.h>, because the
360 reduced pollution of newer Perl versions is an important thing. It's so
361 important that the old polluting ways of original Perl modules will not be
362 supported very far into the future, and your module will almost certainly
363 break! By adapting to it now, you'll gain compatibility and a sense of
364 having done the electronic ecology some good.
365
366 =head2 How to use ppport.h
367
368 Don't direct the users of your module to download C<Devel::PPPort>.
369 They are most probably no XS writers. Also, don't make F<ppport.h>
370 optional. Rather, just take the most recent copy of F<ppport.h> that
371 you can find (e.g. by generating it with the latest C<Devel::PPPort>
372 release from CPAN), copy it into your project, adjust your project to
373 use it, and distribute the header along with your module. 
374
375 =head2 Running ppport.h
376
377 But F<ppport.h> is more than just a C header. It's also a Perl script
378 that can check your source code. It will suggest hints and portability
379 notes, and can even make suggestions on how to change your code. You
380 can run it like any other Perl program:
381
382     perl ppport.h [options] [files]
383
384 It also has embedded documentation, so you can use
385
386     perldoc ppport.h
387
388 to find out more about how to use it.
389
390 =head1 FUNCTIONS
391
392 =head2 WriteFile
393
394 C<WriteFile> takes one optional argument. When called with one
395 argument, it expects to be passed a filename. When called with
396 no arguments, it defaults to the filename F<ppport.h>.
397
398 The function returns a true value if the file was written successfully.
399 Otherwise it returns a false value.
400
401 =head1 COMPATIBILITY
402
403 F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
404 in threaded and non-threaded configurations.
405
406 =head2 Provided Perl compatibility API
407
408 The header file written by this module, typically F<ppport.h>, provides
409 access to the following elements of the Perl API that is not available
410 in older Perl releases:
411
412     __PROVIDED_API__
413
414 =head2 Perl API not supported by ppport.h
415
416 There is still a big part of the API not supported by F<ppport.h>.
417 Either because it doesn't make sense to back-port that part of the API,
418 or simply because it hasn't been implemented yet. Patches welcome!
419
420 Here's a list of the currently unsupported API, and also the version of
421 Perl below which it is unsupported:
422
423 =over 4
424
425 __UNSUPPORTED_API__
426
427 =back
428
429 =head1 BUGS
430
431 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
432 system or any of its tests fail, please use the CPAN Request Tracker
433 at L<http://rt.cpan.org/> to create a ticket for the module.
434
435 =head1 AUTHORS
436
437 =over 2
438
439 =item *
440
441 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
442
443 =item *
444
445 Version 2.x was ported to the Perl core by Paul Marquess.
446
447 =item *
448
449 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
450
451 =back
452
453 =head1 COPYRIGHT
454
455 Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
456
457 Version 2.x, Copyright (C) 2001, Paul Marquess.
458
459 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
460
461 This program is free software; you can redistribute it and/or
462 modify it under the same terms as Perl itself.
463
464 =head1 SEE ALSO
465
466 See L<h2xs>, L<ppport.h>.
467
468 =cut
469
470 package Devel::PPPort;
471
472 require DynaLoader;
473 use strict;
474 use vars qw($VERSION @ISA $data);
475
476 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.06 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
477
478 @ISA = qw(DynaLoader);
479
480 bootstrap Devel::PPPort;
481
482 {
483   $data = do { local $/; <DATA> };
484   my $now = localtime;
485   my $pkg = 'Devel::PPPort';
486   $data =~ s/__PERL_VERSION__/$]/g;
487   $data =~ s/__VERSION__/$VERSION/g;
488   $data =~ s/__DATE__/$now/g;
489   $data =~ s/__PKG__/$pkg/g;
490   $data =~ s/^POD\s//gm;
491 }
492
493 sub WriteFile
494 {
495   my $file = shift || 'ppport.h';
496   my $copy = $data;
497   $copy =~ s/\bppport\.h\b/$file/g;
498
499   open F, ">$file" or return undef;
500   print F $copy;
501   close F;
502
503   return 1;
504 }
505
506 1;
507
508 __DATA__
509 #if 0
510 <<'SKIP';
511 #endif
512 /*
513 ----------------------------------------------------------------------
514
515     ppport.h -- Perl/Pollution/Portability Version __VERSION__ 
516    
517     Automatically created by __PKG__ running under
518     perl __PERL_VERSION__ on __DATE__.
519     
520     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
521     includes in parts/inc/ instead.
522  
523     Use 'perldoc ppport.h' to view the documentation below.
524
525 ----------------------------------------------------------------------
526
527 SKIP
528
529 %include ppphdoc { indent => 'POD ' }
530
531 %include ppphbin
532
533 __DATA__
534 */
535
536 #ifndef _P_P_PORTABILITY_H_
537 #define _P_P_PORTABILITY_H_
538
539 #ifndef DPPP_NAMESPACE
540 #  define DPPP_NAMESPACE DPPP_
541 #endif
542
543 #define DPPP_CAT2(x,y) CAT2(x,y)
544 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
545
546 %include version
547
548 %include limits
549
550 %include uv
551
552 %include misc
553
554 %include threads
555
556 %include mPUSH
557
558 %include call
559
560 %include newRV
561
562 %include newCONSTSUB
563
564 %include MY_CXT
565
566 %include format
567
568 %include SvPV
569
570 %include sv_xpvf
571
572 %include magic
573
574 %include cop
575
576 %include grok
577
578 %include exception
579
580 #endif /* _P_P_PORTABILITY_H_ */
581
582 /* End of File ppport.h */