Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBII/DEMOS/DEMO_FCS.PAS

Pascal/Delphi Source File | 1993-03-03 | 10.3 KB | 391 lines

{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
{$M 65520, 0, 655360}
uses
  crt, dos, eco_lib,
  eco_file, eco_tree,
  eco_swap

  ;



const
  nr_of_filekeys = 3;
  nr_of_treekeys = 3;

  einde         : boolean = false;
  pathprompt    : boolean = false;
  filesonly     : boolean =  true;
  startwithtree : boolean =  true;


  filesretkeys : array[1..nr_of_filekeys] of word = (
    _c_r { reread files }, _enter { action on file or dir }, _c_p { full }
  );
  rets : array[1..nr_of_treekeys] of word = (
    _space, { pad } _c_r, { treescan } _enter { confirmation }
  );



{tree}var
  buf          : array[1..4096] of char;
  oup          :                   text;
  checkdriv    :                   char;
  retkey,
  i, j         :                   word;
  call_editor,
  commandline,
  st           :                 string;
  tmpscn,
  backscreen   :           _scnimageptr;

  tree         :           treepanelobj;
  files        :          filespanelobj;




  procedure init_commander;
  var
    ch,
    swch : char;
  var
    st,
    environment_str : string;

  begin
    call_editor := 'ECO.COM';
    environment_str := __up(getenv('FCS_COMMANDER')); swch := '/';
    if environment_str <> '' then begin
      if __checkstr(swch + 'EDIT', environment_str, i, j) then begin
        call_editor := __part(environment_str, i, j)
      end;
      if __checkstr(swch + 'TREE', environment_str, i, j) then
        startwithtree := true;
      if __checkstr(swch + 'FILE', environment_str, i, j) then
        startwithtree := false;
      if __checkstr(swch + 'PROMPT', environment_str, i, j) then
        pathprompt := true;
      if __checkstr(swch + 'SORT', environment_str, i, j) then begin
        st := __part(environment_str, i, i);
        ch := upcase(st[1]);
        with files do case ch of
          'E': sort := 2;
          'D': sort := 3;
          'S': sort := 4;
          else sort := 1;
        end;
      end;
    end;
  end;



  procedure putfileopts;
  begin
    with files do setoptions(
      { fulwide }  false,
      { showpath } true,
      { boxtype }  0,
      54, 1, 80, 23,
      06, { panel_f,   }    00, { panel_b,    }
      15, { header_f,  }    00, { header_b,   }
      15, { footer_f,  }    00, { footer_b,   }
      true,
      50, 5, 70, 9,
      00, { popup_f,    }   07, { popup_b,    }
      15, { tagnocsr_f, }   00, { tagnocsr_b, }
      15, { tagcsr_f,   }   07, { tagcsr_b,   }
      00, { scrollbar_f,}   07, { scrollbar_b,}
      06, { curactbar_f,}   08  { curactbar_b }
    );
  end;



  procedure initfilespanel;
  begin
    with files do begin
      newfiloff := true; init; putfileopts; readfiles(__curdir); startsorting;
      { if not really altered by child process, that is: }
      {retagfiles(readconfig, @tempfiltagar);} { pointer to array of booleans }
      putfileopts;
    end;
  end;



  procedure showbackscreen;
  var
    tmpscn : _scnimageptr;
  begin
    new(tmpscn); __savscn(tmpscn);
    __resscn(backscreen);
    __retkey;
    __resscn(tmpscn); dispose(tmpscn);
  end;


  procedure execprog(progn: string);
  const
    swaploc : array[boolean] of string[7] = ('on disk', 'in EMS');
  var
    status :         word;

  begin
    useemsifavailable := true;
    if not initexecswap(heapptr, 'SWAP.$$$') then begin
      writeln('Unable to allocate swap space.');
    end else begin
      {write('Allocated ', bytesswapped, ' bytes ', swaploc[emsallocated]);}
      __savscn(tmpscn);
      __resscn(backscreen);
      gotoxy(1, 25); write('(' + __slashfil(__curdir) + ') ' + progn);
      clreol; writeln;
      swapvectors;
      status := execwithswap(getenv('COMSPEC'), ' /C ' + progn);
      swapvectors;
      writeln;
      __savscn(backscreen);
      {writeln('Exec status: ', status);}
      shutdownexecswap;
      __resscn(tmpscn);
    end;
  end;



  procedure __exec_commandline;
  var edit : _editctrl;
  begin
    with edit do begin
      _viewx1 := length(__curdir) + 4;
      _viewx2 := 80;
      _viewy1 := _currows;
      _vscnfore := brown;
      _vscnback := black;
      _vscncols := 127;
      _showflags := false;
      _mask := '';
    end;
    if __editline(commandline, edit) then begin
      execprog(commandline); commandline := ''
    end;
  end;



  procedure dofilespanel;
  begin
    with files do begin
      repeat
        retkey := $00;
        st := walk_files_(
          @filesretkeys, nr_of_filekeys, filesonly, retkey
        );
        if ((retkey = _enter) or (retkey = _padenter)) then begin
          if (
            (filarray^[filescursor].attr and directory) > 0
          ) then begin
            chdir(filarray^[filescursor+filoff].name);
            readfiles(__curdir); startsorting; filoff := 0; filescursor := 0;
            newfiloff := false;
            with tree do begin
              tree.jump_curpath; newtreeoff := true; tree.draw
            end;
            _doscurpath := __curdir;
            draw;
          end else begin
            if __comp(
              __extractext(filarray^[filescursor+filoff].name), 'pas'
            ) then execprog('T ' + filarray^[filescursor+filoff].name);
            if __comexebatcmdfilter(
              filarray^[filescursor+filoff].name
            ) then execprog(filarray^[filescursor+filoff].name)
          end;
        end;

        if retkey = _f3 then execprog(
          'FCV ' + filarray^[filescursor+filoff].name
        );

        if retkey = _f4 then begin
          execprog(
            call_editor + ' ' + filarray^[filescursor+filoff].name
          );
          readfiles(__curdir);
        end;

      until (
        (retkey = _a_q) or (retkey = _tab) or (retkey =_c_o) or
        (retkey = _backquote)
      );
    end; { with }
  end;



  procedure puttreeopts;
  begin
   with tree do begin
      setoptions(
        { auto }   false,
        { wide }   false,
        { path }   true,
        { boxt }   0,
        { xyxy }   1, 1, 53, 23,
        { panl }   6, black,
        { head }   yellow, black,
        { foot }   yellow, black,
        { scan }   true,
        { xyxy }   31, 10, 49, 11,
        { popu }   black, lightgray,
        { tgno }   black, lightgray,
        { tgcs }   lightblue, black,
        { tgsc }   black, lightgray,
        { curr }   brown, darkgray
      );
    end;
  end;


  procedure inittreepanel;
  begin
    st := getenv('WTREEINFO');
    if st = '' then st := __curdir;
    checkdriv := upcase(st[1]);
    with tree do begin
      init; putdefaults; puttreeopts;
      st := __curdir;
      drivechar := upcase(st[1]);
      horspace := '  '; horbar := '──';
      {writeln(checkdriv + treeinfofile + drivechar);}
      __savscn(scn1);
      if (paramstr(1)='/r') or not(__existfil(
        checkdriv + treeinfofile + drivechar)
      ) then begin
        __bandwin(true, 25, 9, 55, 12, 0, 7, sh_default, 0); trace_tree;
        save_tree(checkdriv + treeinfofile + drivechar);
      end else begin
        load_tree(checkdriv + treeinfofile + drivechar);
      end;
      build_tree(false); jump_curpath;
    end;
  end;




  procedure dotreepanel;
  var s : string;
  begin
    with tree do begin
      repeat
        retkey := 0;
        s := walk_tree_(@rets, nr_of_treekeys, retkey);

        if retkey = _c_e then begin
          assign(oup, 'tree.'+drivechar); rewrite(oup); settextbuf(oup, buf);
          for i := 0 to nodenumber-1 do writeln(oup, '   ' + nodedispptr^[i]);
          close(oup);
        end;

         if retkey = _c_c then begin
           jump_curpath; draw;
         end;

        if retkey = _c_p then begin
          widetree := not widetree; build_tree(true); newtreeoff := true;
          draw;
        end;

        if retkey = _c_f6 then increase_bar;

        if retkey = _c_f5 then decrease_bar;

        if retkey = _enter then begin
          if (
            __existpath(__backrem(__normfil(trace_path(walkcsr)))) or
            (__lastchr(__backrem(__normfil(s))) in _slashset)
            { backrem chops only trailing slashes from nonroot directories }
          ) then begin
            if (
              __lastchr(__backrem(__normfil(s))) in _slashset
            ) then chdir('\') else chdir(
              __backrem(__normfil(trace_path(walkcsr)))  { no slash on end }
            );
            _doscurpath := __curdir;
          end else begin
            newtreeoff := true;
            walkoffset := 0; walkcsr := 0;
            trace_tree; save_tree(treeinfofile);
            build_tree(true); chdir(drivechar+':\');
            retkey := 0;
          end;
          with files do begin
            readfiles(__curdir); startsorting; filoff := 0; filescursor := 0;
            newfiloff := true; draw;
          end;
        end;
      until (
        (retkey=_enter) or (retkey=_tab) or (retkey=_a_q) or (retkey =_c_o) or
        (retkey = _backquote)
      );
    end;
  end;



  procedure showpanels;
  begin
    tree.draw; files.draw;
  end;



type
  paneltype =(nopanel, treepanel, filespanel, infopanel);


var
  panel : paneltype;


begin
  __stdio; __cls; gotoxy(1, 25);  init_commander;
  writeln('The Fast Commander :: An Add-on Demo V 3.51.');
  write(
    'The ECO Library II Release 3.0  Version ',
    '6.02 Concise Edition - Pascal Port #2.'
  );
  if backscreen = nil then new(backscreen); __savscn(backscreen); new(tmpscn);
  inittreepanel; initfilespanel; showpanels;
  if startwithtree then panel := treepanel else panel := filespanel;

  retkey := __retkey; __clrscn(1, 24, 80, 25, 7, 0,' ');
  gotoxy(1, 25);
  if pathprompt then begin
    gotoxy(length(__curdir) + 4, 25);
    __write(1, 25, 7, 0, '(' + __slashfil(__curdir) + ') ');
  end;

  repeat
    case panel of
      filespanel: begin tree.draw; files.draw; dofilespanel end;
      treepanel : begin files.draw; tree.draw; dotreepanel end;
    end;
    if retkey = _tab then begin
      if panel = filespanel then
        panel := treepanel else
        panel := filespanel;
    end;
    if retkey = _a_q then einde := true;
    if retkey = _c_o then showbackscreen;
    if retkey = _backquote then __exec_commandline;
    retkey := $0000;
  until einde;

  __resscn(backscreen); dispose(backscreen); dispose(tmpscn);
end.