DataMuseum.dk

top - metrics - download

    Length: 3456 (0xd80)
    Types: TextFile
    Names: »LENGTH.PAS«

└─⟦692ac107c⟧ Bits:30005923 PolyPascal-80 V3.10 arbejdsdiskette 1
    └─⟦this⟧ »LENGTH.PAS« 

TextFile

CONST
  SETDMA = 26;
  SEARCH_FIRST = 17;
  SEARCH_NEXT = 18;
  
TYPE
  STR14 = STRING(.14.);
  FCBN = STRING(.36.);
VAR
  PARM : STRING(.50.) AT $80;
  FIL,FIL1 : TEXT;
  FIL2 : FILE;
  LINE : STRING(.120.);
  NEWNAME,NAME : STR14;
  NN : ARRAY(.0..1023.) OF STR14;
  FCB1 : FCBN;
  X,I,J : INTEGER;
  RR,DIRBUF : ARRAY(.0..127.) OF BYTE;

FUNCTION BIG(A : CHAR) : CHAR;
BEGIN;
IF A IN (.'a'..'ü'.) THEN BIG := CHR(ORD(A)-$20) ELSE BIG := A;
END;

FUNCTION SETFCB(NAVN : STR14) : FCBN;
VAR
  FC : FCBN;
  I,J : INTEGER;
BEGIN
  I := 1;
  J := 2;
  IF (LEN(NAVN) > 1) AND (NAVN(.2.) = ':') THEN
  BEGIN
    FC(.1.) := CHR(ORD(NAVN(.1.)) MOD 16);
    I := 3;
  END ELSE FC(.1.) := @0;
  WHILE (I <= LEN(NAVN)) AND (NAVN(.I.) <> '.') DO
  BEGIN
    IF NAVN(.I.) = '*' THEN
    BEGIN
      WHILE J < 10 DO BEGIN FC(.J.) := '?'; J := SUCC(J); END;
      I := SUCC(I);
    END ELSE
    BEGIN FC(.J.) := BIG(NAVN(.I.)); J := SUCC(J); I := SUCC(I); END;
  END;
  WHILE J < 10 DO BEGIN FC(.J.) := ' '; J := SUCC(J); END;
  IF NAVN(.I.) = '.' THEN I := SUCC(I);
  WHILE (I <= LEN(NAVN)) DO
  BEGIN
    IF NAVN(.I.) = '*' THEN
    BEGIN
      WHILE J < 13 DO BEGIN FC(.J.) := '?'; J := SUCC(J); END;
      I := SUCC(I);
    END ELSE
    BEGIN FC(.J.) := BIG(NAVN(.I.)); J := SUCC(J); I := SUCC(I); END;
  END;
  WHILE J < 13 DO BEGIN FC(.J.) := ' '; J := SUCC(J); END;
  FC(.0.) := @36;
  FOR J := 13 TO 32 DO FC(.J.) := @0;
  SETFCB := FC;
END;

FUNCTION SEARCH(FCB : STR14) : STR14;
VAR
  I : INTEGER;
  N : STR14;
  NEXT : BOOLEAN;
BEGIN
  N := '';
  FOR I := 1 TO 8 DO IF FCB(.I.) <> ' ' THEN N := N+FCB(.I.);
  IF COPY(FCB,9,3) = '   ' THEN BEGIN END ELSE
  BEGIN
    N := N+'.';
    FOR I := 9 TO 11 DO IF FCB(.I.) <> ' ' THEN N := N+FCB(.I.);
  END;
  SEARCH := N;
END;

PROCEDURE HOLD;
VAR
  P : CHAR;
BEGIN;
  IF (X <> 0) AND (X MOD 22 = 0) THEN
  BEGIN
    WRITE  ('PRESS ANY KEY TO CONTINUE');
    READ(KBD,P);
    WRITELN;
  END;
  WRITELN;
END;

PROCEDURE PRINTFIL(NEWNAME : STR14);
BEGIN
    ASSIGN(FIL2,NEWNAME);
    (*$I-*)
    RESET(FIL2);
    IF IORES = 0 THEN
      BEGIN
        IF X MOD 22 = 0 THEN
        BEGIN
	  HOLD;
          WRITELN('File:            Sectors:');
        END;
        WRITE  (NEWNAME,' ':16-LEN(NEWNAME));
        WRITELN('  ',LENGTH(FIL2):4);
      END;
    CLOSE(FIL2);
    (*$I+*)
END;

(*--*)

BEGIN
  X := 0;
  IF MEM(.$80.) = 0 THEN
  BEGIN
    WRITELN('This program shows the length of sectors for the specified');
    WRITELN('files. Use * and ? in filename for multible search.');
    WRITE('Search-pattern: ');
    READLN(NAME);
  END ELSE NAME := COPY(PARM,2,LEN(PARM)-1);
  WRITELN;
  FCB1 := SETFCB(NAME);
  BDOS(SETDMA,ADDR(DIRBUF));
  I := BDOSB(SEARCH_FIRST,ADDR(FCB1(.1.)));
  WHILE I < 255 DO
  BEGIN
    NEWNAME := '';
    FOR J := 1 TO 11 DO NEWNAME := NEWNAME + (CHR(DIRBUF(.J+(I*32).)));
    NEWNAME :=SEARCH(NEWNAME);
    IF FCB1(.1.) <> @0 THEN NEWNAME := CHR(ORD(FCB1(.1.))+$40)+ ':'+NEWNAME;
    NN(.X.) := NEWNAME;
    X := SUCC(X);
    I := BDOSB(SEARCH_NEXT);
  END;
  IF X = 0 THEN WRITELN('No matching file.')
           ELSE 
           BEGIN
             FOR X := 0 TO X-1 DO PRINTFIL(NN(.X.));
             HOLD;
             WRITELN(X+1:3,' File(s) found.');
           END;
END.
«eof»