util/withlibctx.pl

   1 #! /usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5 use File::Temp qw/tempfile/;
   6
   7 my $topdir = shift;
   8
   9 processallfiles($topdir);
  10 print "Success\n";
  11
  12 sub processallfiles {
  13     my $dir = shift;
  14     my @files = glob "$dir/*.c $dir/*.h $dir/*.h.in $dir/*.pod *dir/*.pod.in";
  15
  16     open (my $STDOUT_ORIG, '>&', STDOUT);
  17
  18     foreach my $file (@files) {
  19         my ($tmpfh, $tmpfile) = tempfile();
  20
  21         print "Processing $file\n";
  22         open(STDOUT, '>>', $tmpfile);
  23         open(INFILE, $file);
  24         processfile(\*INFILE);
  25         close(STDOUT);
  26         rename($tmpfile, $file);
  27         unlink($tmpfile);
  28         # restore STDOUT
  29         open (STDOUT, '>&', $STDOUT_ORIG);
  30     }
  31
  32     #Recurse through subdirs
  33     opendir my $dh, $dir or die "Cannot open directory";
  34
  35     while (defined(my $subdir = readdir $dh)) {
  36         next unless -d "$dir/$subdir";
  37         next if (rindex $subdir, ".", 0) == 0;
  38         processallfiles("$dir/$subdir");
  39     }
  40     closedir $dh;
  41 }
  42
  43 sub processfile {
  44     my $fh = shift;
  45     my $multiline = 0;
  46     my @params;
  47     my $indent;
  48     my $paramstr = "";
  49
  50     foreach my $line (<$fh>) {
  51         chomp($line);
  52         if (!$multiline) {
  53             if ($line =~ /^(.+)_with_libctx\((.*[^\\])$/) {
  54                 my $preline = $1;
  55                 my $postline = $2;
  56                 #Strip trailing whitespace
  57                 $postline =~ s/\s+$//;
  58                 print $preline.'_ex(';
  59                 my @rets = extracttoclose($postline);
  60                 if (@rets) {
  61                     print "$postline\n";
  62                     $multiline = 0;
  63                 } else {
  64                     $multiline = 1;
  65                     $paramstr = $postline;
  66                     $indent = (length $preline) + (length '_ex(');
  67                 }
  68             } else {
  69                 #Any other reference to _with_libctx we just replace
  70                 $line =~ s/_with_libctx/_ex/g;
  71                 print $line."\n";
  72             }
  73         } else {
  74             #Strip leading whitespace
  75             $line =~ s/^\s+//;
  76             #Strip trailing whitespace
  77             $line =~ s/\s+$//;
  78             my @rets = extracttoclose($paramstr.$line);
  79             if (@rets) {
  80                 my $pre = shift @rets;
  81                 my $post = shift @rets;
  82                 @params = split(",", $pre);
  83                 my @params = grep(s/^\s*|\s*$//g, @params);
  84                 formatparams($indent, @params);
  85                 print ')'.$post."\n";
  86                 $multiline = 0;
  87             } else {
  88                 $paramstr .= $line;
  89             }
  90         }
  91     }
  92
  93     die "End of multiline not found" if $multiline;
  94 }
  95
  96 sub formatparams {
  97     my $indent = shift;
  98     my @params = @_;
  99
 100     if (@params) {
 101         my $param = shift @params;
 102         my $lensofar += $indent + (length $param) + 1;
 103
 104         print "$param";
 105         print "," if @params;
 106
 107         while (@params) {
 108             my $param = shift @params;
 109
 110             if (($lensofar + (length $param) + 2) > 80) {
 111                 print "\n".(" " x $indent);
 112                 print $param;
 113                 $lensofar = $indent + (length $param) + 1;
 114             } else {
 115                 print ' '.$param;
 116                 $lensofar += (length $param) + 2;
 117             }
 118             print "," if @params;
 119         }
 120     }
 121 }
 122
 123 sub extracttoclose {
 124     my $inline = shift;
 125     my $outline = "";
 126
 127     while ($inline =~ /^([^\)]*?)\((.*)$/) {
 128         my @rets = extracttoclose($2);
 129         if (!@rets) {
 130             return ();
 131         }
 132         my $inside = shift @rets;
 133         my $post = shift @rets;
 134         $outline .= $1.'('.$inside.')';
 135         $inline = $post;
 136     }
 137     if ($inline =~ /^(.*?)\)(.*)$/) {
 138         return ($outline.$1, $2);
 139     }
 140     return ();
 141 }