[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]

    {
    From: russell@alpha3.ersys.edmonton.ab.ca (Russell Schulz)

    >Can Someone tell me how the DOS program MORE works?

    dos does the redirection part.  more just reads from stdin -- readln(s);

    >I would really like to write a MORE replacement

    there are already a bunch of good ones.  ask archie for `less'.

    also, with this old code of mine, you can type `l80 filespec.*' or
    `dir |l80' as well.  it keeps everything in the lower 640k.
    }

    program l80;  {less-like program, 80-char limitation}

    uses
      dos,crt;

    const
      maxlines=24;
      botlinelen=70;
      blankstring='                                                     ';

    type
      ptr=^node;
      node=record
             line: string[79];
             next: ptr;
           end;

    var
      infile: text;
      ch: char;
      filename: string;
      line: string;
      toplineno: longint;
      prevtoplineno: longint;
      done: boolean;
      head, tail, prev, curr: ptr;
      topline, botline: ptr;
      numlines: longint;
      rep: longint;
      userep: longint;
      searchstr: string;
      dosearch: boolean;
      atend: boolean;
      refresh: boolean;
      scrollno: integer;
      doscroll: boolean;
      newtoplineno: longint;
      msg: string;
      filespec: string;
      temp: integer;
      savepos: pointer;
      i: integer;
      fileinfo: searchrec;

    procedure wipeline;

    begin
      write(^M,blankstring,^M);
    end;

    function expand(str: string): string;

    var
      work: string[79];
      i,j: integer;

    begin
      if (pos(^I,str)=0) and (pos(^J,str)=0) and (pos('_',str)=0) then
        expand := str
      else
        begin
          work := '';
          i := 1;
          while i<=length(str) do
            begin
              if str[i]=^I then
                for j := 1 to 8-(length(work) and 7) do
                  work := work+' '
              else
                if (length(str)>i) and (str[i] in ['_',^H,#127]) and
                  (str[i+1] in ['_',^H,#127]) and not
                  ((str[i]='_') and (str[i+1]='_')) then
                  inc(i)
                else
                  if str[i]<>^J then
                    work := work+str[i];
             inc(i);
            end;
          expand := work;
        end;
    end;

    function pline(p: ptr): string;

    begin
      if p=nil then
        pline := '~'
      else
        pline := p^.line;
    end;

    procedure add(var head,tail: ptr; line: string);

    var
      n: ptr;

    begin
      new(n);
      n^.line := expand(line);
      n^.next := nil;
      if head=nil then
        head := n;
      if tail<>nil then
        tail^.next := n;
      tail := n;
      inc(numlines);
    end;

    function lookup(aline: integer): ptr;

    var
      curr: ptr;

    begin
      if aline>=numlines then
        lookup := tail
      else if aline<1 then
        lookup := head
      else
        begin
          curr := head;
          while aline>1 do
            begin
              dec(aline);
              curr := curr^.next;
            end;
          lookup := curr;
        end;
    end;

    function gets(var line: string): boolean;

    var
      tmp: integer;
      ch: char;
      valid: boolean;

    begin
      valid := true;
      line := '';
      write(^M,'/');
      repeat
        ch := readkey;
        if ch=^I then ch := ' ';
        if ch<>^M then
          if (ch=^H) and (line='') then
            valid := false
          else if ch=^H then
            begin
              if length(line)=1 then line := ''
              else line := copy(line,1,length(line)-1);
              write(ch,' ',ch);
            end
          else if length(line)<botlinelen then
            begin
              line := line+ch;
              write(ch);
            end;
      until (ch=^M) or not valid;
      wipeline;
      gets := valid;
    end;

    function isin(shortstr,longstr: string): boolean;

    begin
      isin := pos(shortstr,longstr)<>0;
    end;

    function searchf(var curr: ptr; var toplineno: longint): boolean;

    var
      tmp: ptr;
      lin: longint;
      found: boolean;
      awrap: boolean;

    begin
      found := false;
      awrap := false;
      prevtoplineno := toplineno;
      prev := curr;
      write('/');
      lin := toplineno;
      tmp := curr;
      if tmp<>nil then
        repeat
          if tmp^.next=nil then
            begin
              awrap := true;
              tmp := head;
              lin := 1;
            end
          else
            begin
              tmp := tmp^.next;
              inc(lin);
            end;
          if isin(searchstr,tmp^.line) then
            found := true;
        until found or (tmp=curr);
      if found then
        begin
          curr := tmp;
          toplineno := lin;
          scrollno := toplineno-prevtoplineno;
          if (scrollno>=0) and (scrollno<maxlines)
           and (prevtoplineno+scrollno<=numlines-maxlines+1) then
            begin
              curr := prev;
              toplineno := prevtoplineno;
              doscroll := true;
            end;
        end;
      if awrap then
        msg := '(wrap)';
      searchf := found;
      wipeline;
    end;

    procedure prtscreen(p: ptr);

    var
      lineat: integer;

    begin
      atend := false;
      lineat := 1;
      while lineat<=maxlines do
        begin
          inc(lineat);
          if p=nil then
            begin
              writeln('~');
              atend := true;
            end
          else
            begin
              writeln(pline(p));
              if lineat<=maxlines then
                p := p^.next;
            end;
        end;
      if (p=nil) or (p^.next=nil) then atend := true;
      botline := p;
    end;

    procedure scroll(scrollno: integer);

    var
      lineat: integer;

    begin
      atend := false;
      lineat := 1;
      while lineat<=scrollno do
        begin
          inc(lineat);
          if botline=nil then
            begin
              writeln('~');
              atend := true;
            end
          else
            begin
              botline := botline^.next;
              writeln(pline(botline));
            end;
          if topline<>nil then
            begin
              topline := topline^.next;
              inc(toplineno);
            end;
        end;
      if botline=nil then atend := true;
    end;

    function inrange(n: longint): longint;

    begin
      if n<1 then inrange := 1
      else if n>numlines then inrange := numlines
      else inrange := n;
    end;

    procedure showfile(filename: string);

    begin
      assign(infile,filename);
      {$I-}
      reset(infile);
      {$I+}
      if IOResult<>0 then
        begin
          writeln('error opening ''',filename,'''');
          halt;
        end;
      head := nil;
      tail := nil;
      numlines := 0;
      searchstr := '';
      msg := '';
      while not eof(infile) do
        begin
          readln(infile,line);
          add(head,tail,line);
        end;
      close(infile);
      toplineno := 1;
      done := false;
      topline := head;
      prev := nil;
      refresh := true;
      doscroll := false;
      while not done do
        begin
          if doscroll then
            scroll(scrollno)
          else if refresh then
            prtscreen(topline);
          refresh := true;
          doscroll := false;
          write(^M,'          ',msg);
          msg := '';
          if atend then
            write(^M,'--END--')
          else
            write(^M,'--L80--');
          rep := 0;
          prevtoplineno := toplineno;
          repeat
            repeat
              ch := readkey;
            until ch in [^M,'j','q',' ','G','0'..'9',^G,'b','u','/','n'];
            if (ch in ['0'..'9']) and (rep<maxlongint div 10) then
              rep := rep*10+ord(ch)-ord('0')
            else if ch=^G then
              begin
                wipeline;
                write('''',filename,''': ');
                newtoplineno := inrange(toplineno+maxlines);
                write('line ',newtoplineno:0,' of ',numlines:0,' ');
                if numlines=0 then
                  write('--100%--')
                else
                  write('--',100*newtoplineno div numlines:0,'%','--');
              end
            else
              begin
                wipeline;
                if rep=0 then
                  userep := 1
                else
                  userep := rep;
                case ch of
                  'q': done := true;
                  ' ':
                    begin
                      newtoplineno := inrange(toplineno+maxlines*userep);
                      if newtoplineno=toplineno then
                        refresh := false
                      else
                        begin
                          topline := lookup(newtoplineno);
                          toplineno := newtoplineno;
                        end;
                    end;
                  ^M,'j':
                    begin
                      newtoplineno := inrange(toplineno+userep);
                      if newtoplineno=toplineno then
                        refresh := false
                      else
                        if userep<maxlines then
                          begin
                            doscroll := true;
                            scrollno := userep;
                          end
                        else
                          begin
                            topline := lookup(newtoplineno);
                            toplineno := newtoplineno;
                          end;
                    end;
                  'G', 'b', 'u':
                    begin
                      if ch='G' then
                        begin
                          newtoplineno := rep;
                          if (newtoplineno>numlines-maxlines)
                           or (newtoplineno<1) then
                            newtoplineno := numlines-maxlines+1;
                        end
                      else
                        newtoplineno := inrange(toplineno-maxlines*userep);
                      topline := lookup(newtoplineno);
                      toplineno := newtoplineno;
                    end;
                  '/', 'n':
                    begin
                    line := '';
                    if (ch='n') or gets(line) then
                      begin
                        dosearch := true;
                        if line='' then
                          if searchstr='' then
                            begin
                              msg := 'no previous string';
                              dosearch := false;
                              refresh := false;
                            end;
                        if line<>'' then
                          searchstr := line;
                        if dosearch then
                          if not searchf(topline,toplineno) then
                            begin
                              msg := 'not found';
                              refresh := false;
                            end;
                      end;
                    end;
                  end;
              end;
          until ch in [^M, 'j', 'q', ' ', 'G', 'b', '/', 'n', 'u'];
        end;
    end;

    begin
      if paramcount>0 then
        if paramstr(1)='-?' then
          begin
            writeln('usage: l80 {filename}');
            halt;
          end;

      mark(savepos);

      if paramcount=0 then
        showfile('')
      else
        begin
          for i := 1 to paramcount do
            begin
              filespec := paramstr(i);
              findfirst(filespec,archive,fileinfo);
              temp:=length(filespec);
              repeat
                dec(temp);
              until (filespec[temp]='\') or (filespec[temp]=':') or (temp=1);
              if (pos('\',filespec)=0) and (pos(':',filespec)=0) then
                filespec:=''
              else
                filespec:=copy(filespec,1,temp);
              while doserror=0 do
                begin
                  release(savepos);
                  showfile(concat(filespec,fileinfo.name));
                  findnext(fileinfo);
                end;
            end;
        end;
    end.

[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]