unit Ficheros;

(*

Asignatura: Ficheros y Base de Datos
Curso: 2005-06
1er cuatrimetre

Práctica 1 - Ficheros

(c) 2005 Juan I. Perea - jiperea@inf.uc3m.es

Este módulo es para soporte de la práctica 1 (Ficheros).
No puede ser modificado por los alumnos bajo ningún concepto.
Es posible que se suministren pequeñas modificaciones durante el desarrollo de
la práctica.

Histórico de versiones
01.00 | 30-09-2005 | Versión inicial
01.01 | 03-10-2005 | Modificaciones reunión de profesores
01.02 | 14-10-2005 | Separación OO / no OO

*)

// ***************************************************************************

interface

  uses SysUtils;

// ***************************************************************************
// *** TamanoBloque ***
// Valor por defecto para el tamaño del bloque.

const TamanoBloque = 1024;

// ***************************************************************************
// *** TBloque ***
// Estructura formada por 'TamanoBloque' bytes que se lee y escribe en un
// fichero.
//   - Mostrar: Muestra en consola el contenido del bloque.
//   - RellenarCero: Pone a 0 todos los bytes del bloque.
//   - RellenarRandom: Rellena el bloque con valores aleatorios.

type TBloque = object
public
  data : array[0..TamanoBloque-1] of byte;
public
  procedure Mostrar ( );
  procedure RellenarCero ( );
  procedure RellenarRandom ( );
end;

function Bloque_GetByte ( var bloque : TBloque; i : Integer ) : Byte;
procedure Bloque_SetByte ( var bloque : TBloque; i : Integer; valor : Byte );
procedure Bloque_Mostrar ( var bloque : TBloque );
procedure Bloque_RellenarCero ( var bloque : TBloque );
procedure Bloque_RellenarRandom ( var bloque : TBloque );

// ***************************************************************************
// *** TFichero ***
// Clase abstracta para soporte de los demás tipos de ficheros.
// No podrá ser usada directamente.
// Encapsula la funcionalidad de ficheros de Delphi.
// Tiene funcionalidades añadidas a la de Delphi (p.ej. estadísticas).
// Las demás clases expondrán sólo cierto métodos disponible en esta clase,
// proporcionando funcionalidades reducidas que ilustren cada tipo de fichero.
// Las funciones de lectura de bloque exigen que el bloque exista.
// Las funciones de escritura extienden el tamaño del fichero si es necesario.
// Sus miembros y métodos no están visibles, a excepción de:
//   - MostrarEstadisticas: Muestra en consola la estadísticas del fichero.

type TFichero = object
protected
 // m_file : File of TBloque;
  m_file : File;
  m_error : LongInt;
  m_contDesplazar : LongInt;
  m_contLeer : LongInt;
  m_contEscribir : LongInt;
  m_contError : LongInt;
protected
  procedure Abrir ( nombre : String );
  procedure Cerrar ( );
private
  procedure TratarIOResult ( );
  procedure TratarInOutError ( func : String; e : EInOutError );
protected
  procedure IrAPosicion ( posicion : LongInt );
  function PosicionActual ( ) : LongInt;
  function FinDeFichero ( ) : Boolean;
  function NumeroDeBloques ( ) : LongInt;
  procedure LeerBloque ( var bloque : TBloque );
  procedure EscribirBloque ( const bloque : TBloque );
public
  procedure MostrarEstadisticas ( );
end;

// ***************************************************************************
// *** TFicheroSerial ***
// Clase que implementa la funcionalidad reducida de un fichero serial.
//   - Abrir: Abre el fichero en modo lectura-escritura.
//   - Cerrar: Cierra el fichero.
//   - IrAPosicionInicial: Mueve el puntero del fichero al comienzo (reset).
//   - LeerBloque: Lee el bloque situado en el puntero.
//   - EscribirBloque: Escribe un bloque sobre la posición del puntero.
// Además, hereda de TFichero:
//   - MostrarEstadisticas: Muestra en consola la estadísticas del fichero.

type TFicheroSerial= object (TFichero)
public
  procedure Abrir ( nombre : String );
  procedure Cerrar ( );
public
  procedure IrAPosicionInicial ( );
  procedure LeerBloque ( var bloque : TBloque );
  procedure EscribirBloque ( const bloque : TBloque );
end;

