(*

    standard i/o library   (C) by Dai ISHIJIMA

    revision history
        1.0: Dec. 25, 1986 ( 1st version: "redirect.inc" )
        2.0: Jan. 20, 1987
        2.2: Feb. 18, 1987
        3.0: Mar.  7, 1987
        3.1: Mar. 11, 1987
        3.2: Apr.  5, 1987
        3.3: Nov. 13, 1987
        4.0: Dec. 30, 1987

    usage: {$I stdio.lib}

    CAUTION !!!
        You must write "openstd;" on the first line
        of your program.

    procedures and functions
        error(s: string);
        openf(var filvar: text;  filename: string; mode: char);
        exist(filename: string): boolean;
        chgname(oldname, newname: string);
        parmcnt: integer;
        parmstr(i: integer): integer;
        openstd;
        closestd;
        argc: integer;
        argv(i: integer): string;

*)

type
  _string = string[255];

var
  stdin:  text; { standard input file }
  stdout: text; { standard output file }
  stderr: text;
  cmdlin: string[255];
  argstr: string[255];


(* close stdin, stdout, stderr *)
procedure closestd;

  begin
    close(stdin);
    close(stdout);
    close(stderr);
  end; { of closestd }


(* file already exists on the disk? *)
function exist(filename: _string): boolean;

  var
    filvar: file;

  begin
    assign(filvar, filename);
    {$I-}
    reset(filvar);
    {$I+}
    if ioresult = 0 then
      exist := TRUE
    else
      exist := FALSE;
  end; { of exist }


(* exit to CP/M sytem *)
procedure exit(exitcode: integer);

  const
    BATFILE = '$$$.SUB';

  var
    f: file;

  begin
    if (exitcode <> 0) and (exist(BATFILE)) then
      begin
        assign(f, BATFILE);
        erase(f);
      end;
    closestd;
    halt;
  end; { of exit }


(* write error message on console & return CP/M *)
procedure error(s: _string);

  begin
    writeln(CON, s);
    exit(1);
  end; { of error }


(* open file *)
procedure openf(var fileptr; filename: _string; mode: char);

  const
    F_READ  = 'R';
    F_WRITE = 'W';

  var
    filvar: text absolute fileptr;

  begin
    assign(filvar, filename);
    {$I-}
    case upcase(mode) of
      F_READ:  reset(filvar);
      F_WRITE: rewrite(filvar);
    end;
    {$I+}
    if ioresult <> 0 then
      error(filename + ': Can''t open. ');
  end; { of openf }


(* rename file *)
procedure chgname(oldname, newname: _string);


  var
    oldfile, newfile: file;

  begin
    assign(oldfile, oldname);
    if exist(newname) then
      begin
        assign(newfile, newname);
        erase(newfile);
      end;
    rename(oldfile, newname);
  end; { of chgname }


(* get count of parameters *)
function parmcnt: integer;

  var
    cnt, pos: integer;
    inword: boolean;

  begin
    cnt := 0;
    inword := FALSE;
    for pos := 1 to length(cmdlin) do
      begin
        if cmdlin[pos] = ' ' then
          inword := FALSE
        else
          begin
            if inword = FALSE then
              cnt := cnt + 1;
            inword := TRUE
          end;
      end;
    parmcnt := cnt - 1;
  end; { of parmcnt }


(* get parameters *)
function parmstr(n: integer): _string;

  var
    cnt, pos, target: integer;

  begin
    if (n < 0) or (parmcnt < n) then
      parmstr := ''
    else
      begin
        pos := 1;
        while cmdlin[pos] = ' ' do
          pos := pos + 1;
        for cnt := 1 to n do
          begin
            while cmdlin[pos] <> ' ' do
              pos := pos + 1;
            while cmdlin[pos] = ' ' do
              pos := pos + 1;
          end;
        target := 0;
        while (
          cmdlin[pos + target] <> ' ') and ((target + pos) <= length(cmdlin)
        ) do
          target := target + 1;
        parmstr := copy(cmdlin, pos, target);
      end;
  end; { of parmstr }


