This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b2fb34a9b8cbc6c579111bdc9f8952d48e064157
[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         check(1, "differing prototypes for $func:\n  API: $proto\n  PPP: $prototypes{$func}");
290         $proto = $prototypes{$func};
291       }
292     }
293     else {
294       warn "found no prototype for $func\n";;
295     }
296
297     $explicit{$func} = 'func';
298
299     $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
300     my $embed = make_embed($e);
301
302     return "defined(NEED_$func)\n"
303          . "static $proto;\n"
304          . "static\n"
305          . "#else\n"
306          . "extern $proto;\n"
307          . "#endif\n"
308          . "\n"
309          . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)\n"
310          . "\n"
311          . "$embed\n";
312   }
313
314   die "cannot expand preprocessor expression '$expr'\n";
315 }
316
317 sub make_embed
318 {
319   my $f = shift;
320   my $n = $f->{name};
321   my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };
322   my $lastarg = ${$f->{args}}[-1];
323
324   if ($f->{flags}{T}) {
325     if ($f->{flags}{p}) {
326       return "#define $n $DPPP(my_$n)\n" .
327              "#define Perl_$n $DPPP(my_$n)";
328     }
329     else {
330       return "#define $n $DPPP(my_$n)";
331     }
332   }
333   else {
334     my $undef = <<UNDEF;
335 #ifdef $n
336 #  undef $n
337 #endif
338 UNDEF
339     if ($f->{flags}{p}) {
340       if ($f->{flags}{f}) {
341         return "#define Perl_$n $DPPP(my_$n)";
342       }
343       elsif (@$lastarg && $lastarg->[0] =~ /\.\.\./) {
344         return $undef . "#define $n $DPPP(my_$n)\n" .
345                         "#define Perl_$n $DPPP(my_$n)";
346       }
347       else {
348         return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
349                         "#define Perl_$n $DPPP(my_$n)";
350       }
351     }
352     else {
353       return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
354     }
355   }
356 }
357
358 sub check
359 {
360   my $level = shift;
361
362   if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
363     print STDERR @_, "\n";
364   }
365 }
366
367 __DATA__
368 ################################################################################
369 #
370 #  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
371 #
372 #  This file was automatically generated from the definition files in the
373 #  parts/inc/ subdirectory by PPPort_pm.PL. To learn more about how all this
374 #  works, please read the F<HACKERS> file that came with this distribution.
375 #
376 ################################################################################
377 #
378 #  Perl/Pollution/Portability
379 #
380 ################################################################################
381 #
382 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
383 #               Copyright (C) 2018, The perl5 porters
384 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
385 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
386 #
387 #  This program is free software; you can redistribute it and/or
388 #  modify it under the same terms as Perl itself.
389 #
390 ################################################################################
391
392 =head1 NAME
393
394 Devel::PPPort - Perl/Pollution/Portability
395
396 =head1 SYNOPSIS
397
398   Devel::PPPort::WriteFile();   # defaults to ./ppport.h
399   Devel::PPPort::WriteFile('someheader.h');
400
401   # Same as above but retrieve contents rather than write file
402   my $contents = Devel::PPPort::GetFileContents();
403   my $contents = Devel::PPPort::GetFileContents('someheader.h');
404
405 =head1 Start using Devel::PPPort for XS projects
406
407   $ cpan Devel::PPPort
408   $ perl -MDevel::PPPort -e'Devel::PPPort::WriteFile'
409   $ perl ppport.h --compat-version=5.6.1 --patch=diff.patch *.xs
410   $ patch -p0 < diff.patch
411   $ echo ppport.h >>MANIFEST
412
413 =head1 DESCRIPTION
414
415 Perl's API has changed over time, gaining new features, new functions,
416 increasing its flexibility, and reducing the impact on the C namespace
417 environment (reduced pollution). The header file written by this module,
418 typically F<ppport.h>, attempts to bring some of the newer Perl API
419 features to older versions of Perl, so that you can worry less about
420 keeping track of old releases, but users can still reap the benefit.
421
422 C<Devel::PPPort> contains two functions, C<WriteFile> and C<GetFileContents>.
423 C<WriteFile>'s only purpose is to write the F<ppport.h> C header file.
424 This file contains a series of macros and, if explicitly requested, functions
425 that allow XS modules to be built using older versions of Perl. Currently,
426 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
427
428 C<GetFileContents> can be used to retrieve the file contents rather than
429 writing it out.
430
431 This module is used by C<h2xs> to write the file F<ppport.h>.
432
433 =head2 Why use ppport.h?
434
435 You should use F<ppport.h> in modern code so that your code will work
436 with the widest range of Perl interpreters possible, without significant
437 additional work.
438
439 You should attempt to get older code to fully use F<ppport.h>, because the
440 reduced pollution of newer Perl versions is an important thing. It's so
441 important that the old polluting ways of original Perl modules will not be
442 supported very far into the future, and your module will almost certainly
443 break! By adapting to it now, you'll gain compatibility and a sense of
444 having done the electronic ecology some good.
445
446 =head2 How to use ppport.h
447
448 Don't direct the users of your module to download C<Devel::PPPort>.
449 They are most probably not XS writers. Also, don't make F<ppport.h>
450 optional. Rather, just take the most recent copy of F<ppport.h> that
451 you can find (e.g. by generating it with the latest C<Devel::PPPort>
452 release from CPAN), copy it into your project, adjust your project to
453 use it, and distribute the header along with your module.
454
455 =head2 Running ppport.h
456
457 But F<ppport.h> is more than just a C header. It's also a Perl script
458 that can check your source code. It will suggest hints and portability
459 notes, and can even make suggestions on how to change your code. You
460 can run it like any other Perl program:
461
462     perl ppport.h [options] [files]
463
464 It also has embedded documentation, so you can use
465
466     perldoc ppport.h
467
468 to find out more about how to use it.
469
470 =head1 FUNCTIONS
471
472 =head2 WriteFile
473
474 C<WriteFile> takes one optional argument. When called with one
475 argument, it expects to be passed a filename. When called with
476 no arguments, it defaults to the filename F<ppport.h>.
477
478 The function returns a true value if the file was written successfully.
479 Otherwise it returns a false value.
480
481 =head2 GetFileContents
482
483 C<GetFileContents> behaves like C<WriteFile> above, but returns the contents
484 of the would-be file rather than writing it out.
485
486 =head1 COMPATIBILITY
487
488 F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
489 in threaded and non-threaded configurations.
490
491 =head2 Provided Perl compatibility API
492
493 The header file written by this module, typically F<ppport.h>, provides
494 access to the following elements of the Perl API that are not otherwise
495 available in Perl releases older than when the elements were first introduced.
496 (Many of these are not supported all the way back to __MIN_PERL__;
497 see L</Perl API not supported by ppport.h back to __MIN_PERL__> for details.)
498
499     __PROVIDED_API__
500
501 =head2 Perl API not supported by ppport.h back to __MIN_PERL__
502
503 There is still a big part of the API not fully supported by F<ppport.h>.
504 This can be because it doesn't make sense to back-port that part of the API,
505 or simply because it hasn't been implemented yet. Patches welcome!  Some
506 elements are ported backward for some releases, but not all the way to
507 __MIN_PERL__.
508
509 Below is a list of the API that isn't currently supported back to
510 __MIN_PERL__, sorted by the version of Perl below which it is unsupported.
511 Only things you should be using are included in the list, so not listed are
512 deprecated and experimental functions.
513
514 Some of the entries are marked as "undocumented".  This means that they
515 aren't necessarily considered stable, and could be changed or removed in some
516 future release without warning.  It is therefore a bad idea to use them
517 without further checking.  It could be that these are considered to be for
518 perl core use only; or it could be, though, that C<Devel::PPPort> doesn't know
519 where to find their documentation, or that it's just an oversight that they
520 haven't been documented.  If you want to use one, and potentially have it
521 backported, first send mail to L<mailto:perl5-porters@perl.org>.
522
523 =over 4
524
525 __UNSUPPORTED_API__
526
527 =back
528
529 =head1 BUGS
530
531 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
532 system, or any of its tests fail, please send a bug report to
533 L<perlbug@perl.org|mailto:perlbug@perl.org>.
534
535 =head1 AUTHORS
536
537 =over 2
538
539 =item *
540
541 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
542
543 =item *
544
545 Version 2.x was ported to the Perl core by Paul Marquess.
546
547 =item *
548
549 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
550
551 =item * 
552
553 Versions >= 3.22 are maintained by perl5 porters
554
555 =back
556
557 =head1 COPYRIGHT
558
559 Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
560
561              Copyright (C) 2018, The perl5 porters
562
563 Version 2.x, Copyright (C) 2001, Paul Marquess.
564
565 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
566
567 This program is free software; you can redistribute it and/or
568 modify it under the same terms as Perl itself.
569
570 =head1 SEE ALSO
571
572 See L<h2xs>, L<ppport.h>.
573
574 =cut
575
576 package Devel::PPPort;
577
578 use strict;
579 use vars qw($VERSION $data);
580
581 $VERSION = '3.55';
582
583 sub _init_data
584 {
585   $data = do { local $/; <DATA> };
586   my $pkg = 'Devel::PPPort';
587   $data =~ s/__PERL_VERSION__/$]/g;
588   $data =~ s/__VERSION__/$VERSION/g;
589   $data =~ s/__PKG__/$pkg/g;
590   $data =~ s/^\|>//gm;
591 }
592
593 sub GetFileContents {
594   my $file = shift || 'ppport.h';
595   defined $data or _init_data();
596   my $copy = $data;
597   $copy =~ s/\bppport\.h\b/$file/g;
598
599   return $copy;
600 }
601
602 sub WriteFile
603 {
604   my $file = shift || 'ppport.h';
605   my $data = GetFileContents($file);
606   open F, ">$file" or return undef;
607   print F $data;
608   close F;
609
610   return 1;
611 }
612
613 1;
614
615 __DATA__
616 #if 0
617 <<'SKIP';
618 #endif
619 /*
620 ----------------------------------------------------------------------
621
622     ppport.h -- Perl/Pollution/Portability Version __VERSION__
623
624     Automatically created by __PKG__ running under perl __PERL_VERSION__.
625
626     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
627     includes in parts/inc/ instead.
628
629     Use 'perldoc ppport.h' to view the documentation below.
630
631 ----------------------------------------------------------------------
632
633 SKIP
634
635 %include ppphdoc { indent => '|>' }
636
637 %include ppphbin
638
639 __DATA__
640 */
641
642 #ifndef _P_P_PORTABILITY_H_
643 #define _P_P_PORTABILITY_H_
644
645 #ifndef DPPP_NAMESPACE
646 #  define DPPP_NAMESPACE DPPP_
647 #endif
648
649 #define DPPP_CAT2(x,y) CAT2(x,y)
650 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
651
652 %include version
653
654 %include threads
655
656 %include limits
657
658 %include variables
659
660 %include newCONSTSUB
661
662 %include magic_defs
663
664 %include misc
665
666 %include sv_xpvf
667
668 %include SvPV
669
670 %include warn
671
672 %include format
673
674 %include uv
675
676 %include memory
677
678 %include mess
679
680 %include mPUSH
681
682 %include call
683
684 %include newRV
685
686 %include MY_CXT
687
688 %include SvREFCNT
689
690 %include newSV_type
691
692 %include newSVpv
693
694 %include Sv_set
695
696 %include shared_pv
697
698 %include HvNAME
699
700 %include gv
701
702 %include pvs
703
704 %include magic
705
706 %include cop
707
708 %include grok
709
710 %include snprintf
711
712 %include sprintf
713
714 %include exception
715
716 %include strlfuncs
717
718 %include utf8
719
720 %include pv_tools
721
722 #endif /* _P_P_PORTABILITY_H_ */
723
724 /* End of File ppport.h */