home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TPPROC19.ZIP / DIRHARD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-09-06  |  14.5 KB  |  641 lines
  1. PROGRAM dir;
  2.  
  3. {written by George Goldberg
  4.  copyright 1985 The Catalog Company
  5.  Released to public domain}
  6.  
  7. CONST
  8.    max_record = 2000;
  9.    max_dir = 50;
  10.  
  11.    TYPE
  12.      registers=RECORD
  13.                  ax,bx,cx,dx,bp,si,di,ds,es,flags:INTEGER;
  14.                END;
  15.  
  16.      file_record=RECORD
  17.                 catalog:BYTE;
  18.                 name:STRING[12];
  19.                 attribute:BYTE;
  20.                 file_month,file_day,file_year,file_hour,file_min:BYTE;
  21.                 file_size:REAL;
  22.               END;
  23.      char80arr=ARRAY[1..80] OF CHAR;
  24.      string80=STRING[80];
  25.  
  26.    VAR
  27.      file_catalog:ARRAY [1..max_record] OF file_record;
  28.      outdev:STRING[5];
  29.      dev:TEXT;
  30.      dta:ARRAY[1..43] OF BYTE;
  31.      subdir:ARRAY [1..max_dir] OF string80;
  32.      dir1,dir2:STRING[3];
  33.      ok,printer:BOOLEAN;
  34.      origdir,sub:string80;
  35.      end_page,linecount,num,num1,num2,opt,index,pagenum:INTEGER;
  36.      dtaseg,dtaofs,setdtaseg,setdtaofs,error,
  37.      i,j,loop,scan_month,scan_day,scan_year,ok_date,
  38.      att,option,year,month,day,hour,min,sec:INTEGER;
  39.      size:REAL;
  40.      regs:registers;
  41.      buffer,namr:string80;
  42.      mask:char80arr;
  43.      ch:CHAR;
  44.  
  45. PROCEDURE setdta(segment,offset:INTEGER;VAR error:INTEGER);
  46.  
  47. BEGIN
  48.   regs.ax:=$1a00;
  49.   regs.ds:=segment;
  50.   regs.dx:=offset;
  51.   MSDOS(regs);
  52.   error:=regs.ax AND $ff;
  53. END;
  54.  
  55. PROCEDURE time;
  56.  
  57. BEGIN
  58.   regs.ax:=$2a00;
  59.   WITH regs DO
  60.   BEGIN
  61.     MSDOS(regs);
  62.     WRITE (dev,' ',HI(dx):2,'-',LO(dx):2,'-',cx-1900:2,' ');
  63.     regs.ax:=$2c00;
  64.     MSDOS(regs);
  65.     WRITE (dev,'   ',HI(cx):2,':',LO(cx):2)
  66.   END;
  67. END;
  68.  
  69. PROCEDURE getcurrentdta(VAR segment,offset:INTEGER; VAR error:INTEGER);
  70.  
  71. BEGIN
  72.   regs.ax:=$2f00;
  73.   MSDOS(regs);
  74.   segment:=regs.es;
  75.   offset:=regs.bx;
  76.   error:=regs.ax AND $ff;
  77. END;
  78.  
  79.  
  80. PROCEDURE information (segm,offs:INTEGER);
  81.  
  82. BEGIN
  83.   i:=1;
  84.   REPEAT
  85.     namr[i]:=CHR(MEM[segm:offs+29+i]);
  86.     i:=i+1;
  87.   UNTIL (NOT(namr[i-1] IN [' '..'~']));
  88.   att:=MEM[segm:offs+21];
  89.   hour:=((MEM[segm:offs+23])SHR 3 )AND $1f  ;
  90.   month:=((MEM[segm:offs+25] AND $01))*8
  91.       +((MEM[segm:offs+24]SHR 5)AND $07);
  92.   min:=(MEM[segm:offs+23] AND $07)*8
  93.       +((MEM[segm:offs+22]SHR 5)AND $07);
  94.   day:=(MEM[segm:offs+24] AND $1f);
  95.   year:=80+(MEM[segm:offs+25] AND $0fe) SHR 1;
  96.   size:=(MEM[segm:offs+26]* 1.0)+
  97.         (MEM[segm:offs+27]* 256.0)+
  98.         (MEM[segm:offs+28]* 65536.0)+
  99.         (MEM[segm:offs+29]* 16777216.0);
  100.   namr[0]:=CHR(i-1);
  101. END;
  102.  
  103.  
  104. PROCEDURE getfirst(mask:char80arr;VAR namr:string80;segment,
  105.           offset:INTEGER;option:INTEGER; VAR error:INTEGER);
  106.  
  107. VAR
  108.   i:INTEGER;
  109.  
  110. BEGIN
  111.   error:=0;
  112.   regs.ax:=$4e00;
  113.   regs.ds:=SEG(mask);
  114.   regs.dx:=OFS(mask);
  115.   regs.cx:=option;
  116.   MSDOS(regs);
  117.   error:=regs.ax AND $ff;
  118.   information(segment,offset);
  119. END;
  120.  
  121. PROCEDURE getnextentry(VAR namr:string80; segment,offset:INTEGER;
  122.                        option:INTEGER;VAR error:INTEGER);
  123.  
  124. VAR
  125.   i:INTEGER;
  126.  
  127. BEGIN
  128.   error:=0;
  129.   regs.ax:=$4f00;
  130.   regs.cx:=option;
  131.   MSDOS(regs);
  132.   error:=regs.ax AND $ff;
  133.   information(segment,offset);
  134. END;
  135.  
  136. PROCEDURE print_listings;
  137. VAR
  138.   temp:STRING[13];
  139.  
  140. BEGIN
  141.   IF (namr<>dir1) AND (namr<>dir2) THEN
  142.   WITH file_catalog[index] DO
  143.   BEGIN
  144.     IF (opt =  3) AND (ok_date <= (year-80)*365+month*31+day) OR (opt<>3)
  145.     THEN
  146.     BEGIN
  147.       IF sub[LENGTH(sub)]<>'\' THEN sub:=sub+'\';
  148.       catalog:=loop;
  149.       temp:=namr;
  150.       DELETE (temp,LENGTH(temp),1); {remove chr(0) at end of string}
  151.       name:=temp;
  152.       attribute:=att;
  153.       file_year:=year;
  154.       file_day:=day;
  155.       file_month:=month;
  156.       file_hour:=hour;
  157.       file_min:=min;
  158.       file_size:=size;
  159.       index:=index+1;
  160.       IF index > max_record THEN
  161.       BEGIN
  162.         CLRSCR;
  163.         GOTOXY (5,10);
  164.         WRITELN ('########  PROGRAM HALTED #########');
  165.         WRITELN;
  166.         WRITELN ('MAXIUMUM NUMBER OF FILES [',max_record,'] EXCEEDED');
  167.         WRITELN ;
  168.         WRITELN ('Cannot Use this program - sorry ');
  169.         CHDIR (origdir);
  170.         HALT;
  171.       END;
  172.     END;
  173.   END;
  174. END;
  175.  
  176. PROCEDURE getinfo;
  177. BEGIN
  178.   FOR i:=1 TO 21 DO dta[i]:=0;
  179.   FOR i:=1 TO 80 DO
  180.   BEGIN
  181.     mask[i]:=CHR(0);
  182.     namr[i]:=CHR(0);
  183.   END;
  184.   namr[0]:=CHR(0);
  185.   getcurrentdta(dtaseg,dtaofs,error);
  186.   IF (error<>0 ) THEN
  187.   BEGIN
  188.     WRITELN('unable to get current dta');
  189.     WRITELN('program aborting');
  190.     HALT;
  191.   END;
  192.   setdtaseg:=SEG(dta);
  193.   setdtaofs:=OFS(dta);
  194.   setdta(setdtaseg,setdtaofs,error);
  195.   IF (error<>0) THEN
  196.   BEGIN
  197.     WRITELN('Cannot reset dta');
  198.     WRITELN('Program aborting');
  199.     HALT;
  200.   END;
  201.   error:=0;
  202.   buffer[0]:=CHR(0);
  203.   option:=22;
  204.   buffer:='????????.???';
  205.   FOR i:=1 TO LENGTH(buffer) DO
  206.     mask[i]:=buffer[i];
  207.   getfirst(mask,namr,setdtaseg,setdtaofs,option,error);
  208.   IF (error=0) THEN
  209.   BEGIN
  210.     GETDIR(0,sub);
  211.     GOTOXY (27,15);
  212.     WRITE (' ':50);
  213.     GOTOXY (27,15);
  214.     LOWVIDEO;
  215.     WRITELN (sub);
  216.     NORMVIDEO;
  217.     print_listings
  218.   END;
  219.   WHILE (error=0) DO
  220.   BEGIN
  221.     getnextentry(namr,setdtaseg,setdtaofs,option,error);
  222.     IF (error=0) THEN
  223.     BEGIN
  224.       print_listings;
  225.       IF (att AND $10 <>0) AND (namr <>('..'+CHR(0))) THEN
  226.       BEGIN
  227.         num:=num+1;
  228.         IF num > max_dir THEN
  229.         BEGIN
  230.           CLRSCR;
  231.           GOTOXY (5,10);
  232.           WRITELN ('########  PROGRAM HALTED #########');
  233.           WRITELN;
  234.           WRITELN ('MAXIUMUM NUMBER OF DIRECTORIES [',
  235.                         max_dir,'] EXCEEDED');
  236.           WRITELN ;
  237.           WRITELN ('Cannot Use this program - sorry ');
  238.           CHDIR (origdir);
  239.           HALT;
  240.         END;
  241.         GETDIR(0,sub);
  242.         IF sub[LENGTH(sub)] <> '\' THEN sub:=sub+'\';
  243.             subdir[num]:=sub+namr;
  244.         DELETE (subdir[num],LENGTH(subdir[num]),1) {get rid of
  245.                                 terminal chr(0) }
  246.       END
  247.     END
  248.   END;
  249.   setdta(dtaseg,dtaofs,error);
  250. END;
  251.  
  252.  
  253. {Quicksort in Turbo Pascal}
  254.  
  255. PROCEDURE sort(bottom,top: INTEGER);
  256. VAR lower_ptr, upper_ptr: INTEGER;
  257.       middle_element, temp: file_record;
  258.  
  259. BEGIN
  260.   lower_ptr := bottom;
  261.   upper_ptr :=top;
  262.   middle_element := file_catalog[(bottom+top)DIV 2] ;
  263.   REPEAT
  264.     WHILE file_catalog[lower_ptr].name <
  265.               middle_element.name DO lower_ptr := lower_ptr + 1;
  266.     WHILE middle_element.name <
  267.           file_catalog[upper_ptr].name DO upper_ptr := upper_ptr - 1;
  268.     IF lower_ptr <= upper_ptr THEN
  269.     BEGIN
  270.       temp := file_catalog[lower_ptr];
  271.       file_catalog[lower_ptr]:= file_catalog[upper_ptr];
  272.       file_catalog[upper_ptr] := temp;
  273.       lower_ptr := lower_ptr + 1;
  274.       upper_ptr := upper_ptr - 1;
  275.     END;
  276.   UNTIL lower_ptr > upper_ptr;
  277.   IF bottom < upper_ptr THEN sort(bottom,upper_ptr);
  278.   IF lower_ptr < top THEN sort(lower_ptr,top);
  279. END;
  280.  
  281. PROCEDURE header;
  282.  
  283. BEGIN
  284.   IF opt=1 THEN WRITE (dev,'Directory list for all files.',' ':15)
  285.      ELSE
  286.   IF opt=2 THEN WRITE (dev,'Directory list for duplicate files.',' ':9)
  287.      ELSE     WRITE (dev,'Directory list for files by selected date',' ':3);
  288.   time;
  289.   WRITELN (dev,'   Page ',pagenum:3);
  290.   pagenum:=pagenum+1;
  291.   WRITELN (dev,'* = Sub dir: A = Archive bit on: R = Read only: ',
  292.                'H = Hidden: S = System');
  293.   WRITELN (dev);
  294.   WRITELN (dev,' ':6,'Files',' ':10,'Directory',' ':12,'Date',' ':6,'Time',
  295.             ' ':8,'Size');
  296.   WRITELN (dev);
  297.   linecount:=5;
  298. END;
  299.  
  300. PROCEDURE checkcount;
  301.  
  302. BEGIN
  303.   IF linecount = end_page THEN
  304.   BEGIN
  305.     IF NOT printer THEN
  306.     BEGIN
  307.       WRITE (dev,' ':35,'-MORE-');
  308.       REPEAT UNTIL KEYPRESSED;
  309.       READ (KBD,ch);
  310.       CLRSCR
  311.     END
  312.     ELSE
  313.     BEGIN
  314.       GOTOXY (8,17);
  315.       WRITE (' ':67);
  316.       GOTOXY (8,17);
  317.       WRITE ('Page #',pagenum:3,' ');
  318.       WRITELN (dev,CHR(12));
  319.     END;
  320.     header;
  321.   END;
  322.   IF printer THEN WRITE ('.');
  323. END;
  324.  
  325.  
  326. PROCEDURE print_data1;
  327. VAR
  328.   count:INTEGER;
  329.   am:STRING[2];
  330.  
  331. BEGIN
  332.   LOWVIDEO;
  333.   WITH file_catalog[i] DO
  334.   BEGIN
  335.     count:=0;
  336.     IF (attribute AND $01)<>0 THEN
  337.     BEGIN
  338.       count:=count+1;
  339.       WRITE (dev,'R');
  340.     END;
  341.     IF (attribute AND $02)<>0 THEN
  342.     BEGIN
  343.       count:=count+1;
  344.       WRITE (dev,'H');
  345.     END;
  346.     IF (attribute AND $04)<>0 THEN
  347.     BEGIN
  348.       count:=count+1;
  349.       WRITE (dev,'S');
  350.     END;
  351.     IF (attribute AND $08)<>0 THEN
  352.     BEGIN
  353.       count:=count+1;
  354.       WRITE (dev,'V');
  355.     END;
  356.     IF (attribute AND $10)<>0 THEN
  357.     BEGIN
  358.       count:=count+1;
  359.       WRITE (dev,'*');
  360.     END;
  361.     IF (attribute AND $20)<>0 THEN
  362.     BEGIN
  363.       count:=count+1;
  364.       WRITE (dev,'A');
  365.     END;
  366.     WRITE (dev,' ':6-count);
  367.     WRITE (dev,name,' ':15-LENGTH(name),
  368.           subdir[catalog],' ':20-LENGTH(subdir[catalog]));
  369.     IF LENGTH (subdir[catalog]) > 19 THEN
  370.     BEGIN
  371.       WRITELN (dev);
  372.       linecount:=linecount+1;
  373.       checkcount;
  374.       WRITE (dev,' ':41);
  375.     END;
  376.     am:='pm';
  377.     IF file_hour <12 THEN am:='am';
  378.     IF file_hour >12 THEN file_hour :=file_hour-12;
  379.     IF file_hour=0 THEN file_hour :=12;
  380.     WRITE (dev,file_month:2,'-');
  381.     IF file_day >9 THEN WRITE (dev,file_day:2)
  382.     ELSE
  383.     WRITE (dev,'0',file_day:1);
  384.     WRITE (dev,'-',file_year:2,'  ',file_hour:2,':');
  385.     IF file_min >9 THEN WRITE (dev,file_min:2)
  386.     ELSE
  387.     WRITE (dev,'0',file_min:1);
  388.     WRITELN  (dev,am,' ',file_size:10:0);
  389.     linecount:=linecount+1;
  390.     NORMVIDEO;
  391.     checkcount;
  392.   END;
  393. END;
  394.  
  395.  
  396.  
  397. PROCEDURE print_data;
  398. VAR
  399.   oklast:BOOLEAN;
  400.  
  401. BEGIN
  402.   oklast:=FALSE;
  403.   FOR i:=1 TO index DO
  404.   WITH file_catalog[i] DO
  405.   BEGIN
  406.     IF opt <>2 THEN print_data1;
  407.     IF i<>index THEN ok:= ((opt=2) AND (name=file_catalog[i+1].name))
  408.        ELSE ok:= FALSE;
  409.     IF ok THEN print_data1;
  410.     IF oklast AND NOT ok THEN
  411.     BEGIN
  412.       print_data1;
  413.       WRITELN (dev);
  414.       linecount:=linecount+1;
  415.       checkcount;
  416.     END;
  417.     oklast:=ok;
  418.   END;
  419. END;
  420.  
  421. PROCEDURE boarder;
  422. VAR
  423.   block : CHAR;
  424.  
  425. BEGIN
  426.   BLOCK := CHR(176);
  427.   GOTOXY (1,1);
  428.   FOR i:= 1 TO 79 DO
  429.     WRITE (block);
  430.   GOTOXY (1,25);
  431.   FOR i:= 1 TO 79 DO
  432.     WRITE (block);
  433.   GOTOXY( 1,2);
  434.   FOR i:= 1 TO 24 DO
  435.   BEGIN
  436.     GOTOXY (1,i);
  437.     WRITE (block,block);
  438.     GOTOXY (78,i);
  439.     WRITE (block,block);
  440.   END;
  441. END;
  442.  
  443. PROCEDURE introduction;
  444. VAR
  445.   ch:CHAR;
  446.   logdrive:STRING[3];
  447.  
  448. BEGIN
  449.   pagenum:=1;
  450.   CLRSCR;
  451.   boarder;
  452.   GOTOXY (5,3);
  453.   WRITELN ('DIR\SUBDIRECTORY LISTER PROGRAM');
  454.   WRITELN;
  455.   GOTOXY (5,7);
  456.   WRITELN ('OPTIONS');
  457.   LOWVIDEO;
  458.   GOTOXY (10,9);
  459.   WRITELN (' 1 -  List ALL files on the disk');
  460.   GOTOXY (10,10);
  461.   WRITELN (' 2 -  List only DUPLICATE files on the disk');
  462.   GOTOXY (10,11);
  463.   WRITELN (' 3 -  List files DATED on/or after mm/dd/yy');
  464.   GOTOXY (10,12);
  465.   WRITELN (' 4 -  Exit');
  466.   GOTOXY (6,20);
  467.   WRITELN ('For output on printer  - enter (P) prior to number option');
  468.   GOTOXY (6,21);
  469.   WRITELN ('To change to new drive - enter (L) prior to number option');
  470.   GOTOXY (12,24);
  471.   WRITE ('(C) The Catalog Company 1985 - Public Domain Release');
  472.   printer:=FALSE;
  473.   NORMVIDEO;
  474.   GOTOXY (38,20);
  475.   WRITE ('P');
  476.   GOTOXY (38,21);
  477.   WRITE ('L');
  478.   GETDIR(0,logdrive);
  479.   REPEAT
  480.     GOTOXY (60,3);
  481.     LOWVIDEO;
  482.     WRITE ('Drive : = ');
  483.     NORMVIDEO;
  484.     WRITE (logdrive);
  485.     GOTOXY (6,14);
  486.     WRITE ('OPTION <1-4>: ');
  487.     REPEAT UNTIL KEYPRESSED;
  488.     READ (KBD,ch);
  489.     IF ch IN ['p','P'] THEN printer:=NOT printer;
  490.     IF ch IN ['l','L'] THEN
  491.     BEGIN
  492.       GOTOXY (6,15);
  493.       WRITE ('New Drive (A..Z) ');
  494.       REPEAT UNTIL KEYPRESSED;
  495.       READ (KBD,ch);
  496.       ch:=UPCASE(ch);
  497.       IF ch IN ['A'..'Z'] THEN
  498.       BEGIN
  499.         CHDIR(ch+':\');
  500.         WRITE (ch,':');
  501.         GETDIR(0,logdrive);
  502.       END;
  503.     END;
  504.     GOTOXY (6,15);
  505.     WRITE (' ':64);
  506.     opt:=ORD(ch)-48;
  507.     GOTOXY (20,14);
  508.     IF opt IN [1..4] THEN WRITE (opt);
  509.     GOTOXY (21,14);
  510.     IF printer THEN WRITE (' - PRINTER ACTIVE') ELSE WRITE (' ':25);
  511.   UNTIL opt IN [1..4];
  512.   IF opt = 4 THEN EXIT;
  513.   IF opt = 3 THEN
  514.   {$I-}
  515.   BEGIN
  516.     REPEAT
  517.       LOWVIDEO;
  518.       GOTOXY (6,15);
  519.       WRITE (' ':30);
  520.       GOTOXY (6,15);
  521.       WRITE ('MONTH [01-12] ');
  522.       READLN (scan_month)
  523.     UNTIL (scan_month IN [01..12]) AND (ioresult =0);
  524.     REPEAT
  525.       GOTOXY (6,15);
  526.       WRITE (' ':30);
  527.       GOTOXY (6,15);
  528.       WRITE ('DAY [01-31] ');
  529.       READLN (scan_day)
  530.     UNTIL (scan_day IN [01..31]) AND (ioresult =0);
  531.     REPEAT
  532.       GOTOXY (6,15);
  533.       WRITE (' ':30);
  534.       GOTOXY (6,15);
  535.       WRITE ('YEAR [80-99] ');
  536.       READLN (scan_year)
  537.     UNTIL (scan_year IN [80..99]) AND (ioresult =0);
  538.     {$I+}
  539.     ok_date:= (scan_year-80)*365+scan_month*31+scan_day;
  540.   END;
  541.   NORMVIDEO;
  542.   IF printer THEN
  543.   BEGIN
  544.     outdev:='LST:';
  545.     end_page:=60;
  546.   END
  547.   ELSE
  548.   BEGIN
  549.     outdev:='CON:';
  550.     end_page:=24;
  551.   END;
  552.   ASSIGN (dev,outdev);
  553.   RESET(dev);
  554.   GOTOXY (6,15);
  555.   WRITE (' ':64);
  556.   GOTOXY (6,15);
  557.   WRITE ('Reading Directory of ');
  558. END;
  559.  
  560.  
  561. BEGIN
  562.   GETDIR(0,origdir);
  563.   REPEAT
  564.     CHDIR ('\');
  565.     introduction;
  566.     IF opt <> 4 THEN
  567.     BEGIN
  568.       GETDIR(0,namr);
  569.       subdir[1]:=namr;
  570.       dir1:='.'+CHR(0);
  571.       dir2:='..'+CHR(0);
  572.       num:=1;
  573.       index:=1;
  574.       loop:=1;
  575.       getinfo;
  576.       num1:=2;
  577.       num2:=num;
  578.       IF num<>1 THEN
  579.       REPEAT
  580.         FOR loop:=num1 TO num2 DO
  581.         BEGIN
  582.           CHDIR(subdir[loop]);
  583.           getinfo;
  584.         END;
  585.         IF num2<>num THEN
  586.         BEGIN
  587.           ok:=FALSE;
  588.           num1:=num2+1;
  589.           num2:=num;
  590.         END
  591.         ELSE ok:=TRUE;
  592.       UNTIL ok;
  593.       index:=index-1;
  594.       GOTOXY (6,15);
  595.       WRITE (' ':64);
  596.       GOTOXY (6,15);
  597.       WRITELN ('Sorting ');
  598.       sort(1,index);
  599.       GOTOXY (6,16);
  600.       WRITE ('Printing ');
  601.       GOTOXY (8,17);
  602.       WRITE ('Page #',pagenum:3,' ');
  603.       IF NOT printer THEN CLRSCR;
  604.       header;
  605.       print_data;
  606.       WRITELN;
  607.       IF linecount +2 >= end_page THEN
  608.       BEGIN
  609.         linecount:=end_page;
  610.         checkcount;
  611.       END;
  612.       WRITE (dev,' ':6,'Number of dir/subdir : ',num,' ':12,'Number of files : ');
  613.       IF opt <> 3 THEN WRITELN (dev,index-num+1)
  614.               ELSE WRITELN (dev,index);
  615.       IF printer THEN
  616.       BEGIN
  617.         GOTOXY (1,24);
  618.         WRITELN (dev,CHR(12));
  619.       END
  620.       ELSE
  621.       BEGIN
  622.         linecount:=linecount+1;
  623.         checkcount;
  624.         WRITE (dev,' ':35,'-DONE-');
  625.         REPEAT UNTIL KEYPRESSED;
  626.         READ (KBD,ch);
  627.         CLRSCR;
  628.       END;
  629.     END
  630.     ELSE
  631.     BEGIN
  632.       CHDIR (origdir);
  633.       GOTOXY (1,24);
  634.     END;
  635.   UNTIL opt = 4;
  636.   CLRSCR
  637. END.
  638.    {$I+}
  639.     ok_date:= (scan_year-80)*365+scan_month*31+scan_day;
  640.   END;
  641.   NORM