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