/[projet1]/users/waskol/pc tools/taptap/taptap.dpr
Defence Force logotype

Contents of /users/waskol/pc tools/taptap/taptap.dpr

Parent Directory Parent Directory | Revision Log Revision Log


Revision 110 - (show annotations)
Sat Jun 20 15:46:26 2009 UTC (10 years, 11 months ago) by waskol
File size: 10693 byte(s)


1 program taptap;
2
3 {$APPTYPE CONSOLE}
4
5 uses
6 SysUtils,
7 classes,windows;
8
9 procedure Tips;
10 begin
11 WriteLn('Syntax :');
12 Writeln('--------');
13 Writeln('Catalog :');
14 Writeln(' ',ExtractFileName(ParamStr(0)),' cat <File>');
15 Writeln(' <File>.... : Tap file to be processed - mandatory');
16 writeln(' Example : ',ExtractFileName(ParamStr(0)),' cat myfile.tap');
17 writeln;
18 Writeln('Rename an Oric file in a .tap File :');
19 writeln(' ',ExtractFileName(ParamStr(0)),' ren <TapFile> <Newname> <FileIndex>');
20 writeln(' <FromFile>. : Tap file to be processed - mandatory');
21 writeln(' <NewName>.. : New file name of the oric file to be processed -mandatory');
22 writeln(' The New oric file name can be specified');
23 writeln(' in 2 different ways');
24 writeln(' - as a string : in that case it must be');
25 writeln(' enclosed between quotes');
26 writeln(' examples : "Space Invaders", "Terror of the deep",...');
27 writeln(' - as a succession of 8 bits hexadecimal');
28 writeln(' values (2 digits each), without any space');
29 writeln(' It then permits to have some text attributes');
30 writeln(' into the oric title : ink or paper color, blink...');
31 writeln(' (please refer to Oric manual for values).');
32 writeln(' In that case, the string must be preceeded by');
33 writeln(' the # symbol and the null hexadecimal values (INK 0)');
34 writeln(' are forbidden.');
35 writeln(' example : #0148656C6C6F07');
36 writeln(' ...will print "Hello" in red on the status line');
37 writeln(' while loading.');
38 writeln(' <FileIndex> : File index in Tap File, 0 is the 1st file,');
39 writeln(' index 1 the 2nd, etc - Mandatory');
40 writeln;
41 // TODO :
42 // Writeln('Split a tap File :');
43 // Writeln('Join a tap File :');
44 writeln('Set Auto run On or Off :');
45 writeln(' Simply write');
46 writeln(' ',ExtractFileName(ParamStr(0)),' AutoOn <TapFile> <FileIndex>');
47 writeln(' or');
48 writeln(' ',ExtractFileName(ParamStr(0)),' AutoOff <TapFile> <FileIndex>');
49 end;
50
51 function GetTempFile(const Extension: string): string;
52 var
53 Buffer: array[0..MAX_PATH] of Char;
54 begin
55 repeat
56 GetTempPath(SizeOf(Buffer) - 1, Buffer);
57 GetTempFileName(Buffer, '~', 0, Buffer);
58 Result := ChangeFileExt(Buffer, Extension);
59 until not FileExists(Result);
60 end;
61
62 procedure SetAuto(value:boolean);
63 var f1:TFileStream;
64 b:byte;
65 hheader:array[0..8] of byte;
66 name:string;
67 index,i,j,r,size:integer;
68 AddrDeb,AddrFin:integer;
69 TempFile,bb,cc:string;
70 begin
71 index:=0;
72 f1:=TFileStream.Create(ParamStr(2),fmOpenReadWrite);
73 try
74 f1.Position:=0;
75 while (f1.Position<f1.size) do
76 begin
77 b:=$16;
78 while (b=$16) do r:=f1.Read(b,1); // read synchro (0x24 included)
79 if (f1.Position>=f1.size) then break;
80
81 //header
82 for i:=0 to 8 do
83 begin
84 if ((i=3) and (index<>StrToIntDef(ParamStr(3),-1))) then begin
85 if value then b:=$C7 else b:=0;
86 f1.Write(b,1);
87 end
88 else r:=f1.Read(b,1);
89 end;
90
91 //Name
92 name:='';
93 repeat
94 r:=f1.Read(b,1);
95 until ((b=0) or (r=0));
96
97 //data
98 AddrDeb:=hheader[6]*256+hheader[7];
99 AddrFin:=hheader[4]*256+hheader[5];
100 size:=AddrFin-AddrDeb+1;
101 for i:=0 to size-1 do r:=f1.Read(b,1);
102 inc(index);
103 end;
104 finally
105 f1.Free;
106 end;
107 end;
108
109 procedure rename;
110 var f1,f2:TFileStream;
111 b:byte;
112 hheader:array[0..8] of byte;
113 name:string;
114 index,i,j,r,size:integer;
115 AddrDeb,AddrFin:integer;
116 TempFile,bb,cc:string;
117 begin
118 index:=0;
119 TempFile:=GetTempFile('.~tp');
120 f1:=TFileStream.Create(ParamStr(2),fmOpenRead);
121 f2:=tfilestream.Create(TempFile,fmCreate);
122 try
123 f1.Position:=0;
124 while (f1.Position<f1.size) do
125 begin
126 b:=$16;
127 while (b=$16) do begin
128 r:=f1.Read(b,1); // read synchro (0x24 included)
129 if r=1 then f2.Write(b,1);
130 end;
131 if (f1.Position>=f1.size) then break;
132
133 //header
134 for i:=0 to 8 do
135 begin
136 r:=f1.Read(b,1);
137 hheader[i]:=b;
138 if r=1 then f2.Write(b,1);
139 end;
140
141 //Name
142 name:='';
143 repeat
144 r:=f1.Read(b,1);
145 if ((index<>StrToIntDef(ParamStr(4),-1)) and (r=1))
146 then f2.Write(b,1);
147 until ((b=0) or (r=0));
148
149 if (index=StrToIntDef(ParamStr(4),-1)) then
150 begin
151 bb:=ParamStr(3);
152 case bb[1] of
153 '#':begin
154 j:=(length(bb)-1) div 2;
155 for i:=0 to j-1 do
156 begin
157 cc:='$'+bb[2*i+1]+bb[2*i+2];
158 r:=StrToIntdef(cc,-1);
159 if r>0 then b:=r
160 else b:=32;
161 f2.Write(b,1);
162 end;
163 end
164 else for i:=1 to length(bb) do f2.Write(bb[i],1);
165 end;
166 b:=0;
167 f2.Write(b,1);
168 end;
169
170 //data
171 AddrDeb:=hheader[6]*256+hheader[7];
172 AddrFin:=hheader[4]*256+hheader[5];
173 size:=AddrFin-AddrDeb+1;
174 for i:=0 to size-1 do begin
175 r:=f1.Read(b,1);
176 if r=1 then f2.Write(b,1);
177 end;
178 inc(index);
179 end;
180 finally
181 f1.Free;
182 f2.Free;
183 CopyFile(PChar(TempFile),PChar(ParamStr(2)),false);
184 SysUtils.DeleteFile(TempFile);
185 end;
186 end;
187
188 procedure catalog(FileName:string);
189 var f1:TFileStream;
190 b:byte;
191 size:integer;
192 hheader:array[0..8] of byte;
193 name:string;
194 namehex:string;
195 index,i:integer;
196 AddrDeb,AddrFin:integer;
197 specialname:boolean;
198 begin
199 index:=0;
200 f1:=TFileStream.Create(FileName,fmOpenRead);
201 try
202 writeln('Catalog of "',extractfilename(FileName),'"');
203 f1.Position:=0;
204 while (f1.Position<f1.size) do
205 begin
206 specialname:=false;
207 b:=$16;
208 while (b=$16) do f1.Read(b,1); // read synchro (0x24 included)
209 if (f1.Position>=f1.size) then break;
210
211 //header
212 for i:=0 to 8 do
213 begin
214 f1.Read(b,1);
215 hheader[i]:=b;
216 end;
217
218 //Name
219 name:='';
220 namehex:='';
221 repeat
222 i:=f1.Read(b,1);
223 if ((b<>0) and (i<>0)) then
224 begin
225 namehex:=namehex+IntToHex(b,2)+' ';
226 if b>=32 then name:=name+chr(b)
227 else begin
228 specialname:=true;
229 name:=name+' ';
230 end;
231 end;
232 until ((b=0) or (i=0));
233 AddrDeb:=hheader[6]*256+hheader[7];
234 AddrFin:=hheader[4]*256+hheader[5];
235 size:=AddrFin-AddrDeb+1;
236
237 writeln('Index.... : ',index);
238 write('Name..... : ',name);
239 if specialname then writeln('('+namehex+')')
240 else writeln;
241 write('File kind : ');
242 case hheader[2] of
243 $00:writeln('BASIC');
244 $40:writeln('Array');
245 $80:writeln('Machine code or memory bloc');
246 else writeln('#',inttohex(hheader[2],2));
247 end;
248 write('Auto..... : ');
249 case hheader[3] of
250 $00:writeln('No');
251 else writeln('Yes (#',inttohex(hheader[3],2),')');
252 end;
253 writeln('Starting Address : #',IntToHex(AddrDeb,4));
254 writeln('Ending Address : #',IntToHex(AddrFin,4));
255 writeln('Size............ : ',size,' bytes');
256 writeln;
257 //data
258 for i:=0 to size-1 do begin
259 f1.Read(b,1);
260 end;
261 inc(index);
262 end;
263 finally
264 f1.Free;
265 end;
266 end;
267
268 procedure ExecuteProgram;
269 var command:string;
270 begin
271 if ParamCount=0
272 then begin
273 tips;
274 exit;
275 end;
276 if ParamCount>1
277 then command:=ParamStr(1);
278 if uppercase(command)='CAT' then
279 begin
280 if ((ParamCount=2) and FileExists(ParamStr(2)))
281 then catalog(ParamStr(2))
282 else begin
283 case ParamCount of
284 1:writeln('Not enough parameters !');
285 2:writeln('The file ',ParamStr(2),' does not exist !');
286 else writeln('too many parameters !');
287 end;
288 tips;
289 exit;
290 end;
291 end
292 else if uppercase(command)='REN' then
293 begin
294 if ParamCount<4 then
295 begin
296 writeln('Not enough parameters !');
297 tips;
298 exit;
299 end;
300 if ParamCount>4 then
301 begin
302 writeln('Too many parameters !');
303 tips;
304 exit;
305 end;
306 if ParamCount=4 then
307 begin
308 if not FileExists(ParamStr(2)) then
309 begin
310 writeln('The file ',ParamStr(2),' does not exist !');
311 tips;
312 exit;
313 end;
314 rename;
315 end;
316
317 end
318 else if uppercase(command)='AUTOON' then
319 begin
320 if ParamCount<3 then
321 begin
322 writeln('Not enough parameters !');
323 tips;
324 exit;
325 end;
326 if ParamCount>3 then
327 begin
328 writeln('Too many parameters !');
329 tips;
330 exit;
331 end;
332 if ParamCount=3 then
333 begin
334 if not FileExists(ParamStr(2)) then
335 begin
336 writeln('The file ',ParamStr(2),' does not exist !');
337 tips;
338 exit;
339 end;
340 SetAuto(true);
341 end;
342
343 end
344 else if uppercase(command)='AUTOOFF' then
345 begin
346 if ParamCount<3 then
347 begin
348 writeln('Not enough parameters !');
349 tips;
350 exit;
351 end;
352 if ParamCount>3 then
353 begin
354 writeln('Too many parameters !');
355 tips;
356 exit;
357 end;
358 if ParamCount=3 then
359 begin
360 if not FileExists(ParamStr(2)) then
361 begin
362 writeln('The file ',ParamStr(2),' does not exist !');
363 tips;
364 exit;
365 end;
366 SetAuto(false);
367 end;
368 end
369 // TODO ???
370 //else if command='split' then
371 // begin
372 // end
373 // else if command='join' then
374 // begin
375 // end
376 else tips;
377 end;
378 begin
379 try
380 ExecuteProgram;
381 except
382 //Gérer la condition d'erreur
383 WriteLn('Error encountered, this program terminates...');
384 //Définir ExitCode <> 0 pour indiquer la condition d'erreur (par convention)
385 tips;
386 ExitCode := 1;
387 end;
388 end.

  ViewVC Help
Powered by ViewVC 1.1.26