1#!/usr/bin/perl -w 2 3use English; 4 5$basefile = $ARGV[0]; 6$basefile =~ s/[.]c$//; 7 8open (DEP, "$ENV{HOME}/devemboss/deprecated.txt") || die "Cannot open deprecated.txt"; 9open (SRC, "$basefile.c") || die "Cannot open $basefile.c"; 10open (OLDSRC, ">$basefile.save") || die "Cannot open $basefile.save"; 11#open (DBG, ">fixdeprecated.dbg") || die "Cannot open fixdeprecated.dbg"; 12 13$patcnt=0; 14$notecnt=0; 15$gonecnt=0; 16$subcnt=0; 17$subcntall=0; 18$new=0; 19 20%gone=(); 21%note=(); 22%argtest=(); 23%pat=(); 24$ok = 1; 25while (<DEP>){ 26 if (/^[\#](\S+)/) { 27 if($1 eq $basefile) {$ok = 0} 28 else {$ok = 1} 29 next; 30 } 31 if(!$ok) {next} 32 if(/^(\S+)\s+[-]$/) { 33 $oldname = "$1\\s*[\\(]"; 34 $gone{$oldname} = 1; 35 $gonecnt++; 36 } 37 elsif(/^(\S+)\s+[=](\S+)\s*(\S+)\s+(\S+)$/) { 38 $oldname = "$1"; 39 $oldpat = "$1\\s*[\\(]([^\\(\\)]*([\\(][^\\)]*[\\)][^\\(\\)]*)*)[\\)]"; 40 $newname = "$2"; 41 $oldargs = $3; 42 $newargs = $4; 43 $subcntall++; 44 if(defined($argtest{$oldpat})) { 45 $argtest{$oldpat} .= ";$oldname $newname $oldargs $newargs"; 46 } 47 else { 48 $subcnt++; 49 $argtest{$oldpat} = "$oldname $newname $oldargs $newargs"; 50 } 51 } 52 elsif(/^(\S+)\s+[@](\S+)\s*$/) { 53 $oldname = "$1\\s*[\\(]"; 54 $newname = "$2"; 55 $note{$oldname} = $newname; 56 $notecnt++; 57 } 58 elsif(/^(\S+)\s+(\S+)\s*$/) { 59 $oldname = "$1\\s*[\\(]"; 60 $newname = "$2("; 61 $pat{$oldname} = $newname; 62 $patcnt++; 63 } 64} 65 66close DEP; 67 68print "$basefile.c: Using $patcnt patterns, $subcntall edits for $subcnt functions and $gonecnt removals\n"; 69 70$savesrc = ""; 71$cnt=0; 72while (<SRC>) { 73 $cnt++; 74 $savesrc .= $_; 75 foreach $g (keys(%gone)) { 76 while(/$g/g) { 77 ($gout) = ($g =~ /([^\\]+)/); 78 print "$basefile.c: No replacement for obsolete $gout in line $cnt\n"; 79 } 80 } 81} 82close SRC; 83print OLDSRC $savesrc; 84 85close OLDSRC; 86 87open (NEWSRC, ">$basefile.c") || die "Cannot open $basefile.c for writing"; 88 89$savepos = 0; 90foreach $n (sort (keys ( %argtest))) { 91 pos($savesrc) = $savepos; 92 if($savesrc =~ /$n/gs) { 93 $savepos = pos($savesrc); 94# print DBG "a matched $n at '$&'\n"; 95 @subarg = split(/;/, $argtest{$n}); 96 foreach $x (@subarg) { 97 ($oldn, $newn, $olda, $newa) = split(/ /, $x); 98# print DBG "oldn '$oldn' newn '$newn' olda '$olda' newa '$newa'\n"; 99 $nkey = "$oldn\_$newn"; 100 @olda = split(/,/, $olda); 101 @newa = split(/,/, $newa); 102 $arga = ""; 103 $i = 0; 104 foreach $a (@olda) { 105# print DBG "Building '$a'\n"; 106 if($i) {$arga .= ","} 107 if($a eq "n") { 108 $arga .= "\\s*NULL\\s*"; 109 } 110 elsif ($a =~ s/^'(.*)'/$1/) { 111 $fix = $1; 112 $fix =~ s/^-/\[-\]/; 113 $arga .= "\\s*$fix\\s*"; 114 } 115 else { 116 $arga .= "[^\\),]*([\\(][^\\)]*[\\)][^\\),]*)*"; 117 } 118# print DBG "So far '$arga'\n"; 119 $i++; 120 } 121 122 $pata = "($oldn"."\\s*[\\(])(".$arga.")[\\)]"; 123# print DBG "b testing $pata\n"; 124 pos($savesrc) = 0; # search from the start 125 while($savesrc =~ /$pata/gs) { 126# print DBG "b matched $pata at '$&'\n"; 127 $savepre = $PREMATCH; 128 $savepost = $POSTMATCH; 129 $arglist = $2; 130# print DBG "$oldn '$arglist'\n"; 131 $i = 0; 132 $pat = "[^\\(\\),]*([\\(][^\\)]*[\\)][^,]*)*[^,]*,"; 133 while ($arglist =~ /$pat/g) { 134 $p = $POSTMATCH; 135 $ai = $&; 136 $ai =~ s/^(\s*)//; 137 $apre[$i] = $1; 138 $ai =~ s/([\s]*)$//; 139 $apost[$i] = $1; 140 $ai =~ s/,$//; 141# print DBG "arg[$i] '$ai'\n"; 142 $ao[$i++] = $ai; 143 $ai = $p; 144 } 145 $ai =~ s/^(\s*)//; 146 $apre[$i] = $1; 147 $ai =~ s/([,\s]*)$//; 148 $apost[$i] = $1; 149 $ao[$i] = $ai; 150# print DBG "Remaining '$ai'\n"; 151 $newtext = "$newn("; 152# for ($i=0; $i <= $#ao; $i++) { 153# print DBG "saved ai[$i] '$apre[$i]' '$ao[$i]' '$apost[$i]'\n"; 154# } 155 $ok = 1; 156# print DBG "Processing newa '$newa' $#newa\n"; 157 for ($i=0; $i <= $#newa; $i++) { 158 if($newa[$i] =~ /^\d+$/) { 159 $j = $newa[$i] - 1; 160 $newtext .= $apre[$i]; 161 $newtext .= $ao[$j]; 162 if($i < $#newa) {$newtext .= ","} 163 $newtext .= $apost[$i]; 164 } 165 elsif($newa[$i] =~ /\[(\d+)\]/) { 166 $j = $1 - 1; 167 $pre = $PREMATCH; 168 $post = $POSTMATCH; 169 $x = $newa[$i]; 170 $newtext .= $apre[$i]; 171 $newtext .= $pre; 172 $newtext .= "("; 173 $newtext .= $ao[$j]; 174 $newtext .= ")"; 175 $newtext .= $post; 176 $newtext .= $apost[$i]; 177 } 178 elsif($newa[$i] =~ /[*]/) { 179# print DBG "** Cannot define arg $i '$newa[$i]': edit by hand"; 180 $ok = 0; 181 } 182 else { 183# print DBG "** Cannot understand arg $i '$newa[$i]': edit by hand"; 184 $ok = 0; 185 next; 186 } 187# print DBG "+ newa[$i] '$newa[$i]' '$newtext'\n"; 188 } 189# print DBG "ok:$ok newtext '$newtext'\n"; 190 if($ok) { 191 $savesrc = $savepre . $newtext . ")" . $savepost; 192 pos($savesrc) = length($savepre) + length($newtext); 193 $subdone{$nkey}++; 194 } 195 } 196 } 197 } 198# if(!defined($notedone{$n})) { 199# ($nout) = ($n =~ /([^\\]+)/); 200# print "$basefile.c: Replace $nout with $note{$n}\n"; 201# } 202} 203 204foreach $p (sort (keys ( %pat))) { 205 $repcnt=0; 206 while($savesrc =~ /$p/g) {$repcnt++} 207 if($repcnt) { 208 $savesrc =~ s/$p/$pat{$p}/g; 209 ($pa) = ($p =~ /(^[^\\]+)/); 210 ($pb) = ($pat{$p} =~ /(^[^\(]+)/); 211 print "$basefile.c: Rename ($repcnt times) $pa to $pb\n"; 212 $new+=$repcnt; 213 } 214} 215 216print NEWSRC $savesrc; 217 218close NEWSRC; 219 220foreach $n (sort (keys ( %subdone))) { 221 ($na,$nb) = ($n =~ /([^_]+)_([^_]+)/); 222 $new+=$subdone{$n}; 223 print "$basefile.c: Replace ($subdone{$n} times) $na with $nb\n"; 224} 225print "$new lines replaced\n"; 226#close DBG; 227