This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / ext / man2mus
1 #!/usr/bin/perl
2 while (<>) {
3     if (/^\.SH SYNOPSIS/) {
4         $spec = '';
5         for ($_ = <>; $_ && !/^\.SH/; $_ = <>) {
6             s/^\.[IRB][IRB]\s*//;
7             s/^\.[IRB]\s+//;
8             next if /^\./;
9             s/\\f\w//g;
10             s/\\&//g;
11             s/^\s+//;
12             next if /^$/;
13             next if /^#/;
14             $spec .= $_;
15         }
16         $_ = $spec;
17         0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g;
18         s/\(\*([^,;]*)\)\(\)/(*)()$1/g;
19         s/(\w+)\[\]/*$1/g;
20
21         s/\n/ /g;
22         s/\s+/ /g;
23         s/(\w+) \(([^*])/$1($2/g;
24         s/^ //;
25         s/ ?; ?/\n/g;
26         s/\) /)\n/g;
27         s/ \* / \*/g;
28         s/\* / \*/g;
29
30         $* = 1;
31         0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g;
32         $* = 0;
33         s/\|/,/g;
34
35         @cases = ();
36         for (reverse split(/\n/,$_)) {
37             if (/\)$/) {
38                 ($type,$name,$args) = split(/(\w+)\(/);
39                 $type =~ s/ $//;
40                 if ($type =~ /^(\w+) =/) {
41                     $type = $type{$1} if $type{$1};
42                 }
43                 $type = 'int' if $type eq '';
44                 @args = grep(/./, split(/[,)]/,$args));
45                 $case = "CASE $type $name\n";
46                 foreach $arg (@args) {
47                     $type = $type{$arg} || "int";
48                     $type =~ s/ //g;
49                     $type .= "\t" if length($type) < 8;
50                     if ($type =~ /\*/) {
51                         $case .= "IO    $type   $arg\n";
52                     }
53                     else {
54                         $case .= "I     $type   $arg\n";
55                     }
56                 }
57                 $case .= "END\n\n";
58                 unshift(@cases, $case);
59             }
60             else {
61                 $type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/;
62             }
63         }
64         print @cases;
65     }
66 }