procedure FicheroSerial_Abrir ( var fichero : TFicheroSerial; nombre : String );
procedure FicheroSerial_Cerrar ( var fichero : TFicheroSerial );
procedure FicheroSerial_IrAPosicionInicial ( var fichero : TFicheroSerial );
procedure FicheroSerial_LeerBloque ( var fichero : TFicheroSerial; var bloque : TBloque );
procedure FicheroSerial_EscribirBloque ( var fichero : TFicheroSerial; const bloque : TBloque );
procedure FicheroSerial_MostrarEstadisticas ( var fichero : TFicheroSerial );

// ***************************************************************************
// *** TFicheroDireccionado ***
// Clase que implementa la funcionalidad reducida de un fichero direccionado.
//   - Abrir: Abre el fichero en modo lectura-escritura.
//   - Cerrar: Cierra el fichero.
//   - LeerBloque: Lee el bloque situado en una posición dada.
//   - EscribirBloque: Escribe el bloque obre una posición dada.
// Además, hereda de TFichero:
//   - MostrarEstadisticas: Muestra en consola la estadísticas del fichero.

type TFicheroDireccionado = object (TFichero)
public
  procedure Abrir ( nombre : String );
  procedure Cerrar ( );
public
  procedure LeerBloque ( posicion : LongInt; var bloque : TBloque );
  procedure EscribirBloque ( posicion : LongInt; const bloque : TBloque );
end;

procedure FicheroDireccionado_Abrir ( var fichero : TFicheroDireccionado; nombre : String );
procedure FicheroDireccionado_Cerrar ( var fichero : TFicheroDireccionado );
procedure FicheroDireccionado_LeerBloque ( var fichero : TFicheroDireccionado;
                                           posicion : LongInt; var bloque : TBloque );
procedure FicheroDireccionado_EscribirBloque ( var fichero : TFicheroDireccionado;
                                               posicion : LongInt; const bloque : TBloque );
procedure FicheroDireccionado_MostrarEstadisticas ( var fichero : TFicheroDireccionado );

// ***************************************************************************
// *** PropagarExcepciones ***

// Por defecto, no se propagan excepciones.
// Aquellos grupos que deseen recibir la excepciones en su código podrán poner
// esta variable a True.
// Esto debe hacerse asignándola desde el programa, nunca modificando aquí.

const PropagarExcepciones : Boolean = False;

// ***************************************************************************
// Funciones para soporte de este módulo.

function Hex ( n : LongInt; nc : Integer=0 ) : String;
function DescripcionIOResult ( error : Integer ) : String;
function DescripcionFileMode ( mode : Word ) : String;

// ***************************************************************************

implementation

{$IOCHECKS OFF} // Tratamiento con función IOResult
// *NO* {$IOCHECKS ON} // Tratamiento con excepciones EInOutError

// ***************************************************************************
// *** TBloque ***

procedure TBloque.Mostrar ( );
  var i, j : Integer;
  var b : Byte;
begin
  for i:=0 to (TamanoBloque div 16)-1 do begin
    Write(Hex(i*16,4),' ');
    Write('| ');
    for j:=0 to 16 do begin
      b:=data[i*16+j];
      Write(Hex(b,2),' ');
    end;
    Write('| ');
    for j:=0 to 16 do begin
      b:=data[i*16+j];
      if b>=Ord(' ')
        then Write(Chr(b))
        else Write(' ');
    end;
    WriteLn;
  end;
end;

procedure TBloque.RellenarCero ( );
  var i : LongInt;
begin
  for i:=0 to TamanoBloque-1 do begin
    data[i]:=0;
  end;
end;

procedure TBloque.RellenarRandom ( );
  var i : LongInt;
begin
  for i:=0 to TamanoBloque-1 do begin
    data[i]:=Random(256);
  end;
end;

function Bloque_GetByte ( var bloque : TBloque; i : Integer ) : Byte;
begin
  Result:=bloque.data[i];
end;

procedure Bloque_SetByte ( var bloque : TBloque; i : Integer; valor : Byte );
begin
  bloque.data[i]:=valor;
end;

procedure Bloque_Mostrar ( var bloque : TBloque );
begin
  bloque.Mostrar;
end;

procedure Bloque_RellenarCero ( var bloque : TBloque );
begin
  bloque.RellenarCero;
end;

procedure Bloque_RellenarRandom ( var bloque : TBloque );
begin
  bloque.RellenarRandom;
end;

// ***************************************************************************
// *** TFichero ***

