BinIO.p

Unit BinIO;

{ v1.0 by MisterAkko, 18 Agosto 1993 }
{ Riscrittura completa di TextIo v2.5.1 che salva gli elementi nel loro
formato binario e non traducendolo in testo.

BinIO continua a fornire IToS e SToI come in passato, ma non ne fa uso interno.

v1.1 del 11 febbraio 1994. Ora fornisce anche funzioni per l'output
di stringhe secondo il formato specificato dal pannello di controllo
Numeri

v1.1.1 del 25 agosto 96
Cambiata la API di WriteRes a beneficio di ScenarioMaker 2.0

v1.1.2 del 22 dicembre 1996
WriteRes usava un Integer anzichŽ un Longint per memorizzare un file ID. Fixed.
}

Interface

uses 
	Types,
	QuickDraw,
	OSUtils,
	SegLoad,
	{ List 3 - needs List 1/2 types }
	Files;				{ needs OSUtils, SegLoad }


Type
	MyFile = record
		errore: Integer;	{ Ultimo errore ivi ottenuto }
		FSS: FSSpec;		{ File system specification }
		refNum,				{ File reference number when open (Data fork) }
		resFork: Integer;	{ File reference number when open (Res fork) }
		mark: Longint;		{ Current mark position }
		end;

Procedure Reset (var openedFile: MyFile; pathname: String);
{ Apre il file menzionato. Accetta pathname completo,
	incompleto (basato su working directory corrente) o semplice
	filename (basato su volume corrente, p.es. dopo una chiamata a SetVol
	con il valore restituito da Standard File package). }
Procedure ResetByFSS (var openedFile: MyFile; spec: FSSpec);
{ Idem, ma il file da aprire  passato via FSS }
Procedure ResetR (var openedFile: MyFile; pathname: String);
{ Apre il file menzionato, e apre anche il suo ramo risorse }
Procedure ResetRByFSS (var openedFile: MyFile; spec: FSSpec);
{ Idem, ma il file da aprire  passato via FSS }

Procedure Rewrite (var theFile: MyFile; pathname: String;
						fileType, fileOwner: OSType);
{ Apre il file menzionato per la scrittura; se necess. lo crea }
{ Idem, ma il file da aprire  passato via FSS }
Procedure RewriteByFSS (var theFile: MyFile; spec: FSSpec;
						fileType, fileOwner: OSType);
Procedure RewriteR (var theFile: MyFile; pathname: String;
						  fileType, fileOwner: OSType);
{ Apre il file menzionato per la scrittura, e crea anche un ramo risorse }
Procedure RewriteRByFSS (var theFile: MyFile; spec: FSSpec;
						  fileType, fileOwner: OSType);
{ Idem, ma il file da aprire  passato via FSS }

