{                 Unidade de Memoria                          }
   {                  Versao      0.01                           }
   {-------------------------------------------------------------}
   { Contem:manipulacao de lista de pointer }
   {        manipulacao de lista de string  }
   {        manipulacao de variavel PChar   }
   {        gerador de lista com diretorio  }
   {        E/S de disco                    }
   {        atribuicao de pointer           }
   {        existencia de arquivo           }
{ Under GNU License            }
{ JOAO PAULO SCHWARZ SCHULER }
{ http://www.schulers.com      }
{ Turbo Pascal Source          }
{ Free Pascal Source for DOS   }
{ Free Pascal Source for Linux }


                     unit UMEM;


                      INTERFACE
    uses crt,
       strings
       ,dos

      ;

function NEW_UTILPOINTER:pointer;
{ aloca tabela de ponteiros realmente uteis }

function PCHARLEN(PC:PChar):word;
{ devolve o tamanho de uma string apontada por PCHAR }

function GETPCHAR(TX:string):PChar;
{ Cria uma PCHAR com o counteudo passado como parametro em TX do tipo string }

function GETSTRING(PC:PChar):string;
{ devolve uma string do tipo STRING armazenada como PCHAR }

procedure PCHARDISPOSE(PC:PCHAR);
{ devolve o numero de caracteres da string apontada por PChar }

function ASPOINTER(PT:pointer):pointer;
{ recebe pointer tipado e devolve pointer nao tipado }

function FileExists(FileName: String): Boolean;  { RETIRADO DO TURBO HELP }
{ Boolean function that returns True if the file exists;otherwise,
 it returns False. Closes the file if it exists. }

procedure APAGATELA;
{ apaga toda tela }

function IFW(EXP : boolean;O1,O2 : word):word;
{se a expressao EXP for verdadeira, devolve Operando 1; senao, Operando 2}


   {----------- Objeto de lista de pointers ------------------}
   { permite uma lista com 65534 pointers !!!                 }
   { BASE : tabela de 256 ponteiros que apontam para tabelas com    }
   {        capacidade cada uma de outros 256 ponteiros, note que   }
   {        estas ultimas sao alocadas de acordo com a necessidade. }

type UTILPOINTER = record                { tabela de pointers }
                      PT:array [0..255] of pointer;   { ponteiros }
                      NUM:byte;                       { numero de ponteiros }
                   end;

type UTILPOINTERPTR = ^UTILPOINTER;      { pointer para tabela de pointers }

type LISTA_POINTER = object
                      BASE : array [0..255] of UTILPOINTERPTR;
      { BASE: tabela que aponta para tabelas de pointers uteis }
                      NUMP : word;
      { NUMP: numero de pointers na lista                      }

                      constructor INIT;
                      procedure INSERT(P:pointer);
                      { insere ponteiro P na lista }

                      procedure PUT(NUM:word;P:pointer);
                      { deposita pointer P na posicao NUM }

                      procedure KILL(NUM:word);
                      { deleta o iten NUM da lista }

                      procedure KILLALL;
                      { deleta todos os itens }

                      function GET(NUM:word):pointer;
                      { pega um ponteiro de indice NUM }

                      function GETNUM:word;
                      { retorna numero de elementos da lista }

                      destructor DONE;
                   { desaloca todas as tabelas de ponteiros realmente uteis }
                     end;


type STRINGPTR = ^string;

type LISTA_STRING = object(LISTA_POINTER)


                      procedure INSERTSTR(S:string);
                      { insere string }

                      function GETSTR(NUM:word):string;
                      { devolve string de indice NUM }

                      procedure DESALOCA;
                      { desaloca strings }
                    end;


{-------------------- IO de disco ---------------------------------------}
type IODiskBuffer = record
                      Buf : array[0..2047] of byte;{buffer propriamente dito}
                      NUM : word; {numero de bytes no buffer }
                      Modified : boolean;{ se o buffer foi modificado}
                      TAB : longint; { numero da tabela (pagina) }
                    end;

type IODISK = object
                F:file ;
                NOME:string;          { nome do arquivo   }
                BUFIN:IODiskBuffer;   { buffer de leitura }
                BUFOUT:IODiskBuffer;  { buffer de escrita }

                constructor Init(PNOME:string);
                { abre o arquivo }

                function Read(POS:longint):byte;
                { le um byte da posicao POS }

                procedure Write(POS:longint;INF:byte);
                { escreve um byte INF na posicao POS }

                function TAMANHO:longint;
                { devolve o tamanho do arquivo }

                procedure HARD;
                { gravacao fisica do buffer de saida }

                procedure RELOAD;
                { le os buffers novamente do disco }

                destructor Done;
                { fecha arquivo }
              end;

procedure MakeDirList(var DIR:LISTA_POINTER);
{ cria lista contendo diretorio }

procedure DisposeListPChar(var LIS:LISTA_POINTER);
{ Desaloca lista de PChars }

   procedure StrSet(var P : pchar; const S : string );
   { Seta uma uma nova string a um pchar }

    function strpnew(const s : string) : pchar;

    function MyStrPas(P:pchar):string;

                    IMPLEMENTATION

{-----------------------------NOVIDADES---------------------------}
    function strpnew(const s : string) : pchar;
      var
         p : pchar;
      begin
         getmem(p,length(s)+1);
         strpcopy(p,s);
         strpnew:=p;
      end;

   procedure StrSet(var P : pchar; const S : string );
   { Seta uma uma nova string a um pchar }
   begin
   if Assigned(P)
      then StrDispose(P);
   P:=StrPNew(S);
   end;

   function MyStrPas(P:pchar):string;
   begin
   if P<>nil
      then MyStrPas:=StrPas(P)
      else MyStrPas:='';
   end;

{--------------FIM DAS NOVIDADES----------------------------------}

function NEW_UTILPOINTER:pointer;
{ aloca tabela de ponteiros realmente uteis }
{ todos os pointers da nova tabela recebem nil }
var I:integer;
    UP:UTILPOINTERPTR;
begin
new(UP);
for I:=0 to 255 do UP^.PT[I]:=nil;
UP^.NUM:=0;
NEW_UTILPOINTER:=UP;
end;

constructor LISTA_POINTER.INIT;
{ Ponteiros de indice de arrays de ponteiros recebem NIL }
var I:integer;
begin
for I:=0 to 255 do BASE[I]:=nil;
NUMP:=0;
end;


procedure LISTA_POINTER.INSERT(P:pointer);
{ insere ponteiro P na lista }
var TABELA,POSICAO:byte;
    UP:UTILPOINTERPTR;
begin
inc(NUMP);
TABELA:=NUMP shr 8;           { pointer que aponta para tabela de pointers }
POSICAO:=NUMP and 255;        { posicao do pointer util }
if BASE[TABELA]=NIL           { tabela de pointers nao alocada ? }
   then begin
        BASE[TABELA]:=NEW_UTILPOINTER;   { aloca tabela }
        end;

UP:=BASE[TABELA];
if UP^.PT[POSICAO]=NIL
   then begin
        UP^.PT[POSICAO]:=P;         { Insere pointer }
        inc(UP^.NUM);
        end
   else begin
        UP^.PT[POSICAO]:=P;
        end;
end;

procedure LISTA_POINTER.PUT(NUM:word;P:pointer);
{ deposita pointer P na posicao NUM }
var TABELA,POSICAO:byte;
    UP:UTILPOINTERPTR;
begin
if NUM>NUMP then
   begin
   write('ERRO em PUT/LISTA_POINTER');
   halt;
   end
 else
   begin
   TABELA:=NUM shr 8;           { pointer que aponta para tabela de pointers }
   POSICAO:=NUM and 255;        { posicao do pointer util }
   UP:=BASE[TABELA];
   UP^.PT[POSICAO]:=P;
   end;
end;

function LISTA_POINTER.GETNUM:word;
{ retorna numero de elementos da lista }
begin
GETNUM:=NUMP;
end;

function LISTA_POINTER.GET(NUM:word):pointer;
{ pega um ponteiro de indice NUM }
var TABELA,POSICAO:byte;
    UP:UTILPOINTERPTR;
    RESULT:pointer;
begin
TABELA:=NUM shr 8;                { calcula posicao }
POSICAO:=NUM and 255;
if BASE[TABELA]=NIL               { tabela secundaria nao existe ? }
   then begin
        RESULT:=NIL;
        end
   else begin
        RESULT:=BASE[TABELA]^.PT[POSICAO];  { devolve conteudo }
        end;
GET:=RESULT;
end;

procedure LISTA_POINTER.KILL(NUM:word);
{ deleta o iten NUM da lista }
var COUNT:word;
    TABELA,POSICAO:byte;
    UP:UTILPOINTERPTR;

begin
for COUNT:=NUM to NUMP do     { shift na lista }
    PUT(COUNT,GET(succ(COUNT)));
TABELA:=NUMP shr 8;           { pointer que aponta para tabela de pointers }
POSICAO:=NUMP and 255;        { posicao do pointer util }
UP:=BASE[TABELA];
dec(UP^.NUM);
if UP^.NUM=0 then
   begin
   dispose(UP);
   BASE[TABELA]:=nil;        { desaloca tabela sem pointers }
   end;
dec(NUMP); { decrementa numero de pointers }
end;

procedure LISTA_POINTER.KILLALL;
{ deleta todos os itens }
var I:integer;
begin
NUMP:=0;
for I:=0 to 255 do
    begin
    if BASE[I]<>nil then
       begin
       DISPOSE(BASE[I]);
       BASE[I]:=nil;
       end;{ of if }
    end; { of for }
end; { of procedure }

destructor LISTA_POINTER.DONE;
{ desaloca todas as tabelas de ponteiros realmente uteis }
var I:integer;
begin
for I:=0 to 255 do
    begin
    if BASE[I]<>nil then
       DISPOSE(BASE[I]);
    end;
end;

procedure LISTA_STRING.INSERTSTR(S:string);
{ insere string }
var SPTR:STRINGPTR;
begin
new(SPTR);
SPTR^:=S;
INSERT(SPTR);
end;

function LISTA_STRING.GETSTR(NUM:word):string;
{ devolve string de indice NUM }
var SPTR:STRINGPTR;
begin
SPTR:=GET(NUM);
GETSTR:=SPTR^;
end;

procedure LISTA_STRING.DESALOCA;
{ desaloca strings }
var SPTR:STRINGPTR;
    W:word;
begin
for W:=1 to NUMP do
    begin
    SPTR:=GET(W);
    dispose(SPTR);
    end;
end;

{ ----------  Rotinas para permitir uso das variaveis PChar ----------------}
{---------------------------------------------------------------------------}
{ As funcoes e procedimentos, apesar de serem de uso absolutamente generico,}
{ forma desenvolvidas durante o Projeto de Editor de texto, ja que nao e    }
{ permitido o uso da Turbo Vision e qualquer biblioteca                     }

function PCHARLEN(PC:PChar):word;
{ devolve o tamanho de uma string apontada por PCHAR }
var COUNT:word;
begin
COUNT:=1;
while ord(PC[pred(count)]) <> 0 do
      inc(COUNT);
PCHARLEN := pred(COUNT);
end;

function GETPCHAR(TX:string):PChar;
{ Cria uma PCHAR com o counteudo passado como parametro em TX do tipo string }
var COUNT:word;
    PC:PChar;
begin
GetMem(PC,succ(ord(TX[0])));
for COUNT:=1 to ord(TX[0]) do
    PC[pred(COUNT)] := TX[COUNT];
PC[ord(TX[0])]:=chr(0);
GETPCHAR := PC;
end;

function GETSTRING(PC:PChar):string;
{ devolve uma string do tipo STRING armazenada como PCHAR }
var COUNT:word;
    TX:string;
begin
tx:='';
COUNT:=1;
while ( PC[pred(COUNT)] <> chr(0) ) and (COUNT<256) do
      begin
      TX[COUNT]:=PC[pred(COUNT)];
      inc(COUNT);
      end;
TX[0]:=chr(pred(COUNT));
GETSTRING:=TX;
end;

procedure PCHARDISPOSE(PC:PCHAR);
{ devolve o numero de caracteres da string apontada por PChar }
begin
if PC<>nil then
   FreeMem(PC,succ(PCHARLEN(PC)));
end;

procedure MakeDirList(var DIR:LISTA_POINTER);
{ cria lista contendo diretorio }
var
 DirInfo: SearchRec;
begin
 FindFirst('*.*', Archive, DirInfo);
while DosError = 0 do
 begin
   DIR.INSERT(GetPChar(DirInfo.Name));
   FindNext(DirInfo);
 end;
end;

procedure DisposeListPChar(var LIS:LISTA_POINTER);
{ Desaloca lista de PChars }
var COUNT:word;
    MAX:word;
begin
MAX:=LIS.GETNUM;
for COUNT:=1 to MAX do
    PCHARDISPOSE(LIS.GET(COUNT));
end;

function ASPOINTER(PT:pointer):pointer;
{ recebe pointer tipado e devolve pointer nao tipado }
begin
ASPOINTER:=PT;
end;

function FileExists(FileName: String): Boolean;  { RETIREDO DO TURBO HELP }
{ Boolean function that returns True if the file exists;otherwise,
 it returns False. Closes the file if it exists. }
var
 F: file;
begin
 {$I-}
 Assign(F, FileName);
 Reset(F);
 Close(F);
 {$I+}
 FileExists := (IOResult = 0) and (FileName <> '');
end;  { FileExists }


{ -------- Objeto de Entrada e saida de disco ------------------- }

constructor IODISK.Init(PNOME:string);
{ abre o arquivo }
begin
NOME:=PNOME;
assign(F,NOME);
if FileExists(NOME)
   then reset(F,1)
   else rewrite(F,1);
seek(F,0);

{ prepara buffer de entrada }
BUFIN.TAB:=0;
BUFIN.MODIFIED:=false;
blockread(F,BUFIN.BUF,2048,BUFIN.NUM);

{prepara arquivo de saida }
seek(F,0);
BUFOUT.TAB:=0;
BUFOUT.MODIFIED:=false;
blockread(F,BUFOUT.BUF,2048,BUFOUT.NUM);
end;

function IODISK.Read(POS:longint):byte;
{ le um byte da posicao POS }
var TAB:longint;    { tabela para alocar }
    POSONTAB:word;  { posicao na tabela  }
    RESULT:byte;
begin
TAB:=POS shr 11;
POSONTAB:= POS and 2047;
if BUFOUT.TAB=TAB then        { procura na tabela de escrita }
   begin
   RESULT:=BUFOUT.BUF[POSONTAB];
   end
 else
   begin
   if BUFIN.TAB=TAB then      { procaura na tabela de leitura }
      begin
      RESULT:=BUFIN.BUF[POSONTAB];
      end
    else
      begin                        { le outra tabela }
      seek(F,TAB shl 11);
      BUFIN.TAB:=TAB;
      BUFIN.MODIFIED:=false;
      blockread(F,BUFIN.BUF,2048,BUFIN.NUM);
      RESULT:=BUFIN.BUF[POSONTAB];
      end;
   end;
READ:=result;
end; { of function }


procedure IODISK.Write(POS:longint;INF:byte);
{ escreve um byte INF na posicao POS }
var TAB:longint;    { tabela para alocar }
    POSONTAB:word;  { posicao na tabela  }
begin
TAB:=POS shr 11;
POSONTAB:= POS and 2047;
if BUFIN.TAB=TAB then
   begin
   BUFIN.BUF[POSONTAB]:=INF;    { grava informacao no buffer de leitura }
   end;

if BUFOUT.TAB=TAB then
   begin
   BUFOUT.BUF[POSONTAB]:=INF;
   BUFOUT.MODIFIED:=true;
   end
 else
   begin
   if BUFOUT.MODIFIED then
      begin
      seek(F,BUFOUT.TAB shl 11);           { grava buffer antigo }
      blockwrite(F,BUFOUT.BUF,BUFOUT.NUM);
      BUFOUT.MODIFIED:=false;
      end;

   seek(F,TAB shl 11);
   BUFOUT.TAB:=TAB;
   blockread(F,BUFOUT.BUF,2048,BUFOUT.NUM);
   BUFOUT.BUF[POSONTAB]:=INF;
   BUFOUT.MODIFIED:=true;
   end;

if BUFOUT.NUM<succ(POSONTAB)
   then BUFOUT.NUM:=succ(POSONTAB); {GARANTE GRAVACAO DENTRO DO BUFFER}
end; { of procedure }

function IODISK.TAMANHO:longint;
{ devolve o tamanho do arquivo }
begin
TAMANHO:=filesize(F);
end;

procedure IODISK.HARD;
{ gravacao fisica do buffer de saida }
begin
if BUFOUT.MODIFIED then
   begin
   seek(F,BUFOUT.TAB shl 11);           { grava buffer antigo }
   blockwrite(F,BUFOUT.BUF,BUFOUT.NUM);
   BUFOUT.MODIFIED:=false;
   end;
end;

procedure IODISK.RELOAD;
{ le os buffers novamente do disco }
begin
{ prepara buffer de entrada }
BUFIN.MODIFIED:=false;
seek(F,BUFIN.TAB shl 11);
blockread(F,BUFIN.BUF,2048,BUFIN.NUM);

{prepara arquivo de saida }
seek(F,BUFOUT.TAB shl 11);
BUFOUT.MODIFIED:=false;
blockread(F,BUFOUT.BUF,2048,BUFOUT.NUM);
end;

destructor IODISK.Done;
{ fecha arquivo }
begin
HARD;
close(F);
end;

procedure APAGATELA;
{ apaga toda tela }
begin
textbackground(black);
window(1,1,80,25);
clrscr;
end;

function IFW(EXP : boolean;O1,O2 : word):word;
{se a expressao EXP for verdadeira devolve Operando 1 senao Operando 2}
begin
if EXP then IFW := O1
       else IFW := O2;
end;



end.