1#!/usr/bin/perl
2
3my(@tonebank, @drumset);
4my(@pathlist, @patch_ext_list);
5my($rcf_count);
6my($def_instr_name);
7my($cfg, $cfgroot);
8my($MAX_AMPLIFICATION);
9
10@pathlist = ('.');
11@patch_ext_list = ('', '.pat', '.shn', '.pat.shn', '.gz', '.pat.gz');
12$rcf_count = 0;
13$MAX_AMPLIFICATION = 800;
14
15if(@ARGV != 1)
16{
17    print STDERR "Usage: $0 cfg-file\n";
18    exit 1;
19}
20
21$cfgroot = $cfg = $ARGV[0];
22if($cfgroot =~ s/\/[^\/]+$//)
23{
24    unshift(@pathlist, $cfgroot);
25}
26
27if(&read_config_file($cfg) != 0)
28{
29    exit 1;
30}
31$rcf_count++;
32&lspatch('bank', @tonebank);
33&lspatch('drumset', @drumset);
34exit 0;
35
36sub read_config_file
37{
38    my($name) = @_;
39    local(*CFG);
40    my(@args, $bank, $line, $orig_name);
41
42    if($rcf_count > 50)
43    {
44	print STDERR "Probable source loop in configuration files";
45	return -1;
46    }
47
48    $orig_name = $name;
49    undef $_;
50    if(!($name = &open_file(*CFG, $name)))
51    {
52	return -1;
53    }
54    undef $_;
55
56    $line = 0;
57    while(<CFG>)
58    {
59	$line++;
60
61	s/^\s+|\r?\n$//;
62
63	@args = split(/[ \t\r\n\240]+/, $_);
64	next if @args == 0 || $args[0] =~ /^$|^#/;
65
66	if($args[0] eq 'dir')
67	{
68	    if(@args < 2)
69	    {
70		print STDERR "$name: line $line: No directory given\n";
71		return -2;
72	    }
73	    shift @args;
74	    map(s/\/+$//, @args);
75	    unshift(@pathlist, reverse(@args));
76	}
77	elsif($args[0] eq 'source')
78	{
79	    if(@args < 2)
80	    {
81		print STDERR "$name: line $line: No file name given\n";
82		return -2;
83	    }
84	    shift @args;
85	    for(@args)
86	    {
87		my($status);
88		$rcf_count++;
89		print "source $_\n";
90		$status = &read_config_file($_);
91		$rcf_count--;
92		if($status != 0)
93		{
94		    return $status;
95		}
96	    }
97	}
98	elsif($args[0] eq 'default')
99	{
100	    if(@args < 2)
101	    {
102		print STDERR "$name: line $line: Must specify exactly one patch name\n";
103		return -2;
104	    }
105	    $def_instr_name = $args[1];
106	}
107	elsif($args[0] eq 'drumset')
108	{
109	    my($i);
110
111	    if(@args < 2)
112	    {
113		print STDERR "$name: line $line: No drum set number given\n";
114		return -2;
115	    }
116	    $i = $args[1];
117	    if($i < 0 || $i > 127)
118	    {
119		print STDERR "$name: line $line: Drum set must be between 0 and 127\n";
120		return -2;
121	    }
122	    if(! defined $drumset[$i])
123	    {
124		$drumset[$i] = [];
125	    }
126	    $bank = $drumset[$i];
127	}
128	elsif($args[0] eq 'bank')
129	{
130	    my($i);
131	    if(@args < 2)
132	    {
133		print STDERR "$name: line $line: No bank number given\n";
134		return -2;
135	    }
136	    $i = $args[1];
137	    if($i < 0 || $i > 127)
138	    {
139		print STDERR "$name: line $line: Tone bank must be between 0 and 127\n";
140		return -2;
141	    }
142	    if(! defined $tonebank[$i])
143	    {
144		$tonebank[$i] = [];
145	    }
146	    $bank = $tonebank[$i];
147	}
148	else
149	{
150	    my($i, $patch);
151
152	    if(@args < 2 || $args[0] !~ /^[0-9]/)
153	    {
154		print STDERR "$name: line $line: syntax error\n";
155		return -2;
156	    }
157
158	    $i = shift @args;
159	    $patch = shift @args;
160	    if($i < 0 || $i > 127)
161	    {
162		printf STDERR "$name: line $line: Program must be between 0 and 127\n";
163		return -2;
164	    }
165
166	    if(! defined $bank)
167	    {
168		print STDERR "$name: line $line: Must specify tone bank or drum set before assignment\n";
169		return -2;
170	    }
171
172	    for(@args)
173	    {
174		my($x, $y) = split(/=/, $_, 2);
175
176		if($x eq 'amp')
177		{
178		    if($y < 0 || $y > $MAX_AMPLIFICATION || $y !~ /^[0-9]/)
179		    {
180			print STDERR "$name: line $line: amplification must be between 0 and $MAX_AMPLIFICATION\n";
181			return -2;
182		    }
183		}
184		elsif($x eq 'note')
185		{
186		    if($y < 0 || $y > 127 || $y !~ /^[0-9]/)
187		    {
188			print STDERR "$name: line $line: note must be between 0 and 127\n";
189			return -2;
190		    }
191		}
192		elsif($x eq 'pan')
193		{
194		    my($k);
195		    if($y eq 'center')
196		    {
197			$k = 64;
198		    }
199		    elsif($y eq 'left')
200		    {
201			$k = 0;
202		    }
203		    elsif($y eq 'right')
204		    {
205			$k = 127;
206		    }
207		    else
208		    {
209			$k = int(($y + 100) * 100 / 157);
210		    }
211		    if($k < 0 || $k > 127 ||
212		       ($k == 0 && $y !~ /^[0-9\-]/))
213		    {
214			print STDERR "$name: line $line: panning must be left, right, center, or between -100 and 100\n";
215			return -2;
216		    }
217		}
218		elsif($x eq 'keep')
219		{
220		    if($y ne 'env' && $y ne 'loop')
221		    {
222			print STDERR "$name: line $line: keep must be env or loop\n";
223			return -2;
224		    }
225		}
226		elsif($x eq 'strip')
227		{
228		    if($y ne 'env' && $y ne 'loop' && $y ne 'tail')
229		    {
230			print STDERR "$name: line $line: strip must be env, loop, or tail\n";
231			return -2;
232		    }
233		}
234		elsif($x eq 'comm')
235		{
236		    ;
237		}
238		else
239		{
240		    print STDERR "$name: line $line: bad patch option\n";
241		    return -2;
242		}
243	    }
244
245	    $bank->[$i] = ["$name:$line", $patch, @args];
246	}
247    }
248
249    close(CFG);
250    return 0;
251}
252
253sub open_file
254{
255    local(*fiz) = shift;
256    my($fname) = shift;
257
258    if($fname =~ /^\//)
259    {
260	if(open(*fiz, $fname))
261	{
262	    return $fname;
263	}
264	return 0;
265    }
266
267    for(@pathlist)
268    {
269	return "$_/$fname" if open(*fiz, "$_/$fname");
270    }
271
272    print STDERR "$fname: $!\n" if $rcf_count == 0;
273    return 0;
274}
275
276sub lspatch
277{
278    my($tag, @insts) = @_;
279    my($i, $j, $bank, $p, @inst, $pos);
280
281    for($i = 0; $i < 128; $i++)
282    {
283	next if !defined $insts[$i];
284	$bank = $insts[$i];
285
286	for($j = 0; $j < 128; $j++)
287	{
288	    next if !defined $bank->[$j];
289	    $p = $bank->[$j];
290	    @inst = @$p;
291	    $pos = shift @inst;
292
293#	    $p = $bank->[$j]->[1];
294	    print "$tag $i $pos: $j @inst ", &find_patch($inst[0]), "\n";
295	}
296    }
297}
298
299sub find_patch
300{
301    my($f) = @_;
302    local(*FIZ);
303    my($realpath);
304
305    for(@patch_ext_list)
306    {
307	$realpath = &open_file(*FIZ, "$f$_");
308	return $realpath if $realpath;
309    }
310
311    return "-";
312}
313