(* open stdio & get command line parameters *)
procedure openstd;

  const
    BACKUP   = '.BAK';   { extention of backup file }
    F_READ   = 'R';
    F_WRITE  = 'W';
    F_APPEND = 'A';

  var
    infile:   string[255];
    outfile:  string[255];
    append:   string[255];
    prim:     string[255];
    second:   string[255];

  (* get command line from CCP *)
  procedure getcmdlin;

    const
      OFFSET = 8;

    var
      i: integer;
      ch: char;

    (* get ccp address *)
    function ccpadr: integer;

      const
        BIAS = $1600;

      begin
        ccpadr := mem[2] * 256 - BIAS;
      end; { of ccpadr }


    (* main of getcmdlin *)
    begin
      i := ccpadr + OFFSET;
      while mem[i] = ord(' ') do
        i := i + 1;
      while (mem[i] <> ord(' ')) and (mem[i] <> 0) do
        i := i + 1;
      while mem[i] = ord(' ') do
        i := i + 1;
      if (paramcount > 0) and (chr(mem[i]) <> copy(paramstr(1), 1, 1)) then
        begin
          cmdlin := 'Turbo-PASCAL';
          for i := 1 to paramcount do
            cmdlin := cmdlin + ' ' + paramstr(i);
        end
      else
        begin
          cmdlin := '';
          i := ccpadr + OFFSET;
          ch := chr(mem[i]);
          while ch <> chr(0) do
            begin
              cmdlin := cmdlin + ch;
              i := i + 1;
              ch := chr(mem[i]);
            end;
        end;
    end; { of getcmdlin }


  (* pipe line *)
  procedure pipe;

    const
      PIPEMARK = '|';
      BATFILE  = 'a:$$$.sub';
      TMPFIL1  = '%pipe00';
      TMPFIL2  = '.$$$';
      ERACMD   = 'era ';

    type
      nfile  = file;

    var
      fp: nfile;
      i: integer;


      (* get number of pipeline *)
      function pipecnt: integer;

        var
          pos, cnt: integer;

        begin
          cnt := 0;
          for pos := 1 to length(cmdlin) do
            begin
              if cmdlin[pos] = PIPEMARK then
                cnt := cnt + 1;
            end;
          pipecnt := cnt;
        end; { of pipecnt }


      (* get command string *)
      function getcmd(n: integer): _string;

        var
          pos, cnt: integer;
          work: string[255];

        begin
          pos := 1;
          for cnt := 1 to n - 1 do
            begin
              while cmdlin[pos] <> PIPEMARK do
                pos := pos + 1;
              pos := pos + 1;
            end;
          while cmdlin[pos] = ' ' do
            pos := pos + 1;
          work := '';
          while (cmdlin[pos] <> PIPEMARK) and (pos <= length(cmdlin)) do
            begin
              work := work + cmdlin[pos];
              pos := pos + 1;
            end;
          getcmd := work;
        end; { of getcmd }


      (* get tempolary file name *)
      function tempname(n: integer): _string;

        begin
          tempname := TMPFIL1 + chr(n + ord('0') ) + TMPFIL2;
        end; { of tempname }


      (* write to subfile *)
      procedure writecmd(var filvar: nfile; s: _string);

        const
          BUFLEN = 127;
          CPMEOF = $1A;

        var
          buffer: array[0..BUFLEN] of char;
          pos: integer;

        begin
          buffer[0] := chr(length(s));
          for pos := 1 to length(s) do
            buffer[pos] := s[pos];
          buffer[length(s) + 1] := chr(0);
          for pos := length(s) + 2 to BUFLEN do
            buffer[pos] := chr(CPMEOF);
          blockwrite(filvar, buffer, 1);
        end; { of writecmd }


    (* main of pipe *)
    begin
      if pipecnt > 0 then
        begin
          openf(fp, BATFILE, 'w');
          writecmd(fp, ERACMD + tempname(pipecnt));
          if getcmd(pipecnt + 1) = '' then
            error('Invalid null command')
          else
            writecmd(fp, getcmd(pipecnt + 1) + ' <' + tempname(pipecnt) );
          for i := pipecnt downto 2 do
            begin
              if getcmd(i) = '' then
                error('Invalid null command');
              writecmd(fp, ERACMD + tempname(i - 1) );
              writecmd(
                fp, getcmd(i) + ' < '+tempname(i - 1) + ' > ' + tempname(i)
              );
            end;
          close(fp);
          cmdlin := getcmd(1) + ' >' + tempname(1);
        end;
    end; { of pipe }


  (* get file name of backup file *)
  function backname(filename: _string): _string;

    var
      i, j: integer;

    begin
      i := pos(':', filename);
      j := pos('.', filename);
      if j = 0 then
        begin
          backname := copy(filename, 1, i + 8) + BACKUP;
        end
      else
        begin
          backname := copy(copy(filename, 1, j - 1), 1, i + 8) + BACKUP;
        end;
    end; { of getname }


  (* get open mode *)
  function openmode(s: _string): char;

    begin
      if s[1] = '<' then
        openmode := F_READ
      else if (s[1] = '>') and (s[2] <> '>') and (s[2] <> '<') then
        openmode := F_WRITE
      else if (s[1] = '>') and (s[2] = '>') then
        openmode := F_APPEND
      else
        openmode := ' ';
    end; { of openmode }


  (* check command line *)
  procedure checkargs;

    var
      cnt, pos: integer;
      mode: char;
      s:    _string;

    begin
      cnt := 1;
      while cnt <= parmcnt do
        begin
          s := parmstr(cnt);
          mode := openmode(s);
          if openmode(s) <> ' ' then
            begin
              pos := 1;
              while (s[pos] = '<') or (s[pos] = '>') do
                pos := pos + 1;
              delete(s, 1, pos - 1);
              if s = '' then
                begin
                  cnt := cnt + 1;
                  s := parmstr(cnt);
                end;
              case mode of
                F_READ:   begin
                            infile := s;
                          end;
                F_WRITE:  begin
                            outfile := s;
                            append := '';
                          end;
                F_APPEND: begin
                            outfile := '';
                            append := s;
                          end;
              end; { of case }
            end
          else
            argstr := argstr + ' ' + s;
          cnt := cnt + 1;
        end;
    end; { of checkargs }


  (* file copy for append *)
  procedure filcopy(filename: _string);

    var
      sourcef: text;
      ch: char;

    begin
      openf(sourcef, filename, 'r');
      while not eof(sourcef) do
        begin
          read(sourcef, ch);
          write(stdout, ch);
        end;
    end; { of filcopy }


  (* openstd main *)
  begin
    getcmdlin;
    pipe;
    argstr := parmstr(0);
    infile := 'TRM:';
    outfile := 'CON:';
    append := '';
    checkargs;
    openf(stderr, 'CON:', 'w');
    if infile = outfile then
      begin
        chgname(infile, backname(infile));
        infile := backname(infile);
      end;
    openf(stdin, infile, 'r');
    if outfile <> '' then
      begin
        if exist(outfile) then
          begin
            chgname(outfile, backname(outfile));
          end;
        openf(stdout, outfile, 'w');
      end
    else if append <> '' then
      begin
        if exist(append) then
          begin
            chgname(append, backname(append));
            openf(stdout, append, 'w');
            filcopy(backname(append));
          end
        else
         openf(stdout, append, 'w');
      end;
  end; { of openstd }


(* get count of arguments *)
function argc: integer;

  var
    cnt, pos: integer;
    inword: boolean;

  begin
    cnt := 0;
    inword := FALSE;
    for pos := 1 to length(argstr) do
      begin
        if argstr[pos] = ' ' then
          inword := FALSE
        else
          begin
            if inword = FALSE then
              cnt := cnt + 1;
            inword := TRUE;
          end;
      end;
    argc := cnt - 1;
  end; { of argc }


(* get arg *)
function argv(n: integer): _string;

  var
    cnt, pos, target: integer;

  begin
    if (n < 0) or (argc < n) then
      argv := ''
    else
      begin
        pos := 1;
        while argstr[pos] = ' ' do
          pos := pos + 1;
        for cnt := 1 to n do
          begin
            while argstr[pos] <> ' ' do
              pos := pos + 1;
            while argstr[pos] = ' ' do
              pos := pos + 1;
          end;
        target := 0;
        while (
          argstr[pos + target] <> ' ') and ((pos + target) <= length(argstr)
        ) do
          target := target + 1;
        argv := copy(argstr, pos, target);
      end;
  end; { of argv }


(* end of stdio.lib *)