procedure TFichero.Abrir ( nombre : String );
begin
  m_error:=0;
  m_contDesplazar:=0;
  m_contLeer:=0;
  m_contEscribir:=0;
  m_contError:=0;
  try
   // FileMode:=fmCreate+fmShareCompat;
    FileMode:=fmOpenReadWrite; // +fmShareCompat;
    AssignFile(m_file,nombre);
    if FileExists(nombre)
      then Reset(m_file,TamanoBloque)
      else Rewrite(m_file,TamanoBloque);
    TratarIOResult();
  except
    on e : EInOutError do begin
      TratarInOutError('Abrir',e);
      raise;
    end;
  end;
end;

procedure TFichero.Cerrar ( );
begin
  try
    CloseFile(m_file);
    TratarIOResult();
  except
    on e : EInOutError do begin
      TratarInOutError('Cerrar',e);
      raise;
    end;
  end;
end;

//procedure TFichero.TratarIOResult ( );
//  var e : EInOutError;
//      error : Integer;
//begin
//  error:=IOResult();
//  if error<>0 then begin
//    e:=EInOutError.Create(DescripcionIOResult(error));
//    e.ErrorCode:=error;
//    raise e;
//  end;
//end;

procedure TFichero.TratarIOResult ( );
begin
  m_error:=IOResult();
end;

procedure TFichero.TratarInOutError ( func : String; e : EInOutError );
begin
  m_error:=e.ErrorCode;
 // if m_error<>0 then begin
    Inc(m_contError);
    WriteLn;
    WriteLn('*****************************************************************************');
    WriteLn('  Error en ',func,': Error=',m_error,' ',DescripcionIOResult(m_error));
    WriteLn('*****************************************************************************');
 // end;
end;

procedure TFichero.IrAPosicion ( posicion : LongInt );
  var posicionAnterior : LongInt;
begin
  try
    posicionAnterior:=PosicionActual();
    Seek(m_file,posicion);
    TratarIOResult();
    Inc(m_contDesplazar,Abs(posicionAnterior-posicion));
  except
    on e : EInOutError do begin
      TratarInOutError('IrAPosicion',e);
      raise;
    end;
  end;
end;

function TFichero.PosicionActual ( ) : LongInt;
begin
  try
    Result:=FilePos(m_file);
    TratarIOResult();
  except
    on e : EInOutError do begin
      TratarInOutError('PosicionActual',e);
      raise;
    end;
  end;
end;

function TFichero.FinDeFichero ( ) : Boolean;
begin
  try
    Result:=Eof(m_file);
    TratarIOResult();
  except
    on e : EInOutError do begin
      TratarInOutError('FinDeFichero',e);
      raise;
    end;
  end;
end;

function TFichero.NumeroDeBloques ( ) : LongInt;
begin
  try
    Result:=FileSize(m_file);
    TratarIOResult();
  except
    on e : EInOutError do begin
      TratarInOutError('NumeroDeBloques',e);
      raise;
    end;
  end;
end;

procedure TFichero.LeerBloque ( var bloque : TBloque );
begin
  try
    BlockRead(m_file,bloque,1);
    TratarIOResult();
    Inc(m_contLeer);
  except
    on e : EInOutError do begin
      TratarInOutError('LeerBloque',e);
      raise;
    end;
  end;
end;

procedure TFichero.EscribirBloque ( const bloque : TBloque );
begin
  try
    BlockWrite(m_file,bloque,1);
    TratarIOResult();
    Inc(m_contEscribir);
  except
    on e : EInOutError do begin
      TratarInOutError('EscribirBloque',e);
      raise;
    end;
  end;
end;

procedure TFichero.MostrarEstadisticas ( );
begin
  WriteLn;
  WriteLn('*****************************************************************************');
  WriteLn(' Nombre        : ',TFileRec(m_file).Name);
  WriteLn(' Modo          : ',DescripcionFileMode(TFileRec(m_file).Mode));
  WriteLn(' N. bloques    : ',NumeroDeBloques():4);
  WriteLn('Estadisticas del fichero');
  WriteLn(' N. desplazam. : ',m_contDesplazar:4);
  WriteLn(' N. lecturas   : ',m_contLeer:4);
  WriteLn(' N. escrituras : ',m_contEscribir:4);
  WriteLn(' N. errores    : ',m_contError:4);
  WriteLn('*****************************************************************************');
  WriteLn;
end;

// ***************************************************************************
// *** TFicheroSerial ***

procedure TFicheroSerial.Abrir ( nombre : String );
begin
  try
    inherited Abrir(nombre);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroSerial.Cerrar ( );
