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