Struktura plików i katalogów...

0

Czy zastanawił się kiedyś ktoś z Was jak za pomocą TP7 wyświetlić strukturę katalogów/plików?
Sprawa jest prosta w Delphi - tam są odpowiednie komponenty...
Czy potrzebny jest do tego celu Assembler?

Pozdrawiam

0

Kiedys dawno temu, kiedy pascal był (prawie - widze wstawki asm) jedynym znanym mi jezykiem ... Ograniczenie widać na pierwszy rzut oka... 1024 katalogi.

{$A-,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
Unit DiscTree;

Interface

type dirtreetype=record count:integer;data:array[0..1023]of string[25] end;
function createtree:pointer;
procedure disposedirtree(var r:pointer);
function gettree(r:pointer;nr:integer):string;
procedure savetree(r:pointer;name:string);
function loadtree(name:string):pointer;
procedure changetree(r:pointer;nr:integer);

implementation

uses dos;

function createtree;
type intype=record count:integer;data:array[0..1024]of string[25] end;
var s:searchrec;
    q:string;
    d:dirstr;
    p:^intype;
    r:^dirtreetype;

  procedure writeln(s:string);
  begin
    with p^ do
      if count<1024 then
        begin
          data[count]:=copy(s,2,255);
          inc(count)
        end
  end;

  procedure inside(nr:byte);
  var dr:string[12];
  begin
    findfirst('*.*',$ff,s);
    while doserror=0 do
      with s do
        begin
          while((attr and directory=0)or(name='.')or(name='..'))and(doserror=0)do findnext(s);
          if(doserror=0)and(attr and directory<>0)then
            begin
              dr:=name;
              writeln(copy(q,1,nr*2)+#32#195#196+name);
              chdir(name);
              inside(nr+1);
              findfirst('*.*',$ff,s);
              while(doserror=0)and(name<>dr)do findnext(s)
            end;
          attr:=0
        end;
    if nr>0 then chdir('..')
  end;

  procedure oczysc;
  var i:integer;
      j:byte;
  begin
    with p^ do
      begin
        for i:=count downto 1 do
          for j:=1 to byte(data[i,0])do
            case data[i,j] of
              #195:if not(data[i+1,j] in[#179,#195,#192])then data[i,j]:=#192;
              #179:if not(data[i+1,j] in[#179,#195,#192])then data[i,j]:=#32
            end
      end
  end;

var i:integer;
begin
  new(p);
  fillchar(p^,sizeof(intype),0);
  getdir(0,d);
  chdir('');
  writeln(#32+copy(d,1,3));
  q[0]:=^@;
  repeat q:=q+#32#179 until q[0]=#255;
  inside(0);
  chdir(d);
  dec(p^.count);
  oczysc;
  with p^ do getmem(r,count*26+28);
  move(p^,r^,p^.count*26+28);
  dispose(p);
  createtree:=r
end;

procedure disposedirtree;
begin
  with dirtreetype(r^)do freemem(r,count*26+28)
end;

function gettree;
var s:string;
    i:byte;
begin
  s[0]:=^@;
  with dirtreetype(r^)do
    begin
      while nr>0 do
        begin
          i:=pos(#196,data[nr]);
          s:=copy(data[nr],i+1,255)+#92+s;
          asm dec [i] end;
          repeat dec(nr) until not(data[nr,i]in[#179,#195,#192]);
        end;
      s:=data[0]+s
    end;
  asm dec byte ptr [s] end;
  gettree:=s
end;

procedure savetree;
var f:file;
begin
  assign(f,name);
  rewrite(f,1);
  blockwrite(f,r^,dirtreetype(r^).count*26+28);
  close(f)
end;

function loadtree;
var s:searchrec;
    f:file;
    r:^dirtreetype;
    c:word;
begin
  findfirst(name,archive,s);
  if doserror<>0 then
    begin
      loadtree:=createtree;
      exit
    end;
  assign(f,name);
  reset(f,1);
  blockread(f,c,2);
  getmem(r,c*26+28);
  blockread(f,r^.data[0],c*26+26);
  r^.count:=c;
  close(f);
  loadtree:=r
end;

procedure changetree;
var s:string;
begin
  s:=gettree(r,nr);
  if s[0]=^b then s:=s+#92;
  chdir(s)
end;

end.



{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
{$M 16384,65536,655360}
uses vga_ega,disctree;
var p:pointer;
    k1,k2:char;
    i,y:int;
    s:string;
label lab;

procedure puttree(i,y:integer);
var j,k:int;
begin
  with dirtreetype(p^)do
    begin
      for j:=0 to 23 do
        begin
          attrline(3,3+j,$1b+$5f*byte(y=j),27);
          if j+i<=count then
            begin
              for k:=1 to byte(data[i+j,0])do e[3+j,3+k].ch:=data[i+j,k];
              for k:=byte(data[i+j,0])+1 to 26 do e[3+j,3+k].ch:=#32
            end
        end;
      charline(1,28,#32,80);
      print(2,28,gettree(p,i+y)+#92)
    end
end;

const endstr:string='Koniec !'^M^J'Czekolade temu , kto potrafi takie drzewo posortowac'^m^j'Norton np. nie sortuje';
begin
  getdir(0,s);
  singleframe;
  setblinking(false);
  menucolors4;
  setleftrightmenu(false);
  setpol(true);
  setxtkeyboard;
  setxy(0,0);
  cls($1e,#32);
  line(1,1,$20,#32,80);
  line(1,28,$20,#32,80);
  frame(1,2,80,27,$1e);
  vercharline(31,3,#179,24);
  rozjasnij(vpal);
  p:=createtree;
  {savetree(p,'C:\PSTREE.PST');}
  if ioresult=0 then;
  if s[0]=^c
    then i:=0
    else
      with dirtreetype(p^)do
        for i:=0 to count do
          if gettree(p,i)=s then goto lab;
lab:
  if i<23 then y:=i;
  with dirtreetype(p^)do
    repeat
      if i+23>count then
        begin
          i:=count-23
        end;
      if i<0 then i:=0;
      puttree(i,y);
      getkey(k1,k2);
      case k1 of
        ^m:changetree(p,i+y);
        ^@:case k2 of
             #72:if y>0
                   then dec(y)
                   else dec(i);
             #80:if(y<23)and(y<count)
                   then inc(y)
                   else if i+22<count then inc(i);
           end
      end
    until k1 in[^[,^m];
  disposedirtree(p);
  stop(2,endstr);
end.

// Czekolada nieaktualna, wyrosłem, teraz moglbym ewebtualnie postawić piwo (gdybym nie umial ;p).

// Dopisane : Od samego początku crt mi jakoś nie leżało, wolałem swoje :]

0

Oh my God 8-0

Jak widzę coś takiego to mnie krew normalnie zalewa...

Czy oni nie mogli wydać jakiegoś TP8 albo i TP9 nawet... po to żeby nie męczyć się próbami zrozumienia (napisania? - ROTFL) takich modułów?!

Kurde...
A znalazłeś to gdzieś w Necie czy sam napisałeś? :)

PZDR

// Sam, przecież nie opublikowałbym cudzych okrojonych zródel bez dodatkowego info skąd, od kogo i na podstawie jakiej licencji :] Jestem zbokiem i z pascala używałem tylko podstawowych bibliotek poza crt, reszte sam tworzyłem. A moduł jest napisany jak najbardziej prawidłowo. W razie czego w download/kody zródłowe/pascal w którymś z : literki.zip/tfd2.zip/edit_pla powinna byc wersja modułu ega_vga działajaca z demkiem[mf]

1 użytkowników online, w tym zalogowanych: 0, gości: 1