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