Skip to content
This repository
tag: v644
Fetching contributors…

Cannot retrieve contributors at this time

executable file 160 lines (137 sloc) 5.005 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
#!/usr/bin/perl -w

$debugmodule = "DebugVariables";

use Getopt::Std;
%options=();
getopts("drhf:",\%options);

sub HELP_MESSAGE {
    print STDERR <<EOF;

Preprocesses ocaml source files for debug

File syntax (quick summary):
#<Debug> / #<Else> / #<End>
Filter according to PPDEBUG mode (-d switch)
#<If:VAR TEST> / #<Else> / #<End>
Do a run-time check on environment variable VAR (applying function
TEST on its value if TEST is present). Disabled in release mode (-r
switch). If #<Else> is absent, unit is assumed.
If TEST is used, the character \$ can be used as the ppdebug module
prefix (${debugmodule}.).
#<Ifstatic:VAR REGEXP> / #<Else> / #<End>
Do a static check at compile-time on the value of environment
variable VAR.
#<Debugvar:VAR>
Define VAR as the default to test in following #<If> tests.

See $debugmodule for more information on the syntax.

Invocation: $0 [-d] [-r] [file]
-d enable debug sections
-r release mode: comment out dynamic environment checks
file file to parse, by default stdin

The output is put to stdout
EOF
    exit 0;
}

local $SIG{__WARN__} = sub { die $_[0] }; # Exit on anything suspicious

$file = $ARGV[0];
$file = defined($file) ? $file : "/dev/stdin";
$ppdebug = $options{d} ? 1 : ($ENV{'MLSTATE_PPDEBUG'});
$release = $options{r};

open F,$file or die "Couldn't open $file";

sub filterline {
    my $rec = shift;
    $line = <F>;
    return $line unless defined($line);

    sub nextline {
      print;
      $_ = filterline(1);
      die "ppdebug parse error (unclosed block ?) in $file, line ${.}.\n" unless defined($line);
      return $line = $_;
    }

    # Default debug variable definition
    if ($line =~ /^(.*)(#<Debugvar:([A-Z0-9_]+)(\$.*?)?>)(.*)$/) {
      $debugvar = $3;
      if (defined($4)) { $debugtoggle = $4; }
      $line = "$1(* $2 *)$5\n";
    }

    # Old ppdebug style
    if ($line =~ /#<>/) {
      if ($ppdebug) { $line =~ s/(#<>)/(* $1 *)/; }
      else { $line =~ s/(#<>.*)/(* $1 *)/; }
      return $line;
    }
    elsif ($line =~ /#<</) {
      if ($ppdebug) { $line =~ s/(#<<)(.*?)(>>#\s*;?)/(* $1 *)$2(* $3 *)/g; }
      else { $line =~ s/(#<<.*?>>#\s*;?)/(* $1 *)/g; }
      return $line;
    }

    # New advanced ppdebug style
    elsif ($line =~ /^(.*)(#<(Debug|Ifstatic:\s*(.*?))>)(.*)$/) {
        my $enable;
        my $linebeg = "$1(* $2 *)";
        my $lineend = "$5";
        if ($3 eq "Debug") {
          $enable = $ppdebug;
        } else {
          $4 =~ /^([A-Z0-9_]+)\s+(.*?)\s*$/ || die "Bad Ifstatic syntax";
          $enable = defined($ENV{$1}) && ($ENV{$1} =~ /^$2$/);
        }
        $lineend =~ s/^([^ ])/ $1/;
        print $linebeg.($enable ? " " : "(* ");
        $_ = "$lineend\n";

        nextline until /^(.*?)(#<(Else|End)>)(.*)$/;
        $linebeg = $1.($enable ? "" : "*)")."(* $2 *)";
        $lineend = $4;
        if ($3 eq "Else") {
            $lineend =~ s/^([^ ])/ $1/;
            print "$linebeg".($enable ? "(* " : " ");
            $_ = "$lineend\n";
            nextline until /^(.*)(#<End>)(.*)$/;
            $line = $1.($enable ? "*)" : "")."(* $2 *)$3\n";
        }
        else {
          $line = "$linebeg$lineend\n";
        }
        print $line;
        return filterline($rec);
    }
    elsif ($line =~ /^(.*)(#<If(:([A-Z0-9_]+))?((\s+|\$).*?)?>)(.*)$/) {
        my $linebeg = "$1(* $2 *)";
        my $lineend = "$7";
        my ($var,$toggle) = ($4, $5);
        $lineend =~ s/^([^ ])/ $1/;
        $var = $debugvar unless defined($var);
        if (defined($debugvar)) {
          if ($var eq $debugvar) { $toggle = $debugtoggle unless defined($toggle);}}

        die "Error: undefined debug var in $file, line ${.}. Use either #<If:VAR> or #<Debugvar:VAR>\n"
          unless defined($var);
        $var = lc($var);

        if (defined($toggle)) { $toggle =~ s/\$/${debugmodule}./g; }
        else { $toggle = "${debugmodule}.default"; }

        print $linebeg.($release ? "(* " : " ")."if ($toggle) ${debugmodule}.$var then begin";
        $_ = "$lineend\n";

        nextline until /^(.*?)(#<(Else|End)>)(.*)$/;
        $linebeg = $1."(* $2 *) end else".($release ? " *)" : "")." begin";
        $lineend = $4;

        if ($3 eq "Else") {
            print $linebeg;
            $lineend =~ s/^([^ ])/ $1/;
            $_ = "$lineend\n";
            nextline until /^(.*)#<End>(.*)/;
            $linebeg = $1;
            $lineend = $2;
            $lineend =~ s/^([^ ])/ $1/;
            $line = "$linebeg(* #<End> *) end$lineend\n";
        } else {
            $lineend =~ s/^([^ ])/ $1/;
            $line = "$linebeg () end$lineend\n";
        }
        print $line;
        return filterline($rec);
    }
    elsif ($line =~ /(#<(.*?)>)/ && $2 !~ /^Debugvar:[A-Z0-9_]+(\$.*?)?$/ && (!$rec || $2 !~ /^(Else|End)$/)) {
      die "Error: non-parsed ppdebug directive $1 in $file, line ${.}.\n";
    }
    else {
        return ($line);
    }
}

print "#1 \"$file\" (* -*- tuareg -*- *)\n";
print while (defined ($_ = filterline));
Something went wrong with that request. Please try again.