1#!/usr/bin/perl
2###########################################
3# 5005it -- make a PM file 5005-compatible
4# Mike Schilli, 2002 (m@perlmeister.com)
5###########################################
6use 5.00503;
7use strict;
8
9use File::Find;
10
11my $USEVARS_DONE = 0;
12my @OUR_VARS     = ();
13
14###########################################
15sub mk5005 {
16###########################################
17    find(\&process_file, "lib", "t");
18}
19
20###########################################
21sub process_file {
22###########################################
23    my($file) = $_;
24
25    return unless -f $file;
26
27    $USEVARS_DONE = 0;
28    @OUR_VARS     = ();
29
30    open FILE, "<$file" or die "Cannot open $file";
31    my $data = join '', <FILE>;
32    close FILE;
33
34    while($data =~ /^our[\s(]+([\$%@][\w_]+).*[;=]/mg) {
35        push @OUR_VARS, $1;
36    }
37
38        # Replace 'our' variables
39    $data =~ s/^our[\s(]+[\$%@][\w_]+.*/rep_our($&)/meg;
40
41        # Replace 'use 5.006' lines
42    $data =~ s/^use\s+5\.006/\nuse 5.00503/mg;
43
44        # Delete 'no/use warnings;': \s seems to eat newlines, so use []
45    $data =~ s/^[ \t]*use warnings;//mg;
46    $data =~ s/^[ \t]*no warnings.*?;/\$\^W = undef;/mg;
47
48        # 5.00503 can't handle constants that start with a _
49    $data =~ s/_INTERNAL_DEBUG/INTERNAL_DEBUG/g;
50
51        # Anything before 5.6.0 doesn't have the two argument binmode.
52        # Convert to one arg version by discarding second arg.
53    $data =~ s{ binmode \s* \(? (.*?) , .* \)? \s* ; }{ "binmode $1 ;" }gex;
54
55    open FILE, ">$file" or die "Cannot open $file";
56    print FILE $data;
57    close FILE;
58}
59
60###########################################
61sub rep_our {
62###########################################
63    my($line) = @_;
64
65    my $out = "";
66
67    if(!$USEVARS_DONE) {
68        $out = "use vars qw(" . join(" ", @OUR_VARS) . "); ";
69        $USEVARS_DONE = 1;
70    }
71
72    if($line =~ /=/) {
73            # There's an assignment, just skip the 'our'
74        $line =~ s/^our\s+//;
75    } else {
76            # There's nothing, just get rid of the entire line
77        $line = "\n";
78    }
79
80    $out .= $line;
81    return $out;
82}
83
841;
85