begin
  try
    inherited Cerrar();
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroSerial.IrAPosicionInicial ( );
begin
  try
    inherited IrAPosicion(0);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroSerial.LeerBloque ( var bloque : TBloque );
begin
  try
   // bloque.RellenarRandom();
    inherited LeerBloque(bloque);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroSerial.EscribirBloque ( const bloque : TBloque );
begin
  try
    inherited EscribirBloque(bloque);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure FicheroSerial_Abrir ( var fichero : TFicheroSerial; nombre : String );
begin
  fichero.Abrir(nombre);
end;

procedure FicheroSerial_Cerrar ( var fichero : TFicheroSerial );
begin
  fichero.Cerrar();
end;

procedure FicheroSerial_IrAPosicionInicial ( var fichero : TFicheroSerial );
begin
  fichero.IrAPosicionInicial();
end;

procedure FicheroSerial_LeerBloque ( var fichero : TFicheroSerial; var bloque : TBloque );
begin
  fichero.LeerBloque(bloque);
end;

procedure FicheroSerial_EscribirBloque ( var fichero : TFicheroSerial; const bloque : TBloque );
begin
  fichero.EscribirBloque(bloque);
end;

procedure FicheroSerial_MostrarEstadisticas ( var fichero : TFicheroSerial );
begin
end;

(*
// ***************************************************************************
// *** TFicheroSecuencial ***

procedure TFicheroSecuencial.MoverPosicion ( posicionRelativa : Longint );
begin
  try
    IrAPosicion(PosicionActual()+posicionRelativa);
  except
  end;
end;

*)

// ***************************************************************************

// ***************************************************************************
// *** TFicheroDireccionado ***

procedure TFicheroDireccionado.Abrir ( nombre : String );
begin
  try
    inherited Abrir(nombre);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroDireccionado.Cerrar ( );
begin
  try
    inherited Cerrar();
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroDireccionado.LeerBloque ( posicion : LongInt; var bloque : TBloque );
begin
  try
   // bloque.RellenarRandom();
    IrAPosicion(posicion);
    inherited LeerBloque(bloque);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure TFicheroDireccionado.EscribirBloque ( posicion : LongInt; const bloque : TBloque );
begin
  try
    IrAPosicion(posicion);
    inherited EscribirBloque(bloque);
  except
    if PropagarExcepciones then raise;
  end;
end;

procedure FicheroDireccionado_Abrir ( var fichero : TFicheroDireccionado; nombre : String );
begin
  fichero.Abrir(nombre);
end;

procedure FicheroDireccionado_Cerrar ( var fichero : TFicheroDireccionado );
begin
  fichero.Cerrar();
end;

procedure FicheroDireccionado_LeerBloque ( var fichero : TFicheroDireccionado;
                                           posicion : LongInt; var bloque : TBloque );
begin
  fichero.LeerBloque(posicion,bloque);
end;

procedure FicheroDireccionado_EscribirBloque ( var fichero : TFicheroDireccionado;
                                               posicion : LongInt; const bloque : TBloque );
begin
  fichero.EscribirBloque(posicion,bloque);
end;

procedure FicheroDireccionado_MostrarEstadisticas ( var fichero : TFicheroDireccionado );
begin
  fichero.MostrarEstadisticas();
end;

// ***************************************************************************

function Hex ( n : LongInt; nc : Integer=0 ) : String;
  var i : LongInt;
  var c : Byte;
begin
 // Result:=StringOfChar('0',nc);
  Result:='';
  i:=1;
  while (i<=nc) or (n>0) do begin
    c:=n mod 16;
    n:=n div 16;
    if c<10
      then Result:=Chr(Ord('0')+c)+Result
      else Result:=Chr(Ord('a')+c-10)+Result;
    Inc(i);
  end;
end;

function DescripcionIOResult ( error : Integer ) : String;
begin
  case error of
    100 : Result:='End of File';
    101 : Result:='Disk Full';
    102 : Result:='File variable not assigned';
    103 : Result:='File not open';
    104 : Result:='File not open for input';
    105 : Result:='File not open for output';
    106 : Result:='Error in formatted input';
    107 : Result:='File already open';
  end;
end;

function DescripcionFileMode ( mode : Word ) : String;
begin
  case mode of
    fmClosed : Result:='Cerrado';
    fmInput : Result:='Entrada';
    fmOutput : Result:='Salida';
    fmInOut : Result:='Entrada/Salida';
  end;
end;

// ***************************************************************************

end.