Procedure ReadNWrite (var openedFile: MyFile; pathname: String);
{ Apre il file in lettura e scrittura. Il file deve pre-esistere, ed  consentito
leggere e scrivere indifferentemente }
Procedure ReadNWriteByFSS (var openedFile: MyFile; spec: FSSpec);
{ Idem, ma il file da aprire  passato via FSS }
Procedure ReadNWriteRByFSS (var openedFile: MyFile; spec: FSSpec);
{ Idem, ma apre anche il ramo risorse. Se non c', lo crea. }

Function DeleteFile (pathname: string): OSErr;
{ Distrugge il file menzionato, il cui pathname pu˜ essere specificato come
	visto per reset }

Function RenameFile (pathname, newname: string): OSErr;
{ Cambia nome a un file }

Procedure ReadLn (var theFile: MyFile; var s: string);
{ Legge da file BINARIO una stringa, la riformatta in stringa Pascal e la
	restituisce al chiamante }
Procedure WriteLn (var theFile: MyFile; s: string);
{ Scrive una stringa sul file. Osservazione valida per tutte le chiamate di
	tipo ÒwriteÓ: per ottimizzare gli accessi a disco, TextIO lascia che il S.O.
	bufferizzi le scritture. Se per qualche motivo  necessario che la scrittura
	sia fisica, far seguire la chiamata a Write dalla chiamata
			errore := FlushVol (nil, ilFile.FSS.vRefNum);
}

Procedure MoveMark (var theFile: MyFile; moveHow: integer;
	offset: longint);
{ Sposta la posizione corrente nel file. l'offset pu˜ venire specificato in posizione
assoluta dall'inizio del file (moveHow = fsFromStart) oppure da quella corrente
(moveHow = fsFromMark) }

Procedure WriteRes (var theFile: MyFile; theId: integer; theType: ResType;
	theName: Str255; theData: Handle);
{ Aggiunge una risorsa al file. La risorsa  scritta immediatamente.
	Se la handle punta a dati ritornati dal resource manager,  necessario chiamare
	DetachResource (theData) prima di questa procedura.
	SIDE EFFECT: Se il ramo risorse del file non  aperto, la risorsa viene scritta
	all'interno del ramo risorse dell'applicazione corrente }

Procedure ReadLongint (var f: MyFile; var i: longint);
Procedure ReadInt (var f: MyFile; var i: integer);
Procedure ReadByte (var f: MyFile; var i: Byte);
{ Legge un intero da file, come FORMATO BINARIO, e lo restituisce }
Procedure WriteLongInt (var f: MyFile; i: longint);
Procedure WriteInt (var f: MyFile; i: Integer);
Procedure WriteByte (var f: MyFile; i: Byte);
{ Scrive un intero sul file, come FORMATO BINARIO }

Procedure HandleRead (var theFile: MyFile; var count: longint; h: handle);
{ Legge count caratteri dal file e li mette nel buffer fornito }
Procedure HandleWrite (var theFile: MyFile; var count: longint; h: handle);
{ Complementare di HandleRead }

Procedure PtrRead (var theFile: MyFile; var count: longint; p: ptr);
{ Legge count caratteri dal file e li mette nel buffer fornito }
Procedure PtrWrite (var theFile: MyFile; var count: longint; p: ptr);
{ Complementare di PtrRead }

Function Eof (var theFile: MyFile): boolean;

Function FileLength (var theFile: MyFile): longint;

Procedure Close (var theFile: MyFile);
{ Chiude il file, sia ramo dati che ramo risorse }

{ --------- Utility di conversione num-testi ------------- }

Function Stoi (s: string): longint;
Function Itos (i: longint): string;
{$IFC POWERPC}
{$ELSEC}
INLINE
	$201F, {MOVE.L (A7)+,D0}
	$205F, {MOVE.L (A7)+,A0}
	$4267, {CLR.W -(A7)}
	$A9EE, {_Pack7}
	$2F08; {MOVE.L A0,-(A7)}
{$ENDC}

PROCEDURE InitializeDefaultNumberSeparators;
{ Da chiamare prima di una qualsiasi delle seguenti }

FUNCTION IntegerToLocalString (theNumber: LongInt): Str255;
{ Converte un numero in una stringa con i punti delle migliaia corretti }

FUNCTION LocalStringToInteger (theString: Str255): LongInt;
{ Converte una stringa in un numero togliendo i punti delle migliaia }

Implementation

Uses
	Controls,
	Errors,
	Events,
	Finder,
	FixMath,
	IntlResources,
	Memory,
	Resources,
	TextEdit,
	TextUtils,
	ToolUtils
	{ List 2 }
	,Windows			{ needs Events, Controls }
	{ List 3 - needs List 1/2 types }
	,Aliases			{ (3.2) needs Memory }
	,Script				{ needs OSUtils, FixMath }
	{ List 4 - needs List 1/2/3 types }
	,Dialogs			{ needs TextEdit, Windows }
	,StandardFile		{ (3.2) needs Aliases }
	{ List 5 - needs List 1/2/3/4 types }
	,Packages;			{ needs Dialogs, Files, Script, StandardFile (3.2) }

Procedure ResetByFSS (var openedFile: MyFile; spec: FSSpec);
var
	paramBlock: HParamBlockRec;
begin
	with openedFile do begin
		FSS := spec;
		{ Prova la chiamata di apertura di rete, con privilegio bassissimo.}
		with paramBlock do begin
			ioCompletion := nil;
			ioNamePtr := @FSS.name;
			ioDenyModes := $0001; { read only, don't deny others }
			ioDirID := FSS.parID;
			ioVRefNum := FSS.VRefNum;
			end;
		errore := PBHOpenDenySync (@paramBlock);
		{ Se questa non funziona correttamente, ricorri alla chiamata di alto
		livello del file manager (vedi IM V 384, Things to do, punto 1 }
		if errore = paramErr then
			errore := FSpOpenDF (FSS, fsRdPerm, refNum)
		else
			refNum := paramBlock.ioRefNum;
		mark := 0;
		resFork := 0
	end { with }
end;

Procedure Reset (var openedFile: MyFile; pathname: String);
var
	spec: FSSpec;
begin
	{ Crea un FSSpec per il nostro file, poi rivolgiti a ResetByFSS }
	with openedFile do begin
		errore := FSMakeFSSpec (0, 0, pathname, spec);
		if errore = noErr then
			ResetByFSS (openedFile, spec)
		end
end;

Procedure ResetRByFSS (var openedFile: MyFile; spec: FSSpec);
begin
	ResetByFSS (openedFile, spec);
	WITH openedFile DO IF errore = noErr THEN BEGIN
		resFork := FSpOpenResFile (FSS, fsCurPerm);
		errore := ResError;
		if errore = eofErr THEN BEGIN
			{ There is no resource fork! }
			resFork := 0;
			errore := noErr
			END;
		END
end;

Procedure ResetR (var openedFile: MyFile; pathname: String);
begin
	Reset (openedFile, pathname);
	with openedFile do
		if errore = noErr then BEGIN
			resFork := FSpOpenResFile (FSS, fsRdWrPerm);
			errore := ResError
			END
end;

Procedure RewriteByFSS (var theFile: MyFile; spec: FSSpec;
						fileType, fileOwner: OSType);
const
	tempFileName = 'MrAkko''s temp file';
var
	tempFSS: FSSpec;
	e: OSErr;
	dummy: FInfo;
begin
	{ Innanzitutto, scopriamo se il file esiste }
	with theFile do begin
		errore := FSpGetFInfo (spec, dummy);
		FSS := spec;
		case errore of
			fnfErr: { crealo e aprilo }
				begin
					errore := FSpCreate (FSS, fileOwner, fileType, smSystemScript);
					if errore <> noErr then
						exit (RewriteByFSS)
				end;
			noErr: { C' giˆ, quindi aprilo e azzeralo }
				begin
					{ Crea un file temporaneo nel quale salvare }
					errore := FSMakeFSSpec (FSS.vRefNum, FSS.parID,
													tempFileName, tempFSS);
					CASE errore OF
						fnfErr :; { Tutto bene, ho creato il file con nome temp }
						noErr: { C' giˆ un file temponeao con quel nome.
							Lo distruggo nella speranza che si tratti di un
							residuo di un crash passato }
							errore := FSpDelete (tempFSS);
						OTHERWISE
							exit (RewriteByFSS);
						END;
					errore := FSpCreate (tempFSS, fileOwner, fileType, smSystemScript);
					if errore <> noErr then
						exit (RewriteByFSS);
					errore := FSpExchangeFiles (FSS, tempFSS);
					if errore <> noErr then
						exit (RewriteByFSS);
					errore := FSpDelete (tempFSS);
					if errore <> noErr then begin
						e := FSpExchangeFiles (FSS, tempFSS);
						exit (RewriteByFSS);
						end;
				end { if overwritten }
			end; { case }
		errore := FSpOpenDF (FSS, fsRdWrPerm, refNum);
		if errore <> noErr then
			exit (RewriteByFSS);
		mark := 0;
		resFork := 0
		end { with }
end;

Procedure Rewrite (var theFile: MyFile; pathname: String;
					fileType, fileOwner: OSType);
begin
	{ Crea un FSSpec per il nostro file }
	with theFile do begin
		errore := FSMakeFSSpec (0, 0, pathname, FSS);
		if (errore = noErr) OR (errore = fnfErr) then
			RewriteByFSS (theFile, FSS, fileType, fileOwner)
		end
end;

Procedure RewriteRByFSS (var theFile: MyFile; spec: FSSpec;
						  fileType, fileOwner: OSType);
begin
	RewriteByFSS (theFile, spec, fileType, fileOwner);
	with theFile do
		if errore = noErr then begin
			HCreateResFile (FSS.vRefNum, FSS.parID, FSS.name);
			{ Non pu˜ esistere giˆ: Rewrite l'avrebbe cancellato }
			errore := ResError;
			if errore = noErr then BEGIN
				resFork := FSpOpenResFile (FSS, fsRdWrPerm);
				errore := ResError
				END; 
			end
end;

Procedure RewriteR (var theFile: MyFile; pathname: String;
						  fileType, fileOwner: OSType);
begin
	Rewrite (theFile, pathname, fileType, fileOwner);
	with theFile do
		if errore = noErr then begin
			HCreateResFile (FSS.vRefNum, FSS.parID, FSS.name);
			{ Non pu˜ esistere giˆ: Rewrite l'avrebbe cancellato }
			errore := ResError;
			if errore = noErr then BEGIN
				resFork := FSpOpenResFile (FSS, fsRdWrPerm);
				errore := ResError
				END
			end
end;

Procedure ReadNWriteByFSS (var openedFile: MyFile; spec: FSSpec);
begin
	with openedFile do begin
		errore := FSpOpenDF (spec, fsRdWrPerm, refNum);
		FSS := spec;
		mark := 0;
		resFork := 0
		end
end;

Procedure ReadNWriteRByFSS (var openedFile: MyFile; spec: FSSpec);
begin
	ReadNWriteByFSS (openedFile, spec);
	with openedFile do
		IF errore = noErr THEN BEGIN
			resFork := FSpOpenResFile (FSS, fsCurPerm);
			errore := ResError;
			if errore = eofErr THEN BEGIN
				{ There is no resource fork! Let's make one. }
				HCreateResFile (FSS.vRefNum, FSS.parID, FSS.name);
				errore := ResError;
				END; { if eof }
			end; { if noErr }
END;

Procedure ReadNWrite (var openedFile: MyFile; pathname: String);
begin
	{ Crea un FSSpec per il nostro file }
	with openedFile do begin
		errore := FSMakeFSSpec (0, 0, pathname, FSS);
		if errore = noErr then
			ReadNWriteByFSS (openedFile, FSS)
		end
end;

Function DeleteFile (pathname: string): OSErr;
var
	err: OSErr;
	FSS: FSSpec;
begin
	err := FSMakeFSSpec (0, 0, pathname, FSS);
	if err = noErr then
		err := FSpDelete (FSS);
	DeleteFile := err
end;

Function RenameFile (pathname, newname: string): OSErr;
var
	err: OSErr;
	FSS: FSSpec;
begin
	err := FSMakeFSSpec (0, 0, pathname, FSS);
	if err = noErr then
		err := FSpRename (FSS, newname);
	RenameFile := err
end;

Procedure MoveMark (var theFile: MyFile; moveHow: integer;
	offset: longint);
begin
	with theFile do begin
		errore := SetFPos (refNum, moveHow, offset);
		if errore = noErr then
			errore := GetFPos (refNum, mark)
		end { with }
end;

Procedure ReadLn (var theFile: MyFile; var s: string);
VAR
	count: longint;
begin
	{ Leggi il length byte }
	count := 1;
	PtrRead (theFile, count, @s[0]);
	IF theFile.errore = noErr THEN BEGIN
		{ Leggi i caratteri della stringa }
		count := ord(s[0]);
		PtrRead (theFile, count, @s[1]);
		END;
end;

Procedure WriteLn (var theFile: MyFile; s: string);
VAR
	count: longint;
begin
	count := length (s)+1;
	PtrWrite (theFile, count, @s)
end;

Procedure WriteRes (var theFile: MyFile; theId: integer; theType: ResType;
	theName: Str255; theData: Handle);
VAR
	tempHandle: Handle;
	oldCurrentResFile: Longint;
begin
	oldCurrentResFile := CurResFile;
	with theFile do begin
		{ OK, inizia la manipolazione }
		{ C' giˆ una risorsa di questo tipo e con questo ID nel mio file? }
		IF resFork <> 0 THEN BEGIN
			{ Cambio la disposizione dei file del search path del resource manager.
			Questo mi assicura che la risorsa sarˆ aggiunta al mio file, e non a un altro
			file il cui ramo risorse  stato aperto in seguito. Mi assicura anche che
			Ñ dato che devo garantire la rimozione di una eventuale altra risorsa analoga Ñ
			io non vada a rimuovere una risorsa analoga in un altro file. }
			UseResFile (resFork); { Questo mi preserva il side effect citato nella documentazione }
			SetResLoad (FALSE);
			{ Load essential data only from disk }
			tempHandle := Get1Resource (theType, theId);
			{ Tell resource manager that we are finished doodling }
			SetResLoad (TRUE);
			{ Is there such a resource? }
			IF tempHandle <> NIL THEN BEGIN
				RemoveResource(tempHandle);
				DisposeHandle (tempHandle)
				END
			END;
		AddResource (theData, theType, theID, theName);
		errore := ResError;
		if errore = noErr then begin
			UpdateResFile (resFork);
			errore := resError
			end
		end; { with }
	UseResFile (oldCurrentResFile);
end;

Procedure ReadLongint (var f: MyFile; var i: longint);
var
	count: longint;
begin
	count := SizeOf (Longint);
	PtrRead (f, count, @i)
end;

Procedure ReadInt (var f: MyFile; var i: integer);
var
	count: longint;
begin
	count := SizeOf (Integer);
	PtrRead (f, count, @i)
end;

Procedure WriteInt (var f: MyFile; i: Integer);
var
	count: longint;
begin
	count := SizeOf (Integer);
	PtrWrite (f, count, @i)
end;

Procedure ReadByte (var f: MyFile; var i: Byte);
var
	count: longint;
begin
	count := 1;
	PtrRead (f, count, @i)
end;

Procedure WriteByte (var f: MyFile; i: Byte);
var
	count: longint;
begin
	count := 1;
	PtrWrite (f, count, @i)
end;

Procedure WriteLongInt (var f: MyFile; i: longint);
var
	count: longint;
begin
	count := SizeOf (longint);
	PtrWrite (f, count, @i)
end;

Procedure PtrRead (var theFile: MyFile; var count: longint; p: ptr);
begin
	with theFile do begin
		errore := FSRead (theFile.refNum, count, p);
		mark := mark + count
		end { withÊ}
end;

Procedure PtrWrite (var theFile: MyFile; var count: longint; p: ptr);
begin
	with theFile do begin
		errore := FSWrite (theFile.refNum, count, p);
		mark := mark + count
		end { withÊ}
end;

Procedure HandleRead (var theFile: MyFile; var count: longint; h: handle);
begin
	with theFile do begin
		errore := FSRead (theFile.refNum, count, h^);
		mark := mark + count
		end { withÊ}
end;

Procedure HandleWrite (var theFile: MyFile; var count: longint; h: handle);
begin
	with theFile do begin
		errore := FSWrite (theFile.refNum, count, h^);
		mark := mark + count
		end { withÊ}
end;

Function FileLength (var theFile: MyFile): longint;
begin
	with theFile do
		errore := GetEOF (refNum, FileLength);
end;

Function Eof (var theFile: MyFile): boolean;
begin
	if theFile.Mark < FileLength (theFile) then
		Eof := false
	else
		Eof := true
end;

Procedure Close (var theFile: MyFile);
begin
	with theFile do begin
		if refNum <> 0 then
			errore := FSClose (refNum);
		if resFork <> 0 then begin
			CloseResFile (resFork);
			errore := ResError;
			resFork := 0
			end;
		if errore = noErr then begin
			errore := FlushVol (nil, FSS.vRefNum);
			refNum := 0
			end;
		end
end;

{$IFC POWERPC}
Function Itos (i: longint): string;
var
	s: str255;
BEGIN
	NumToString (i, s);
	Itos := s
end;
{$ENDC}

Function Stoi (s: string): longint;
var
	l: longint;
begin
	StringToNum (s, l);
	Stoi := l
end;

	VAR
		gDefaultDecimalSeparator: Char;
		gDefaultThousandsSeparator: Char;


	PROCEDURE InitializeDefaultNumberSeparators;

		VAR
			theItl0Handle: Handle;

	BEGIN
		theItl0Handle := GetResource('itl0', GetScriptVariable(smSystemScript, smScriptNumber));
		IF theItl0Handle = NIL THEN BEGIN
			gDefaultDecimalSeparator := chr (0);
			gDefaultThousandsSeparator := chr (0)
			END
		ELSE WITH Intl0Hndl(theItl0Handle)^^ DO BEGIN
			gDefaultDecimalSeparator := decimalPt;
			gDefaultThousandsSeparator := thousSep;
		END;
	END;


	PROCEDURE LocalizeNumberString (VAR theString: Str255);

		VAR
			boundary: Integer;
			separatorString: STRING[1];
			minusOffset: Integer;

	BEGIN
		separatorString := ',';
		separatorString[1] := gDefaultThousandsSeparator;

		boundary := Pos('.', theString);
		IF boundary <> 0 THEN
			theString[boundary] := gDefaultDecimalSeparator
		ELSE
			boundary := Length(theString) + 1;

		IF gDefaultThousandsSeparator <> Char(0) THEN BEGIN
				IF theString[1] = '-' THEN
					minusOffset := 1
				ELSE
					minusOffset := 0;
				WHILE boundary > 4 + minusOffset DO BEGIN
						theString := Concat(Copy(theString, 1, boundary - 4), separatorString, Copy(theString, boundary - 3, Length(theString) - boundary + 4));
						boundary := boundary - 3;
					END;
			END;
	END;


	FUNCTION IntegerToLocalString (theNumber: LongInt): Str255;
	VAR
		theString: Str255;
	BEGIN
		NumToString(theNumber, theString);
		LocalizeNumberString(theString);
		IntegerToLocalString := theString
	END;

	PROCEDURE UnlocalizeNumberString (VAR theString: Str255; allowDecimal: Boolean);

		VAR
			delta: Integer;
			i: Integer;
			theChar: Char;

	BEGIN
		delta := 0;
		FOR i := 1 TO Length(theString) DO BEGIN
				theChar := theString[i];
				IF (theChar >= '0') & (theChar <= '9') THEN
					theString[i - delta] := theChar
				ELSE IF (theChar = '-') & (i = 1) THEN
					theString[i - delta] := theChar
				ELSE IF theChar = gDefaultThousandsSeparator THEN
					delta := delta + 1
				ELSE IF theChar = gDefaultDecimalSeparator THEN BEGIN
						IF allowDecimal THEN BEGIN
								allowDecimal := FALSE; { one is enough }
								theString[i - delta] := '.';
							END
					END
			END;
		theString[0] := Char(Length(theString) - delta);
	END;


	FUNCTION LocalStringToInteger (theString: Str255): LongInt;
	BEGIN
		UnlocalizeNumberString(theString, FALSE);
		LocalStringToInteger := SToI (theString)
	END;

end.