Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBCS/DEMOS/W.PAS

Pascal/Delphi Source File | 1993-03-08 | 45.2 KB | 1,485 lines

{$F+}
{$M 65520,0,655360}
uses
  eco_lib, dos, crt

  ;



const
  max_colours = 30;


type
  attr_colours_type = record
    ext    : string[3];
    colour :      byte;
  end;
  attr_colours_type_ar = array[0..max_colours] of attr_colours_type;


const
  attr_colours: attr_colours_type_ar = (
    (ext : 'dir'; colour : red),            { directory }
    (ext : 'vol'; colour : magenta),        { volumeid  }
    (ext : 'inf'; colour : darkgray),       { infolines }
    (ext : 'std'; colour : lightgray),      { doscolour }

    (ext : 'exe'; colour : yellow),
    (ext : 'com'; colour : yellow),         { executables }
    (ext : 'bat'; colour : yellow),
    (ext : 'cmd'; colour : yellow),

    (ext : 'asm'; colour : lightcyan),
    (ext : 'ash'; colour : lightcyan),
    (ext : 'pas'; colour : lightcyan),
    (ext : 'c';   colour : lightcyan),      { sources }
    (ext : 'cpp'; colour : lightcyan),
    (ext : 'h';   colour : lightcyan),
    (ext : 'prg'; colour : lightcyan),
    (ext : 'inc'; colour : lightcyan),

    (ext : 'arc'; colour : lightred),
    (ext : 'arj'; colour : lightred),
    (ext : 'lzh'; colour : lightred),       { archives }
    (ext : 'zip'; colour : lightred),
    (ext : 'zoo'; colour : lightred),

    (ext : 'txt'; colour : magenta),
    (ext : 'doc'; colour : magenta),
    (ext : 'sam'; colour : magenta),        { textfiles }
    (ext : 'inf'; colour : magenta),
    (ext : 'hlp'; colour : magenta),

    (ext : 'tpu'; colour : brown),
    (ext : 'obj'; colour : brown),          { binaries }
    (ext : 'lib'; colour : brown),

    (ext : 'ini'; colour : white),          { initialisations }
    (ext : 'cfg'; colour : white)
  );

  packsize           : byte    =        21;

  use_colours        : boolean =      true;
  nopointsdir        : boolean =      true;

  maxoverdrive       : boolean =     false;
  ampm               : boolean =     false;
  debug              : boolean =     false;
  extended           : boolean =     false;

  show_date          : boolean =      true;
  show_pad           : boolean =      true;
  show_drv           : boolean =      true;
  show_num           : boolean =      true;
  show_sum           : boolean =      true;
  greatness          : boolean =     false;
  freespace          : boolean =      true;

  dir_report         : boolean =     false;
  globaltree         : boolean =     false;
  interrupted        : boolean =     false;
  kind               : sortmethods = on_name;
  noscan             : boolean =     false;
  not_sum_only       : boolean =      true;
  sort_items         : boolean =      true;
  takemainsize       : boolean =     false;
  upcasenames        : boolean =     false;
  wide               : boolean =     false;
  comexebatcmdfilter : boolean =     false;

  normalcolour       : byte    = lightgray;


  condition_attrs : condition_attrstype = (
    show_r_o    :   true;
    show_hid    :   true;
    show_sys    :   true;
    show_arc    :   true;
    show_vol    :   true;
    show_dir    :   true;
    show_non    :   true;
    sort_method : on_name
  );




var
  originalswitch,
  swch             :            char;
  filarray         : filarraytypeptr;
  findattribute,
  max_colours_env,
  manipulate       :            word;
  sort_ptr,
  attr_ptr         :         pointer;
  i, j, coll,
  plus, cols,
  skind, nod,
  mainsize,
  totlin,
  dirs, numitems   :            word;
  volum, redirect  :         boolean;
  env, tmp,
  st, st2,
  colour_string,
  treeinfosource,
  olddospath       :          string;
  tot              :         longint;
  oldexitproc      :         pointer;



  procedure toggle(var b: boolean);
  begin
    b := not b;
  end;


  function __rempoint(s: string): string;
  var i : byte;
  begin
    i := pos('.', s);
    if i > 0 then delete(s, i, 1);
    __rempoint := s;
  end;


  procedure textcolour(b: byte);
  begin
    if use_colours then textcolor(b);
  end;


  function redirectpressed: boolean;
  begin
    redirectpressed := not(redirect) and keypressed;
  end;



{▒▒subtree functions▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒}
const
  maxnodes = 3072;

type
  srec_ptr = ^srec_chain;
  srec_chain = record
    srec : searchrec;
    bid  :   longint;
    prev :      word;
    link :  srec_ptr;
  end;

  nodes = record
    name    : string[12];
    bid     :    longint; { bytes in directory }
    parent  :       word;
  end;

  nodearraytype = array[0..maxnodes] of nodes;
  nodearraytypeptr = ^nodearraytype;

const
  x3                : byte    =                1;
  x4                : byte    =               12;
  y3                : byte    =                1;
  popup_f           : byte    =                7;
  popup_b           : byte    =                0;
  sizedir           : boolean =             true;
  showscan          : boolean =             true;
  drivechar         : char    =              'C';
  treeinfodrivechar : char    =              'C';
  treeinfofile      : string  =  ':\TREEINFO.DR';
  totgen            : longint =                0;
  totnum            : longint =                0;


