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