1################################################################################
2#
3#  PPPort_pm.PL -- generate PPPort.pm
4#
5################################################################################
6#
7#  $Revision: 1.2 $
8#  $Author: millert $
9#  $Date: 2006/03/28 19:23:01 $
10#
11################################################################################
12#
13#  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
14#  Version 2.x, Copyright (C) 2001, Paul Marquess.
15#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
16#
17#  This program is free software; you can redistribute it and/or
18#  modify it under the same terms as Perl itself.
19#
20################################################################################
21
22use strict;
23$^W = 1;
24require "parts/ppptools.pl";
25
26my $INCLUDE = 'parts/inc';
27my $DPPP = 'DPPP_';
28
29my %embed = map { ( $_->{name} => $_ ) }
30            parse_embed(qw(parts/embed.fnc parts/apidoc.fnc));
31
32my(%provides, %prototypes, %explicit);
33
34my $data = do { local $/; <DATA> };
35$data =~ s{^\%(include)\s+(\w+)((?:[^\S\r\n]+.*?)?)\s*$}
36          {eval "$1('$2', $3)" or die $@}gem;
37
38$data = expand($data);
39
40my @api = sort { lc $a cmp lc $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', 'Static Request', 'Global Request') .
55           $1 . '-'x$len . "\n" .
56           join('', map { sprintf "$1$format\n", "$_()", "NEED_$_", "NEED_${_}_GLOBAL" }
57                    sort keys %explicit)
58          /gem;
59}
60
61my %raw_base = %{&parse_todo('parts/base')};
62my %raw_todo = %{&parse_todo('parts/todo')};
63
64my %todo;
65for (keys %raw_todo) {
66  push @{$todo{$raw_todo{$_}}}, $_;
67}
68
69# check consistency
70for (@api) {
71  if (exists $raw_todo{$_}) {
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
83my @perl_api;
84for (keys %provides) {
85  next if exists $embed{$_};
86  push @perl_api, $_;
87  check(2, "No API definition for provided element $_ found.");
88}
89
90push @perl_api, keys %embed;
91
92for (@perl_api) {
93  if (exists $provides{$_} && !exists $raw_base{$_}) {
94    check(2, "Mmmh, $_ doesn't seem to need backporting.");
95  }
96  my $line = "$_|" . (exists $provides{$_} && exists $raw_base{$_} ? $raw_base{$_} : '') . '|';
97  $line .= ($raw_todo{$_} || '') . '|';
98  $line .= 'p' if exists $provides{$_};
99  if (exists $embed{$_}) {
100    my $e = $embed{$_};
101    if (exists $e->{flags}{p}) {
102      my $args = $e->{args};
103      $line .= 'v' if @$args && $args->[-1][0] eq '...';
104    }
105    $line .= 'n' if exists $e->{flags}{n};
106  }
107  $_ = $line;
108}
109
110$data =~ s/^([\t ]*)__PERL_API__(\s*?)$/
111           join "\n", map "$1$_", sort @perl_api
112          /gem;
113
114my @todo;
115for (reverse sort keys %todo) {
116  my $ver = format_version($_);
117  my $todo = "=item perl $ver\n\n";
118  for (sort @{$todo{$_}}) {
119    $todo .= "  $_\n";
120  }
121  push @todo, $todo;
122}
123
124$data =~ s{^__UNSUPPORTED_API__(\s*?)^}
125          {join "\n", @todo}gem;
126
127$data =~ s{__MIN_PERL__}{5.003}g;
128$data =~ s{__MAX_PERL__}{5.9.3}g;
129
130open FH, ">PPPort.pm" or die "PPPort.pm: $!\n";
131print FH $data;
132close FH;
133
134exit 0;
135
136sub include
137{
138  my($file, $opt) = @_;
139
140  print "including $file\n";
141
142  my $data = parse_partspec("$INCLUDE/$file");
143
144  for (@{$data->{provides}}) {
145    if (exists $provides{$_}) {
146      if ($provides{$_} ne $file) {
147        warn "$file: $_ already provided by $provides{$_}\n";
148      }
149    }
150    else {
151      $provides{$_} = $file;
152    }
153  }
154
155  for (keys %{$data->{prototypes}}) {
156    $prototypes{$_} = $data->{prototypes}{$_};
157    $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg;
158  }
159
160  my $out = $data->{implementation};
161
162  if (exists $opt->{indent}) {
163    $out =~ s/^/$opt->{indent}/gm;
164  }
165
166  return $out;
167}
168
169sub expand
170{
171  my $code = shift;
172  $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem;
173  $code =~ s{^\s*
174              __UNDEFINED__
175              \s+
176              (
177                ( \w+ )
178                (?: \( [^)]* \) )?
179              )
180              [^\r\n\S]*
181              (
182                (?:[^\r\n\\]|\\[^\r\n])*
183                (?:
184                  \\
185                  (?:\r\n|[\r\n])
186                  (?:[^\r\n\\]|\\[^\r\n])*
187                )*
188              )
189            \s*$}
190            {expand_undefined($2, $1, $3)}gemx;
191  return $code;
192}
193
194sub expand_undefined
195{
196  my($macro, $withargs, $def) = @_;
197  my $rv = "#ifndef $macro\n#  define ";
198
199  if (defined $def && $def =~ /\S/) {
200    $rv .= sprintf "%-30s %s", $withargs, $def;
201  }
202  else {
203    $rv .= $withargs;
204  }
205
206  $rv .= "\n#endif\n";
207
208  return $rv;
209}
210
211sub expand_pp_expressions
212{
213  my $pp = shift;
214  $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge;
215  return $pp;
216}
217
218sub expand_pp_expr
219{
220  my $expr = shift;
221
222  if ($expr =~ /^\s*need\s*(\w+)\s*$/i) {
223    my $func = $1;
224    my $e = $embed{$func} or die "unknown API function '$func' in NEED\n";
225    my $proto = make_prototype($e);
226    if (exists $prototypes{$func}) {
227      if (compare_prototypes($proto, $prototypes{$func})) {
228        check(1, "differing prototypes for $func:\n  API: $proto\n  PPP: $prototypes{$func}");
229        $proto = $prototypes{$func};
230      }
231    }
232    else {
233      warn "found no prototype for $func\n";;
234    }
235
236    $explicit{$func} = 1;
237
238    $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
239    my $embed = make_embed($e);
240
241    return "defined(NEED_$func)\n"
242         . "static $proto;\n"
243         . "static\n"
244         . "#else\n"
245         . "extern $proto;\n"
246         . "#endif\n"
247         . "\n"
248         . "$embed\n"
249         . "\n"
250         . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)";
251  }
252
253  die "cannot expand preprocessor expression '$expr'\n";
254}
255
256sub make_embed
257{
258  my $f = shift;
259  my $n = $f->{name};
260  my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };
261
262  if ($f->{flags}{n}) {
263    if ($f->{flags}{p}) {
264      return "#define $n $DPPP(my_$n)\n" .
265             "#define Perl_$n $DPPP(my_$n)";
266    }
267    else {
268      return "#define $n $DPPP(my_$n)";
269    }
270  }
271  else {
272    my $undef = <<UNDEF;
273#ifdef $n
274#  undef $n
275#endif
276UNDEF
277    if ($f->{flags}{p}) {
278      if ($f->{flags}{f}) {
279        return "#define Perl_$n $DPPP(my_$n)";
280      }
281      else {
282        return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
283                        "#define Perl_$n $DPPP(my_$n)";
284      }
285    }
286    else {
287      return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
288    }
289  }
290}
291
292sub check
293{
294  my $level = shift;
295
296  if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
297    print STDERR @_, "\n";
298  }
299}
300
301__DATA__
302################################################################################
303#
304#  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
305#
306################################################################################
307#
308#  Perl/Pollution/Portability
309#
310################################################################################
311#
312#  $Revision: 1.2 $
313#  $Author: millert $
314#  $Date: 2006/03/28 19:23:01 $
315#
316################################################################################
317#
318#  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
319#  Version 2.x, Copyright (C) 2001, Paul Marquess.
320#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
321#
322#  This program is free software; you can redistribute it and/or
323#  modify it under the same terms as Perl itself.
324#
325################################################################################
326
327=head1 NAME
328
329Devel::PPPort - Perl/Pollution/Portability
330
331=head1 SYNOPSIS
332
333    Devel::PPPort::WriteFile();   # defaults to ./ppport.h
334    Devel::PPPort::WriteFile('someheader.h');
335
336=head1 DESCRIPTION
337
338Perl's API has changed over time, gaining new features, new functions,
339increasing its flexibility, and reducing the impact on the C namespace
340environment (reduced pollution). The header file written by this module,
341typically F<ppport.h>, attempts to bring some of the newer Perl API
342features to older versions of Perl, so that you can worry less about
343keeping track of old releases, but users can still reap the benefit.
344
345C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
346only purpose is to write the F<ppport.h> C header file. This file
347contains a series of macros and, if explicitly requested, functions that
348allow XS modules to be built using older versions of Perl. Currently,
349Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
350
351This module is used by C<h2xs> to write the file F<ppport.h>.
352
353=head2 Why use ppport.h?
354
355You should use F<ppport.h> in modern code so that your code will work
356with the widest range of Perl interpreters possible, without significant
357additional work.
358
359You should attempt older code to fully use F<ppport.h>, because the
360reduced pollution of newer Perl versions is an important thing. It's so
361important that the old polluting ways of original Perl modules will not be
362supported very far into the future, and your module will almost certainly
363break! By adapting to it now, you'll gain compatibility and a sense of
364having done the electronic ecology some good.
365
366=head2 How to use ppport.h
367
368Don't direct the users of your module to download C<Devel::PPPort>.
369They are most probably no XS writers. Also, don't make F<ppport.h>
370optional. Rather, just take the most recent copy of F<ppport.h> that
371you can find (e.g. by generating it with the latest C<Devel::PPPort>
372release from CPAN), copy it into your project, adjust your project to
373use it, and distribute the header along with your module.
374
375=head2 Running ppport.h
376
377But F<ppport.h> is more than just a C header. It's also a Perl script
378that can check your source code. It will suggest hints and portability
379notes, and can even make suggestions on how to change your code. You
380can run it like any other Perl program:
381
382    perl ppport.h [options] [files]
383
384It also has embedded documentation, so you can use
385
386    perldoc ppport.h
387
388to find out more about how to use it.
389
390=head1 FUNCTIONS
391
392=head2 WriteFile
393
394C<WriteFile> takes one optional argument. When called with one
395argument, it expects to be passed a filename. When called with
396no arguments, it defaults to the filename F<ppport.h>.
397
398The function returns a true value if the file was written successfully.
399Otherwise it returns a false value.
400
401=head1 COMPATIBILITY
402
403F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
404in threaded and non-threaded configurations.
405
406=head2 Provided Perl compatibility API
407
408The header file written by this module, typically F<ppport.h>, provides
409access to the following elements of the Perl API that is not available
410in older Perl releases:
411
412    __PROVIDED_API__
413
414=head2 Perl API not supported by ppport.h
415
416There is still a big part of the API not supported by F<ppport.h>.
417Either because it doesn't make sense to back-port that part of the API,
418or simply because it hasn't been implemented yet. Patches welcome!
419
420Here's a list of the currently unsupported API, and also the version of
421Perl below which it is unsupported:
422
423=over 4
424
425__UNSUPPORTED_API__
426
427=back
428
429=head1 BUGS
430
431If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
432system or any of its tests fail, please use the CPAN Request Tracker
433at L<http://rt.cpan.org/> to create a ticket for the module.
434
435=head1 AUTHORS
436
437=over 2
438
439=item *
440
441Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
442
443=item *
444
445Version 2.x was ported to the Perl core by Paul Marquess.
446
447=item *
448
449Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
450
451=back
452
453=head1 COPYRIGHT
454
455Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
456
457Version 2.x, Copyright (C) 2001, Paul Marquess.
458
459Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
460
461This program is free software; you can redistribute it and/or
462modify it under the same terms as Perl itself.
463
464=head1 SEE ALSO
465
466See L<h2xs>, L<ppport.h>.
467
468=cut
469
470package Devel::PPPort;
471
472require DynaLoader;
473use strict;
474use vars qw($VERSION @ISA $data);
475
476$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.06_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
477
478@ISA = qw(DynaLoader);
479
480bootstrap Devel::PPPort;
481
482sub _init_data
483{
484  $data = do { local $/; <DATA> };
485  my $now = localtime;
486  my $pkg = 'Devel::PPPort';
487  $data =~ s/__PERL_VERSION__/$]/g;
488  $data =~ s/__VERSION__/$VERSION/g;
489  $data =~ s/__DATE__/$now/g;
490  $data =~ s/__PKG__/$pkg/g;
491  $data =~ s/^\|>//gm;
492}
493
494sub WriteFile
495{
496  my $file = shift || 'ppport.h';
497  defined $data or _init_data();
498  my $copy = $data;
499  $copy =~ s/\bppport\.h\b/$file/g;
500
501  open F, ">$file" or return undef;
502  print F $copy;
503  close F;
504
505  return 1;
506}
507
5081;
509
510__DATA__
511#if 0
512<<'SKIP';
513#endif
514/*
515----------------------------------------------------------------------
516
517    ppport.h -- Perl/Pollution/Portability Version __VERSION__
518
519    Automatically created by __PKG__ running under
520    perl __PERL_VERSION__ on __DATE__.
521
522    Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
523    includes in parts/inc/ instead.
524
525    Use 'perldoc ppport.h' to view the documentation below.
526
527----------------------------------------------------------------------
528
529SKIP
530
531%include ppphdoc { indent => '|>' }
532
533%include ppphbin
534
535__DATA__
536*/
537
538#ifndef _P_P_PORTABILITY_H_
539#define _P_P_PORTABILITY_H_
540
541#ifndef DPPP_NAMESPACE
542#  define DPPP_NAMESPACE DPPP_
543#endif
544
545#define DPPP_CAT2(x,y) CAT2(x,y)
546#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
547
548%include version
549
550%include limits
551
552%include uv
553
554%include misc
555
556%include threads
557
558%include mPUSH
559
560%include call
561
562%include newRV
563
564%include newCONSTSUB
565
566%include MY_CXT
567
568%include format
569
570%include SvPV
571
572%include sv_xpvf
573
574%include magic
575
576%include cop
577
578%include grok
579
580%include exception
581
582#endif /* _P_P_PORTABILITY_H_ */
583
584/* End of File ppport.h */
585