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