This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
23ffb6b1496e197a71dc80d7a3809c47d3efcd89
[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.11.5}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 =head1 DESCRIPTION
388
389 Perl's API has changed over time, gaining new features, new functions,
390 increasing its flexibility, and reducing the impact on the C namespace
391 environment (reduced pollution). The header file written by this module,
392 typically F<ppport.h>, attempts to bring some of the newer Perl API
393 features to older versions of Perl, so that you can worry less about
394 keeping track of old releases, but users can still reap the benefit.
395
396 C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
397 only purpose is to write the F<ppport.h> C header file. This file
398 contains a series of macros and, if explicitly requested, functions that
399 allow XS modules to be built using older versions of Perl. Currently,
400 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
401
402 This module is used by C<h2xs> to write the file F<ppport.h>.
403
404 =head2 Why use ppport.h?
405
406 You should use F<ppport.h> in modern code so that your code will work
407 with the widest range of Perl interpreters possible, without significant
408 additional work.
409
410 You should attempt older code to fully use F<ppport.h>, because the
411 reduced pollution of newer Perl versions is an important thing. It's so
412 important that the old polluting ways of original Perl modules will not be
413 supported very far into the future, and your module will almost certainly
414 break! By adapting to it now, you'll gain compatibility and a sense of
415 having done the electronic ecology some good.
416
417 =head2 How to use ppport.h
418
419 Don't direct the users of your module to download C<Devel::PPPort>.
420 They are most probably no XS writers. Also, don't make F<ppport.h>
421 optional. Rather, just take the most recent copy of F<ppport.h> that
422 you can find (e.g. by generating it with the latest C<Devel::PPPort>
423 release from CPAN), copy it into your project, adjust your project to
424 use it, and distribute the header along with your module.
425
426 =head2 Running ppport.h
427
428 But F<ppport.h> is more than just a C header. It's also a Perl script
429 that can check your source code. It will suggest hints and portability
430 notes, and can even make suggestions on how to change your code. You
431 can run it like any other Perl program:
432
433     perl ppport.h [options] [files]
434
435 It also has embedded documentation, so you can use
436
437     perldoc ppport.h
438
439 to find out more about how to use it.
440
441 =head1 FUNCTIONS
442
443 =head2 WriteFile
444
445 C<WriteFile> takes one optional argument. When called with one
446 argument, it expects to be passed a filename. When called with
447 no arguments, it defaults to the filename F<ppport.h>.
448
449 The function returns a true value if the file was written successfully.
450 Otherwise it returns a false value.
451
452 =head1 COMPATIBILITY
453
454 F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
455 in threaded and non-threaded configurations.
456
457 =head2 Provided Perl compatibility API
458
459 The header file written by this module, typically F<ppport.h>, provides
460 access to the following elements of the Perl API that is not available
461 in older Perl releases:
462
463     __PROVIDED_API__
464
465 =head2 Perl API not supported by ppport.h
466
467 There is still a big part of the API not supported by F<ppport.h>.
468 Either because it doesn't make sense to back-port that part of the API,
469 or simply because it hasn't been implemented yet. Patches welcome!
470
471 Here's a list of the currently unsupported API, and also the version of
472 Perl below which it is unsupported:
473
474 =over 4
475
476 __UNSUPPORTED_API__
477
478 =back
479
480 =head1 BUGS
481
482 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
483 system or any of its tests fail, please use the CPAN Request Tracker
484 at L<http://rt.cpan.org/> to create a ticket for the module.
485
486 =head1 AUTHORS
487
488 =over 2
489
490 =item *
491
492 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
493
494 =item *
495
496 Version 2.x was ported to the Perl core by Paul Marquess.
497
498 =item *
499
500 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
501
502 =back
503
504 =head1 COPYRIGHT
505
506 Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
507
508 Version 2.x, Copyright (C) 2001, Paul Marquess.
509
510 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
511
512 This program is free software; you can redistribute it and/or
513 modify it under the same terms as Perl itself.
514
515 =head1 SEE ALSO
516
517 See L<h2xs>, L<ppport.h>.
518
519 =cut
520
521 package Devel::PPPort;
522
523 use strict;
524 use vars qw($VERSION $data);
525
526 $VERSION = '3.21';
527
528 sub _init_data
529 {
530   $data = do { local $/; <DATA> };
531   my $pkg = 'Devel::PPPort';
532   $data =~ s/__PERL_VERSION__/$]/g;
533   $data =~ s/__VERSION__/$VERSION/g;
534   $data =~ s/__PKG__/$pkg/g;
535   $data =~ s/^\|>//gm;
536 }
537
538 sub WriteFile
539 {
540   my $file = shift || 'ppport.h';
541   defined $data or _init_data();
542   my $copy = $data;
543   $copy =~ s/\bppport\.h\b/$file/g;
544
545   open F, ">$file" or return undef;
546   print F $copy;
547   close F;
548
549   return 1;
550 }
551
552 1;
553
554 __DATA__
555 #if 0
556 <<'SKIP';
557 #endif
558 /*
559 ----------------------------------------------------------------------
560
561     ppport.h -- Perl/Pollution/Portability Version __VERSION__
562
563     Automatically created by __PKG__ running under perl __PERL_VERSION__.
564
565     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
566     includes in parts/inc/ instead.
567
568     Use 'perldoc ppport.h' to view the documentation below.
569
570 ----------------------------------------------------------------------
571
572 SKIP
573
574 %include ppphdoc { indent => '|>' }
575
576 %include ppphbin
577
578 __DATA__
579 */
580
581 #ifndef _P_P_PORTABILITY_H_
582 #define _P_P_PORTABILITY_H_
583
584 #ifndef DPPP_NAMESPACE
585 #  define DPPP_NAMESPACE DPPP_
586 #endif
587
588 #define DPPP_CAT2(x,y) CAT2(x,y)
589 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
590
591 %include version
592
593 %include threads
594
595 %include limits
596
597 %include uv
598
599 %include memory
600
601 %include misc
602
603 %include variables
604
605 %include mPUSH
606
607 %include call
608
609 %include newRV
610
611 %include newCONSTSUB
612
613 %include MY_CXT
614
615 %include format
616
617 %include SvREFCNT
618
619 %include newSV_type
620
621 %include newSVpv
622
623 %include SvPV
624
625 %include Sv_set
626
627 %include sv_xpvf
628
629 %include shared_pv
630
631 %include HvNAME
632
633 %include gv
634
635 %include warn
636
637 %include pvs
638
639 %include magic
640
641 %include cop
642
643 %include grok
644
645 %include snprintf
646
647 %include sprintf
648
649 %include exception
650
651 %include strlfuncs
652
653 %include pv_tools
654
655 #endif /* _P_P_PORTABILITY_H_ */
656
657 /* End of File ppport.h */