var
  node_file              :    file of nodes;
  nodearray              : nodearraytypeptr;
  prevparent,
  nodenumber             :             word;
  srec                   :        searchrec;
  searchbasis,
  searchpattern,
  searchpath,
  s                      :           string;


  function trace_path(temphead: integer): pathstr;
  var
    off      :                    word;
    st       :                  string;
    i        :                    word;
    tmp      : array[1..50] of integer;

  begin
    off := 0;
    while temphead>0 do begin
      inc(off); tmp[off] := temphead;
      temphead := nodearray^[temphead].parent;
    end; st := '\';
    if off>0 then for i := off downto 1 do
      st := st + nodearray^[tmp[i]].name +'\';
    off := 0; fillchar(tmp, sizeof(tmp), chr(48));
    trace_path := st;
  end;



  function calccurpath(var notfound: boolean): word;
  var
    i,j      :    word;
    curpath  : pathstr;
    chops    :  string;

  begin
    getdir(0, curpath); notfound := false;
    if length(curpath) = 3 then calccurpath := 0 else begin
      curpath := __cvtstr(curpath + '\', _to_upcase_str);
      i := length(curpath)-1; j := i; while curpath[i]<>'\' do dec(i); inc(i);
      chops := __cvtstr(copy(curpath, i, j-i+1), _to_upcase_str);

      j := 0;
      for i := nodenumber - 1 downto 1 do if
        __cvtstr(nodearray^[i].name, _to_upcase_str)=chops then
        if __cvtstr(__normfil(trace_path(i)),_to_upcase_str)=curpath then j :=i;
      if j=0 then notfound := true;
      calccurpath := j;
    end;
  end;


{$I-}
  procedure showtree(s: string);
  begin
    if not redirect then begin gotoxy(19, wherey); write(s) end;
  end;


  procedure search_tree(level: word);
  var
    i         :  integer;
    s         :   string;
    srec_root,
    srec_link : srec_ptr;

    { not much subdirs in one dir, so no efficiency taken into account }
    procedure sort(srec_root: srec_ptr);
    var
      srec1, srec2, srec3 :  srec_ptr;
      srec                : searchrec;

    begin
      srec1 := srec_root;
      while srec1^.link <> nil do begin
        srec2 := srec1^.link; srec3 := srec1;
        repeat { assume we are already sorted properly }
          if srec2^.srec.name < srec3^.srec.name then srec3 := srec2;
          srec2 := srec2^.link;
        until srec2 = nil;
        if srec3 <> srec1 then begin
          srec := srec1^.srec; srec1^.srec := srec3^.srec; srec3^.srec := srec;
        end; srec1 := srec1^.link;
      end;
    end;

  begin
    srec_root := nil;
    if sizedir then findfirst('*.*', anyfile, srec) else findfirst(
      '*.*', directory, srec
    );

    nodearray^[nodenumber].bid := 0;
    while doserror=0 do begin {@}
      if not({__nonascii(srec.name) or }((srec.attr and directory)=0)) then begin
        if sizedir then inc(
          nodearray^[nodenumber].bid, __main(srec.size, mainsize)
        );
        if (((srec.attr and directory)>0) and (srec.name[1] <> '.')) then begin
          if srec_root = nil then begin
            new(srec_root); srec_link := srec_root;
          end else begin
            new(srec_link^.link); srec_link := srec_link^.link;
          end; srec_link^.srec := srec; srec_link^.link := nil;
          srec_link^.prev := prevparent;
        end;
      end;
      findnext(srec);
    end; inc(prevparent);
    if srec_root <> nil then begin
      if sort_items then sort(srec_root);
      if showscan then showtree('\');
      repeat
        s := srec_root^.srec.name;
        with nodearray^[nodenumber] do begin
          name := s; parent := srec_root^.prev;
        end;
        if nodenumber < maxnodes then inc(nodenumber) else
          maxoverdrive := true;
        if showscan then showtree(
          __juststr(__num(nodenumber), '0', 3, _right_just_str) + ' : ' +
          __juststr(s, ' ', 12, _left_just_str)
        );
        chdir(s); search_tree(level+1); chdir('..');
        srec_link := srec_root; srec_root := srec_root^.link;
        dispose(srec_link);
      until (srec_root = nil); {@}
    end else if (level = 0) and showscan then showtree('No <DIR> entries');
  end; { search_tree }



  procedure trace_tree;
  var oldpath: string;
  begin
    s := ''; nodenumber := 1; prevparent := 0; new(nodearray);
    getdir(0, oldpath);
    showscan := _dosdiscsize > 50000000; { > 50.000.000 }
    search_tree(0); chdir(oldpath);
    gotoxy(16, wherey); clreol; writeln(':  ', nodenumber);
    if maxoverdrive then begin
      writeln;
      writeln(
        'WARNING: limited tree functionality: more than ',
        maxnodes, ' directories!'
      );
    end;
  end;


  procedure load_tree(fname: pathstr);
  var rec : searchrec;
  begin
    s := ''; nodenumber := 1; prevparent := 0; new(nodearray);
    assign(node_file, fname); reset(node_file);
    while not(eof(node_file)) do begin
      read(node_file, nodearray^[nodenumber]); inc(nodenumber)
    end; close(node_file);
    nodearray^[0].bid := 0;
  end;

  procedure save_tree(fname: pathstr);
  var rec : searchrec;
  begin
    assign(node_file, fname); rewrite(node_file);
    for nod := 1 to nodenumber-1 do write(node_file, nodearray^[nod]);
    close(node_file);
  end;

{▒▒subtree functions▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒}





  procedure help;

    procedure s(s: string);
    var
      part1, part2 : string;
      i, j         :   byte;

    begin
      i := pos(swch, s);
      j := i;
      while (j < length(s)) and not(s[j] in ['[', ' ']) do inc(j);
      if s[2] = '.' then begin i := 2; j := 3 end;
      if (i < 7) and (i > 0) then begin
        part1 := __part(s, 1, i-1);
        part2 := __part(s, j, length(s));
        write(part1);
        textcolour(lightred);
        write(__part(s, i, j-1));
        textcolour(yellow);
        write(part2);
      end else write(s);
      clreol;
      writeln;
    end;

  begin
    textcolour(yellow);
    s('');
    s('');
    s(
      ' · ·· · ··  ─── ─ ─  ──  ┌─────────────' +
      '───────────────────────────────────────┐'
    );
    s(
      '· ·  ── · ─ ─  ─   ── ── │ (W) MCMXCIII' +
      ' UltiHouse Software / This is freeware │'
    );
    s(
      '  ·· ·─ ─ ── ·· ─ ── ·   └─────────────' +
      '───────────────────────────────────────┘'
    );
    s('');
    s(
      'Usage: ' + __progname + '  {filepathspec}  [options]'
    );
    s(
      '  Notes: Forward slashes may be used instead of backslashes.'
    );
    s(
      '  If a directory is designated, using forward slashes (/), that'
    );
    s(
      '  matches an attribute skipper, use double slashes like in //a or //s'
    );
    s(
      '  Options are toggles: set in environment WDIR ' +
      'and commandline will toggle.'
    );
    s(
      ' ' + swch +
      'switch c :: where `c'' is a char for switch designation' +
      ' (environment)'
    );
    if swch <> '-' then s(
      '  Suggested environment: "SET WDIR=-switch ' + swch +
      ' ' + swch + 'w ' + swch + 'u 1 ' + swch + 'x ' + swch +
      'k"  en   "SET WTREEINFO=C"'
    ) else s(
      '  Suggested environment: "SET WDIR=' + swch + 'w ' + swch + 'u 1 ' +
      swch + 'x ' + swch + 'k"  en   "SET WTREEINFO=C"'
    );
    s('');
    s(
      ' ' + swch + 'A[rchive]    :: Skip Archive files.'
    );
    s(
      ' ' + swch + 'B[oot/Sys]   :: Skip Boot / System files.' +
      '     ┌───┐ ┌─┬─┐ ┌─┬─┐ ┌───┐'
    );
    s(
      ' ' + swch + 'H[idden]     :: Skip Hidden files.' +
      '            ├───┤   │     │   ├──┬┘'
    );
    s(
      ' ' + swch + 'R[eadonly]   :: Skip ReadOnly files.' +
      '          ┴   ┴   ┴     ┴   ┴  └─'
    );
    s(
      ' ' + swch + 'N[one]       :: Skip files with no attributes.'
    );
    s('');
    s('');
    s(
      ' ' + swch + 'E[xtension]  :: Sort files by extension.'
      );
    s(
      ' ' + swch + 'L[ength]     :: Sort files by filelength.' +
      '     ┌───┐ ┌───┐ ┌───┐ ┌─┬─┐'
    );
    s(
      ' ' + swch + 'T[imedate]   :: Sort files by time and date.' +
      '  └───┐ │   │ ├──┬┘   │  '
    );
    s(
      ' ' + swch + 'V[erbose]    :: Sort files by filename.' +
      '       └───┘ └───┘ ┴  └─   ┴  '
    );
    s(
      ' ' + swch + 'Q Do not sort the files.' +
      ' (Some OS''s like OS/2 V2.x will sort anyhow)'
    );
    if _currows >= 40 then s('');
    if not(redirect) and (_currows < 40) then __delaykey(25000);
    s('');

    s(
      ' .  searches executables (COM EXE BAT CMD). ( Example:  w ../EXE/. )'
    );
    s(
      ' ' + swch + '.            :: toggle the showing of . and .. directories.'
    );
    s(
      ' ' + swch + 'n            :: Other date form (1 ≤ n ≤ 4).'
    );
    s(
      ' ' + swch + 'C[olours]    :: Show colours (SET WCOLOURS=)  ' +
      '┌───┐ ┌───┐ ┌─┬─┐ ┬ ┌───┐ ┌┐  ┬'
    );
    s(
      ' ' + swch + 'D[irectory]  :: Show <DIR> and discsize.      ' +
      '│   │ ├───┘   │   │ │   │ │└─┐│'
    );
    s(
      ' ' + swch + 'F[ilesize]   :: Sum files and show disc size. ' +
      '└───┘ ┴       ┴   ┴ └───┘ ┴  └┘'
    );
    s(
      ' ' + swch + 'G f|u|n|d|t|p:: Free-Used-Number-Drive-Total-Path Footer' +
      ' construction.'
    );
    s(
      ' ' + swch + 'I[nfo]       :: Show Post/Ante meridiane sign.'
    );
    s(
      ' ' + swch + 'J            :: Show volume-lable or not.'
    );
    s(
      ' ' + swch + 'M[ultiple N] :: Main of filesize (multiples of 512)'
    );
    s(
      ' ' + swch + 'O[ther info] :: Show current date on commandline.'
    );
    s(
      ' ' + swch + 'P[ause]      :: Do not wait every ' + __num(_currows) +
      ' lines.'
    );
    s(
      ' ' + swch + 'U n where n=1:: lowcase;  n=2: upcase;  n=0 (default):' +
      ' OS filenames.'
    );
    s(
      ' ' + swch + 'W[ide]       :: Show more files on screen.     '
    );
    s(
      ' ' + swch + 'X[tended]    :: Information visible. (Numbered, long items)'
    );
    s(
      ' ' + swch + 'Y            :: do not add linefeeds with redirection ' +
      'to stdio.'
    );
    s(
      ' ' + swch + 'Z            :: debugmode for a complete trace of actions.'
    );
    s(
      ' ' + swch + 'S[ubtree]    :: Take entire subtree of directory.'
    );
    s(
      '   ' + swch + 'K kill tree scan when scanning subdirectories' +
      ' (only from root).'
    );
    s('');
    s(
      'Normally, you can use default colours. If you like, you can specify up' +
      ' to ' + __num(max_colours-2));
    s(
      'colours for extensions besides the first 4,' +
      'reserved for <DIR> <VOL> <INF> <STD>'
    );
    s(
      'SET WCOLOURS=DIR:4  VOL:3  INF:8  STD:7  ARC,ARJ,LZH,ZIP:14  EXE,ASM, ....'
    );
    write('Standard colours: ');
    for i := 1 to max_colours+1 do
      if attr_colours[i].colour <> attr_colours[i-1].colour then begin
        textcolour(attr_colours[i-1].colour); write(attr_colours[i-1].ext, ' ');
        textcolour(normalcolour);
      end;
    exitproc := oldexitproc;
    textcolour(normalcolour);
    halt(255);
  end; { help }





  procedure getparams;
  const
    show: array[boolean] of string[11] = ('Do not show', 'Show');
    allow: array[boolean] of string[12] = ('Do not allow', 'Allow');
    dont: array[boolean] of string[2] = ('No', 'Do');
    mani: array[0..2] of string[9] = ('Unchanged', 'Lowered', 'Uppered');

  begin
    if __checkstr(swch + 'switch', env, i, j) then begin
      tmp := __nw(copy(env, i, j-i)); swch := tmp[1];
      originalswitch := swch;
    end;

    if __checkstr(swch + '.', env, i, j) then begin
      toggle(nopointsdir);
      if debug then writeln(
        'Env: ', show[nopointsdir], ' the . and .. directories.'
      );
    end;
    if __checkstr(swch + 'z', env, i, j) then begin
      toggle(debug);
      if debug then writeln(
        '__DEBUG MODE ON__ Warning: environment debugmode!'
      );
    end;
    if __checkstr(swch + '1', env, i, j) then begin
      skind := 1;
      if debug then writeln('Env: Eurodate set.');
    end;
    if __checkstr(swch + '2', env, i, j) then begin
      skind := 2;
      if debug then writeln('Env: American date set.');
    end;
    if __checkstr(swch + '3', env, i, j) then begin
      skind := 3;
      if debug then writeln('Env: Text date set.');
    end;
    if __checkstr(swch + '4', env, i, j) then begin
      skind := 4;
      if debug then writeln('Env: Full text date set.');
    end;
    if __checkstr(swch + 'a', env, i, j) then begin
      toggle(condition_attrs.show_arc);
      if debug then writeln(
        'Env: ', show[condition_attrs.show_arc], ' Archive atrributed files.'
      );
    end;
    if __checkstr(swch + 'b', env, i, j) then begin
      toggle(condition_attrs.show_sys);
      if debug then writeln(
        'Env: ', show[condition_attrs.show_sys],
        ' Boot/System attributed files.'
      );
    end;
    if __checkstr(swch + 'c', env, i, j) then begin
      if debug then writeln(
        'Env: ', show[use_colours], ' colours.'
      );
      toggle(use_colours);
    end;
    if __checkstr(swch + 'd', env, i, j) then begin
      toggle(dir_report);
      if dir_report then findattribute := directory + only else
        findattribute := anyfile;
    end;
    if __checkstr(swch + 'e', env, i, j) then begin
      condition_attrs.sort_method := on_extension;
      if debug then writeln('Env: Sort files on extension.');
    end;

    if __checkstr(swch + 'f', env, i, j) then begin
      toggle(not_sum_only);
      if debug then writeln(
        'Env: ', show[not_sum_only], ' summation of bytes.'
      );
    end;
    if __checkstr(swch + 'h', env, i, j) then begin
      toggle(condition_attrs.show_hid);
      if debug then writeln(
        'Env: ', show[condition_attrs.show_hid], ' Hidden attributed files.'
      );
    end;
    if __checkstr(swch + 'i', env, i, j) then begin
      toggle(ampm);
      if debug then writeln('Env: ', show[ampm], ' AmPm designator.');
    end;
    if __checkstr(swch + 'j', env, i, j) then begin
      if debug then writeln(
        'Env: ', show[not condition_attrs.show_vol], ' volume-lable.'
      );
      toggle(condition_attrs.show_vol);
    end;
    if __checkstr(swch + 'k', env, i, j) then begin
      toggle(noscan);
      if debug then writeln('Env: Kill treescan for full volume, use file.');
    end;
    if __checkstr(swch + 'l', env, i, j) then begin
      condition_attrs.sort_method := on_size;
      if debug then writeln('Env: Sort files on size (fileLength).');
    end;
    if __checkstr(swch + 'm', env, i, j) then begin
      takemainsize := true; extended := true;
      mainsize := __str(__nw(copy(env, i, j-i)));
      if debug then writeln('Env: Take mainsize in Kbytes.');
    end;
    if __checkstr(swch + 'n', env, i, j) then begin
      if debug then writeln(
        'Env: ', show[condition_attrs.show_non], ' unattributed files.'
      );
      toggle(condition_attrs.show_non);
    end;
    if __checkstr(swch + 'o', env, i, j) then begin
      toggle(show_date);
      if debug then writeln(
        'Env: ', show[show_date], ' date as commandline header.'
      );
    end;
    if __checkstr(swch + 'p', env, i, j) then begin
      toggle(interrupted);
      if debug then writeln('Env: ', allow[interrupted], ' interruption.');
    end;

    if __checkstr(swch + 'q', env, i, j) then begin
      toggle(sort_items);
      if debug then writeln('Env: ', allow[sort_items], ' sorting files.');
    end;
    if __checkstr(swch + 'r', env, i, j) then begin
      toggle(condition_attrs.show_r_o);
      if debug then writeln(
        'Env: ', show[condition_attrs.show_r_o], ' ReadOnly attributed files.'
      );
    end;
    if __checkstr(swch + 's', env, i, j) then begin
      toggle(globaltree);
      if debug then writeln(
        'Env: ', dont[globaltree], 'Scan subtree of current directory.'
      );
    end;
    if __checkstr(swch + 't', env, i, j) then begin
      condition_attrs.sort_method := on_datetime;
      if debug then writeln('Env: Sort files on time and date.');
    end;
    if __checkstr(swch + 'u', env, i, j) then begin
      manipulate := __str(__nw(copy(env, i, j-i)));
      if debug then writeln(
        'Env: The case is ', mani[manipulate],
        '. (', i, ':', j, '|', copy(env, i, j-i), ')'
      );
      if manipulate = 2 then manipulate := _to_upcase_str else
        if manipulate = 1 then manipulate := _to_lowcase_str else
          manipulate := 0;
    end;
    if __checkstr(swch + 'v', env, i, j) then begin
      condition_attrs.sort_method := on_name;
      if debug then writeln('Env: Sort files verbosely (on name).');
    end;
    if __checkstr(swch + 'w', env, i, j) then begin
      toggle(wide);
      if debug then writeln('Env: ', allow[wide], ' files to be shown in a wide manner.');
    end;
    if __checkstr(swch + 'x', env, i, j) then begin
      toggle(extended);
      if debug then writeln(
        'Env: ', dont[extended],
        'Extended information is to be shown. (' + swch + 'w may override)'
      );
    end;
    if __checkstr(swch + 'y', env, i, j) then begin
      redirect := false;
      if debug then writeln('Env: Redirection linefeeds removed.');
    end;

    if __checkstr(swch + 'g', env, i, j) then begin
      if (
        pos(upcase('p'), __up( copy(env, i, j-i) )) > 0
      ) then toggle(show_pad);
      if (
        pos(upcase('t'), __up( copy(env, i, j-i) )) > 0
      ) then toggle(greatness);
      if (
        pos(upcase('u'), __up( copy(env, i, j-i) )) > 0
      ) then toggle(show_sum);
      if (
        pos(upcase('d'), __up( copy(env, i, j-i) )) > 0
      ) then toggle(show_drv);
      if (
        pos(upcase('f'), __up( copy(env, i, j-i) )) > 0
      ) then toggle(freespace);
      if (
        pos(upcase('n'), __up( copy(env, i, j-i) )) > 0
      ) then toggle(show_num);
      if debug then writeln(
        'Env: ', allow[greatness], ' discsize to be calculated.'
      );
      if debug then writeln(
        'Env: ', allow[show_sum], ' filesummation to be calculated.'
      );
      if debug then writeln(
        'Env: ', allow[freespace], ' free discspace to be calculated.'
      );
      if debug then writeln(
        'Env: ', allow[show_num],
        ' number of files and directories to be calculated.'
      );
      if debug then writeln(
        'Env: ', allow[show_drv],
        ' Drive designator to be shown.'
      );
      if debug then writeln(
        'Env: ', allow[show_pad],
        ' Drive and path designators to be shown.'
      );
    end;

    {▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒ COMMANDLINE OVERRIDES ENVIRONMENT SETTINGS ▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒}

    if __inparams(swch + 'switch', i) then begin
      tmp := paramstr(i);
      writeln('Originalswitch     : -');
      writeln('Switch (Env)       : ', swch);
      swch := tmp[1];
      writeln('Switch (Cmd)       : ', swch);
    end;

    if __inparams(swch + '.', i) then begin
      toggle(nopointsdir);
      if debug then writeln(
        'Cmd: ', show[nopointsdir], ' the . and .. directories.'
      );
    end;
    if __inparams(swch + 'z', i) then begin
      toggle(debug);
      if debug then writeln('__DEBUG MODE ON__') else
        writeln('__DEBUG MODE OFF__  warning: environment debugmode!');
    end;
    if __inparams(swch + '1', i) then begin
      skind := 1;
      if debug then writeln('Cmd: Eurodate set');
    end;
    if __inparams(swch + '2', i) then begin
      skind := 2;
      if debug then writeln('Cmd: American date set');
    end;
    if __inparams(swch + '3', i) then begin
      skind := 3;
      if debug then writeln('Cmd: Text date set');
    end;
    if __inparams(swch + '4', i) then begin
      skind := 4;
      if debug then writeln('Cmd: Full text date set');
    end;

    if __inparams(swch + 'a', i) then begin
      toggle(condition_attrs.show_arc);
      if debug then writeln(
        'Cmd: ', show[condition_attrs.show_arc], ' Archive atrributed files.'
      );
    end;
    if __inparams(swch + 'b', i) then begin
      toggle(condition_attrs.show_sys);
      if debug then writeln(
        'Cmd: ', show[condition_attrs.show_sys],
        ' Boot/System attributed files.'
      );
    end;
    if __inparams(swch + 'c', i) then begin
      if debug then writeln(
        'Cmd: ', show[use_colours], ' colours.'
      );
      toggle(use_colours);
    end;
    if __inparams(swch + 'd', i) then begin
      toggle(dir_report);
      if dir_report then findattribute := directory + only else
        findattribute := anyfile;
    end;

    if __inparams(swch + 'e', i) then begin
      condition_attrs.sort_method := on_extension;
      if debug then writeln('Cmd: Sort files on extension.');
    end;

    if __inparams(swch + 'f', i) then begin
      toggle(not_sum_only);
      if debug then writeln(
        'Cmd: ', show[not_sum_only], ' summation of bytes.'
      );
    end;
    if __inparams(swch + 'g', i) then begin
      if pos(upcase('t'), __up(paramstr(i))) > 0 then toggle(greatness);
      if pos(upcase('u'), __up(paramstr(i))) > 0 then toggle(show_sum);
      if pos(upcase('p'), __up(paramstr(i))) > 0 then toggle(show_pad);
      if pos(upcase('d'), __up(paramstr(i))) > 0 then toggle(show_drv);
      if pos(upcase('f'), __up(paramstr(i))) > 0 then toggle(freespace);
      if pos(upcase('n'), __up(paramstr(i))) > 0 then toggle(show_num);
      if debug then writeln(
        'Cmd: ', allow[greatness], ' discsize to be calculated.'
      );
      if debug then writeln(
        'Cmd: ', allow[show_sum], ' filesummation to be calculated.'
      );
      if debug then writeln(
        'Cmd: ', allow[freespace], ' free discspace to be calculated.'
      );
      if debug then writeln(
        'Cmd: ', allow[show_num], ' number of files and directories to be calculated.'
      );
      if debug then writeln(
        'Cmd: ', allow[show_drv], ' Drive designator to be shown.'
      );
      if debug then writeln(
        'Cmd: ', allow[show_pad], ' Drive and path designators to be shown.'
      );
    end;
    if __inparams(swch + 'h', i) then begin
      toggle(condition_attrs.show_hid);
      if debug then writeln(
        'Cmd: ', show[condition_attrs.show_hid], ' Hidden attributed files'
      );
    end;
    if __inparams(swch + 'i', i) then begin
      toggle(ampm);
      if debug then writeln(
        'Cmd: ', show[ampm], ' AmPm designator.'
      );
    end;
    if __inparams(swch + 'j', i) then begin
      if debug then writeln(
        'Cmd: ', show[not condition_attrs.show_vol], ' volume-lable.'
      );
      toggle(condition_attrs.show_vol);
    end;
    if __inparams(swch + 'k', i) then begin
      toggle(noscan);
      if debug then writeln(
        'Cmd: Kill treescan for full volume, use file.'
      );
    end;
    if __inparams(swch + 'l', i) then begin
      condition_attrs.sort_method := on_size;
      if debug then writeln('Cmd: Sort files on size (fileLength)');
    end;
    if __inparams(swch + 'm', i) then begin
      begin takemainsize := true; mainsize := __str(paramstr(i)) end;
      if debug then writeln('Cmd: Take mainsize in Kbytes.');
    end;
    if __inparams(swch + 'n', i) then begin
      toggle(condition_attrs.show_non);
      if debug then writeln(
        'Cmd: ', show[condition_attrs.show_r_o], ' ReadOnly attributed files'
      );
    end;
    if __inparams(swch + 'o', i) then begin
      toggle(show_date);
      if debug then writeln(
        'Cmd: ', show[show_date], ' date as commandline header.'
      );
    end;
    if __inparams(swch + 'p', i) then begin
      toggle(interrupted);
      if debug then writeln(
        'Cmd: ', allow[interrupted], ' interruption.'
      );
    end;
    if __inparams(swch + 'q', i) then begin
      toggle(sort_items);
      if debug then writeln('Cmd: ', allow[sort_items], ' sorting files.');
    end;
    if __inparams(swch + 'r', i) then begin
      toggle(condition_attrs.show_r_o);
      if debug then writeln(
        'Cmd: ', show[condition_attrs.show_r_o], ' ReadOnly attributed files.'
      );
    end;
    if __inparams(swch + 's', i) then begin
      toggle(globaltree);
      if debug then writeln(
        'Cmd: ', dont[globaltree], ' scan subtree of current directory.'
      );
    end;
    if __inparams(swch + 't', i) then begin
      condition_attrs.sort_method := on_datetime;
      if debug then writeln('Cmd: Sort files on time and date.');
    end;
    if __inparams(swch + 'u', i) then begin
      manipulate := __str(paramstr(i));
      if debug then writeln('Cmd: The case is ', mani[manipulate], '.');
      if manipulate = 2 then manipulate := _to_upcase_str else
        if manipulate = 1 then manipulate := _to_lowcase_str else
          manipulate := 0;
    end;
    if __inparams(swch + 'v', i) then begin
      condition_attrs.sort_method := on_name;
      if debug then writeln('Cmd: Sort files verbosely (on name).');
    end;
    if __inparams(swch + 'w', i) then begin
      toggle(wide);
      if debug then writeln(
        'Cmd: ', allow[wide], ' files to be shown in a wide manner.'
      );
    end;
    if __inparams(swch + 'x', i) then begin
      toggle(extended);
      if debug then writeln(
        'Cmd: ', dont[extended], 'Extended information to be shown. (' + swch + 'w may override)'
      );
    end;
    if __inparams(swch + 'y', i) then begin
      redirect := false;
      if debug then writeln('Cmd: Redirection linefeeds removed.');
    end;
  end;



  function first_is_param(s: string): boolean;
  var swch : char;
  begin
    swch := originalswitch;
    {
      if we get here, the swicthchar may have been altered,
      so we match against the original switch, the logic of which is,
      that in order to alter the switchchar, the option that enables
      this function is switched itself, with a standard switchchar, after
      which usage, the testing will not work anymore
    }
    first_is_param := (
      { debugging or help }
      __comp(s, swch + '?') or __comp(s, swch + 'switch') or (
      { normal options }
        (upcase(s[2]) in ['1'..'4', 'A'..'Z']) and (s[1] = swch) and
        (length(__nw(s))=2)
      ) or (
        __comp(s, swch + '.')
      )
    )
  end;






  function __retrievecolour(re: searchrec): byte;
  var t : byte;
  begin
    __retrievecolour := normalcolour;
    if use_colours then begin
      if __attrfilter(
        re.attr, directory + only
      ) then __retrievecolour := attr_colours[0].colour else
        if __attrfilter(
          re.attr, volumeid + only
        ) then __retrievecolour := attr_colours[1].colour else if not(
          __nonascii(re.name) or (__extractext(re.name) = '')
        ) then begin
          for t := 4 to max_colours_env do if __comp(
            __extractext(re.name), attr_colours[t].ext
          ) then __retrievecolour := attr_colours[t].colour;
        end;
    end;
  end;


  procedure checkintr(line, j: word);
  begin
    if redirectpressed then begin
      textcolour(yellow);
      if use_colours then textbackground(blue);
      write('(PRESS)');
      readkey; readkey;
      write(__rep(7, #8));
      textcolour(normalcolour);
      if use_colours then textbackground(black);
      write(__rep(7, ' '), __rep(7, #8));
    end else if not(redirect) and interrupted and (
      (j = 0) or (j = cols-1)
    ) and (
      (
        (line mod (_currows-1) = 0) and
        not globaltree
      ) or (
        (
          (totlin >= _currows-1)
        ) and globaltree and (totlin > 0)
      )
    ) then begin
      textcolour(yellow); totlin := 0;
      if use_colours then textbackground(blue);
      write('(PRESS)');
      readkey;
      write(__rep(7, #8));
      textcolour(normalcolour);
      if use_colours then textbackground(black);
      write(__rep(7, ' '), __rep(7, #8));
    end;
  end;



  procedure widedispline(i: word);
  var k : word;
  begin
    j := 0;
    while (j < cols) do begin
      k := i + (j * coll);
      textcolour(__retrievecolour(filarray^[k]^));
      if not (
        __nonascii(filarray^[k]^.name)
      ) then begin
        if (
          ((filarray^[k]^.attr and directory) > 0)
        ) and (
          __nw(filarray^[k]^.name) <> ''
        ) then write(
          __juststr(
            '[' + filarray^[k]^.name + ']',
            ' ', 16, _left_just_str
          )
        ) else if (
          ((filarray^[k]^.attr and volumeid) > 0)
        ) and (
          __nw(filarray^[k]^.name) <> ''
        ) then write(
          __juststr(
            '{' + __rempoint(filarray^[k]^.name) + '}',
            ' ', 16, _left_just_str
          )
        ) else if true or (__nw(filarray^[k]^.name) <> '') then write(
          __juststr(filarray^[k]^.name, ' ', 16, _left_just_str)
        );
      end else write(' ' : 16);
      inc(j); checkintr(i, j);
      textcolour(normalcolour);
    end;
    if redirect then writeln;
    {
      if redirect then linefeed after line:
      con does it automatically, file does not
    }
  end;




  procedure processdirectory(search: string);
  var colnr : word;
  begin
    if debug then write('Filitems:ColumnLen : ');
    if debug then write(filitems, ':'); colnr := _curcolumns div 16;
    i := 0; coll := (filitems div colnr);
    if filitems mod colnr <> 0 then inc(coll);
    if debug then writeln(coll);

    if wide then begin
      if not_sum_only then for i := 1 to coll do begin
        widedispline(i); inc(totlin);
      end;
    end else begin
      if not_sum_only then for i := 1 to filitems do begin
        inc(totlin);
        st := __searchrec(
          {srec} filarray^[i]^,
          {numb} i,
          {kind} skind,
          {main} mainsize,
          {take} false,
          {extn} extended,  { size in K, number }
          {ampm} ampm,
          {attr} true,
          {wide} wide
        );
        if extended then j := 4 else j := 1;
        write(__part(st, 1, j));
        textcolour(__retrievecolour(filarray^[i]^));
        write(__part(st, j, j+13));
        textcolour(normalcolour);
        write(__part(st, j+14, length(st)));
        checkintr(i, 0);
        writeln;
      end;
      writeln;
    end;
    totgen := totgen + tot;
  end;



  procedure errorhandler(number, adres:integer);
  begin
    chdir(olddospath); exitproc := oldexitproc;
    textbackground(0);
    if debug then begin
      writeln('Files: ', filitems, '  Mem: ', maxavail);
    end;
    writeln('*user break*'); halt
  end; { errorhandler }



  {$F+}
  function dir_condition(var srec): boolean;
  begin
    with std_condition_attrs do dir_condition := (
      ((searchrec(srec).attr and volumeid ) > 0) or
      ((searchrec(srec).attr and directory) > 0)
    ) and not (
      nopointsdir and (
        (searchrec(srec).name = '.') or
        (searchrec(srec).name = '..')
      )
    );
  end; { dir_conditio }



  function new_condition(var srec): boolean;
  begin
    new_condition := (
      std_condition(searchrec(srec)) and not(
        (searchrec(srec).name = '.') or
        (searchrec(srec).name = '..')
      )
    );
  end; { new_condition }



  procedure parse_colour_string(s: string);
  var
    t, tt, mx,
    i, k, col :                 word;
    tmp       : attr_colours_type_ar;

  begin
    if debug then begin
      writeln('Standard Colours: ');
      for i := 1 to max_colours do begin
        textcolour(attr_colours[i].colour);
        write(attr_colours[i].ext + ' ');
      end;
      textcolour(normalcolour); writeln;
    end;
    if s <> '' then begin
      {
        de idee:
        we lopen met `t' door de range
        `tt' is het vorige begin van t, zodat we de sub-range kennen, om
        later in een batch de kleur aan toe te kennen.
        `i' en `j' worden de lopende variables in de te parsen string `s'
      }
      t := 0; j := 1; mx := length(s)+1;
      if debug then begin
        writeln(s, '  ', mx);
        writeln('123456789-123456789-123456789-123456789-123456789-123');
      end;
      { dir:12 vol: 13 arc,arj,lzh,zip,zoo:14 txt,doc:15 }

      while (t < max_colours) and (j < mx) do begin
        tt := t;
        while (s[j] <> ':') and (j < mx) do begin
          i := j; { i op j zetten, en j laten lopen }
          while not(s[j] in [',', ':']) and (j < mx) do inc(j);
          { we hebben woord t }
          tmp[t].ext := __nw(__part(s, i, j-1));
          if debug then writeln(
            't=', t:2, ' tt=', tt:2, '  ', 'i=', i:2,
            ' "', __nw(__part(s, i, j-1)), '" ', '  j=', j:2
          );
          inc(t); if s[j] <> ':' then inc(j);
        end;
        { nu colon }
        inc(j); i := j; while (s[j] <> ' ') and (j < mx) do inc(j);
        { kleurcode }
        col := __str(__nw(__part(s, i , j)));
        if debug then begin
          textcolour(col);
          writeln(tmp[t-1].ext);
          textcolour(normalcolour);
        end;
        for k := tt to t do tmp[k].colour := col;
        inc(j);
      end;
      attr_colours := tmp;
    end; { s > '' }
    max_colours_env := t;
    if debug then writeln('New max_colours    : ', t);
    normalcolour := tmp[3].colour;
  end;






{main}begin
  redirect := not __isconfil(__handlfil(output)); findattribute := anyfile;
  swch := '-'; originalswitch := swch; max_colours_env := max_colours;

  { init }
  oldexitproc := exitproc; exitproc := @errorhandler;
  cols := _curcolumns div 16; mainsize := 1024;
  set_std_condition_attrs(condition_attrs); manipulate := 0;

  env := getenv('WDIR');
  colour_string := getenv('WCOLOURS');
  if __comp(colour_string, '') then colour_string := '';
  treeinfosource := getenv('WTREEINFO');

  skind := 3; totgen := 0;
  getparams;

  if __inparams(swch + '?', i) then help;
  if not greatness then packsize := 35;
  if colour_string <> '' then parse_colour_string(colour_string);
  if show_date then begin
    if not debug then gotoxy(1, wherey-1); clreol;
    textcolour(attr_colours[2].colour);
    write(__todaystr(false), '  ', __curdate);
    textcolour(normalcolour); writeln;
  end;

  { search expansion }
  searchpath := paramstr(1);

  if (__lastchr(searchpath) = '.') and not (
    searchpath[length(searchpath)-1] in ['.', swch]
  ) then comexebatcmdfilter := true;
  if comexebatcmdfilter then writeln('Executable filter:');
  searchpath := __normfil(searchpath);

  if first_is_param(paramstr(1)) or (paramcount = 0) then begin
    searchbasis := __normfil(__backapp(__curdir));
    searchpattern := '*.*';
  end else if (             { searchpath is specified }
    (pos('*', searchpath) = 0) and (pos('?', searchpath) = 0)
  ) then begin { no wildcard, so entire director(y/ies) }
    searchbasis := __normfil(__backapp(searchpath));
    searchpattern := '*.*';
  end else begin       { wildcards/pattern, so selection of director(y/ies) }
    searchbasis := __normfil(__backapp(__extractpath(searchpath)));
    searchpattern := __extractnamext(searchpath);
  end;


  if (swch <> '/') and (paramstr(1) = '/?') then writeln(
    'Help: ', __progname, ' ', swch,
    '?   (now searching ? in root of ' + upcase(searchbasis[1]) + ':)'
  );

  { dir expansion }
  set_std_condition_attrs(condition_attrs);

  {
    expressly after search, so in case path(1) = param(?),
    the path is evaluated first, and / trans to \, (therefore no param)
  }

  if not __existpath(__normfil(searchbasis)) then begin
    write('Path does not exist: "', searchpath, '"');
    exitproc := oldexitproc; halt(5);
  end else if (
    not(__findfil(__normfil(searchbasis+searchpattern), tmp)) and
    not(globaltree) and
    not(__existfil(__normfil(searchbasis+searchpattern)))
  ) then begin
    write('File does not exist: "', searchbasis, '"'); exitproc := oldexitproc; halt(2);
  end;

  olddospath := __curdir;
  chdir(__backrem(searchbasis));

  __drvparm(upcase(searchbasis[1]));


  if sort_items then sort_ptr := @std_sort else sort_ptr := nil;
  if dir_report then attr_ptr := @dir_condition else if
    nopointsdir then attr_ptr := @new_condition else
      attr_ptr := @std_condition;

  if debug then begin
    writeln('Environment        : "', env, '"');
    writeln('                   : "', colour_string, '"');
    write  ('Commandline        : "');
    for i := 1 to paramcount do write(paramstr(i), ' ');
    writeln('"');
    writeln('Switch (override)  : "', swch, '"');
    writeln('Sort pointer       : "', __ptr2str(sort_ptr), '"');
    writeln('Manipulate case    : "', manipulate, '"');
    writeln('Global tree        : "', globaltree, '"');
    writeln('Searchpath         : "', searchpath, '"');
    writeln('Searchbasis        : "', searchbasis, '"');
    writeln('Searchpattern      : "', searchpattern, '"');
  end;


  if globaltree then totlin := 2 else totlin := 1;
  if globaltree then begin { do it }
    write('Reading subtree...');
    if treeinfosource <> '' then
      treeinfodrivechar := upcase(treeinfosource[1]) else
      treeinfodrivechar := upcase(searchbasis[1]);
    drivechar := upcase(searchbasis[1]);

    if debug then writeln(treeinfodrivechar + treeinfofile + drivechar);
    if noscan and (length(searchbasis) < 4) {root} and __existfil(
      treeinfodrivechar + treeinfofile + drivechar
    ) then begin
      load_tree(treeinfodrivechar + treeinfofile + drivechar);
      writeln;
    end else begin
      trace_tree;
      if length(searchbasis) < 4 then save_tree(
        treeinfodrivechar + treeinfofile + drivechar
      );
    end;

    for nod := 0 to nodenumber-1 do begin
      new_filarray(filarray);
      filitems := 0; tot := 0;
      __dirutl(
        comexebatcmdfilter,
        __normfil(__backapp(searchbasis) + trace_path(nod)) + searchpattern,
        filarray,
        findattribute, manipulate, error, dirs, volum,
        attr_ptr,
        sort_ptr,
        tot
      );
      writeln(
        __cvtstr(
          __xlatestr(
            __normfil(
              __backapp(searchbasis + trace_path(nod))
            ) + searchpattern, '\', _dirslash
          ), manipulate
        ) + '  (' + __num(filitems) + ' : ' +
        __pntstr(tot) + ')'
      );
      processdirectory(
        __backrem(__normfil(__backapp(searchbasis) + trace_path(nod))) + searchpattern
      );
      dispose_filarray(filarray);
      if wherex > 1 then writeln;
      writeln;
      if wide then inc(totlin, 2) else inc(totlin, 3);
    end
  end else begin
    new_filarray(filarray);
    filitems := 0; tot := 0;
    __dirutl(
      comexebatcmdfilter,
      searchbasis + searchpattern, filarray,
      findattribute, manipulate, error, dirs, volum,
      attr_ptr,
      sort_ptr,
      tot
    );
    processdirectory(__normfil(searchbasis) + searchpattern);
    if wherex > 1 then writeln;

    if show_pad then show_drv := true;
    if show_drv then begin
      if show_pad then st := __slashfil(
        __packfil(__backrem(__curdir), packsize)
      ) else st := upcase(searchbasis[1]) + ':';
      if freespace or greatness then st := st + ' ';
    end else st := '';

    if greatness then begin
      st := st + 'T ' + __pntstr(_dosdiscsize) + ' ';
    end;
    if freespace then st := st + ' F ' + __pntstr(_dosdiscfree) + ' ';

    tmp := '';
    if show_sum then tmp := 'U ' + __pntstr(tot) + ' b ';
    if show_num then tmp := tmp + '[' +
      __pntstr(dirs) + '](' + __pntstr(filitems-dirs) + ')';

    if freespace or greatness then st := st + 'b';
    if freespace or greatness or show_sum then begin
      textcolour(attr_colours[2].colour);
      write(
        tmp, ' ' : (_curcolumns - length(st)-length(tmp)-1), st
      );
      textcolour(normalcolour); writeln;
    end;
    dispose_filarray(filarray);
  end;

  if globaltree then begin
    textcolour(attr_colours[2].colour);
    write(__pntstr(totgen));
    textcolour(normalcolour); writeln;
  end;
  chdir(olddospath);
  exitproc := oldexitproc;
{happy}end.