Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBBS/eco_fido.pas

Pascal/Delphi Source File | 1992-03-21 | 14.3 KB | 487 lines

(*
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   Unit was conceived, designed and written         ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII by EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
*)
unit eco_fido;
interface
uses
  eco_lib, dos

  ;

type
  netmsg = record        { netmessage record structure }
    from,
    too        : string[35];
    subject    : string[71];
    date       : string[19];
    timesread,
    destnode,
    orignode,
    cost,
    orignet,
    destnet,
    replyto,
    attr,
    nextreply  :       word;
    areaname   : string[20];
  end;

  pkthdr = record        { packet hdr of packet }
    orignode,
    destnode,
    year,
    month,
    day,
    hour,
    minute,
    second,
    baud,
    orignet,
    destnet  : word;
  end;

  pktmessage = record        { packet hdr of each individual message }
    orignode,
    destnode,
    orignet,
    destnet,
    attr,
    cost        :       word;
    date        : string[19];
    too         : string[35];
    from        : string[35];
    subject     : string[71];
    areaname    : string[20];
  end;

  archivename = record        { internal record structure used for     }
    mynet,                    { determining the name of of an echomail }
    mynode,                   { archive. i.e. 00fa1fd3.mo1             }
    hisnet,
    hisnode     : word;
  end;


const                        { attribute flags }
  _private  = $0001;
  _crash    = $0002;
  _recvd    = $0004;
  _sent     = $0008;
  _file     = $0010;
  _forward  = $0020;     { also know as in-transit }
  _orphan   = $0040;
  _killsent = $0080;
  _local    = $0100;
  _hold     = $0200;
  _freq     = $0800;

  months    : array[1..12] of string[3] = (
    'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'
  );


var
  net    :      netmsg;
  ph     :      pkthdr;
  pm     :  pktmessage;
  arcn   : archivename;


  function  __fpktname                                      :  string;
  function  __fpktmsg                                       :  string;
  function  __fpkthdr                                       :  string;
  function  __fnetmsg                                       :  string;
  function  __fgetnet(gn: string)                           :  string;
  function  __fgetnode(gn: string)                          :  string;
  function  __fmsgdatestamp                                 :  string;
  function  __flastmsgnum(_netpath: string)                 : integer;
  function  __fhex(n : word)                                :  string;
  function  __farcname                                      :  string;
  procedure __fexpnodenum(var list: string; var totalnumber: integer);
  procedure __fcvtnetnode(netnode: string; var net, node: word);






implementation







  function last(n: byte; str: string): string;
  var temp: string;
  begin
    if (
      n > length(str)
    ) then temp := str else temp := copy(str, succ(length(str) - n), n);
    last := temp;
  end;  {func last}




  function wordcnt(str: string): byte;
  var
    w, i       : integer;
    spacebefore: boolean;
  begin
    if str = '' then begin wordcnt := 0; exit end;
    spacebefore := true; w := 0;
    for  i :=  1 to length(str) do begin
      if spacebefore and (str[i] <> ' ') then begin
        w := succ(w); spacebefore := false;
      end else if (
        spacebefore = false) and (str[i] = ' '
      ) then spacebefore := true;
    end;
    wordcnt := w;
  end;



  function locword(startat, wordno: byte;str: string): byte;
  {local proc used by posword and extract word}
  var
    w, l        : integer;
    spacebefore: boolean;

  begin
    if (str = '') or (wordno < 1) or (startat > length(str)) then begin
      locword := 0; exit
    end;
    spacebefore := true;
    w := 0; l := length(str);
    startat := pred(startat);
    while (w < wordno) and (startat <= length(str)) do begin
      startat := succ(startat);
      if spacebefore and (str[startat] <> ' ') then begin
        w := succ(w); spacebefore := false;
      end else if (
        (spacebefore = false) and (str[startat] = ' ')
      ) then spacebefore := true;
    end;
    if w = wordno then locword := startat else locword := 0;
  end;



  function extractwords(startword, nowords: byte; st: string): string;
  var start, finish: integer;
  begin
    if st = '' then begin extractwords := ''; exit end;
    start := locword(1, startword, st);
    if start <> 0 then finish := locword(start, succ(nowords), st) else begin
      extractwords := ''; exit
    end;
    if finish <> 0 then repeat
      finish := pred(finish);
    until st[finish] <> ' ' else finish := length(st);
    extractwords := copy(st, start, succ(finish-start));
  end; {func extractwords}



  function __fpktname: string; { creates and returns a unique packet name }
  var
    h, m, s, hs    :   word;
    yr, mo, da, dow:   word;
    wrkstr      : string;

  begin
    wrkstr := ''; gettime(h, m, s, hs); getdate(yr, mo, da, dow);
    wrkstr := __juststr(__num(da), '0', 2, _right_just_str) +
      __juststr(__num(h), '0', 2, _right_just_str) +
      __juststr(__num(m), '0', 2, _right_just_str) +
      __juststr(__num(s), '0', 2, _right_just_str
    );
    __fpktname := wrkstr + '.PKT';
  end;




  function __fpktmsg: string;       { returns a packet msg hdr }
  var hdr: string;
  begin
    hdr := ''; { type #2 packets... type #1 is obsolete }
    with pm do hdr := #2#0  +
      chr(lo(orignode)) + chr(hi(orignode)) +
      chr(lo(destnode)) + chr(hi(destnode)) +
      chr(lo(orignet))  + chr(hi(orignet)) +
      chr(lo(destnet))  + chr(hi(destnet)) +
      chr(lo(attr))     + chr(hi(attr)) +
      chr(lo(cost))     + chr(hi(cost)) +
      date+#0 + too+#0 + from+#0 + subject+#0 +
      __cvtstr(pm.areaname, _to_upcase_str);
    __fpktmsg := hdr;
  end;



  function __fpkthdr: string;         { returns a packet hdr string }
  var hdr: string;
  begin
    hdr := '';
    with ph do hdr :=
      chr(lo(orignode)) + chr(hi(orignode)) +
      chr(lo(destnode)) + chr(hi(destnode)) +
      chr(lo(year))     + chr(hi(year)) +
      chr(lo(month))    + chr(hi(month)) +
      chr(lo(day))      + chr(hi(day)) +
      chr(lo(hour))     + chr(hi(hour)) +
      chr(lo(minute))   + chr(hi(minute)) +
      chr(lo(second))   + chr(hi(second)) +
      chr(lo(baud))     + chr(hi(baud)) +
      #2#0+
      chr(lo(orignet))  + chr(hi(orignet)) +
      chr(lo(destnet))  + chr(hi(destnet)) +
      #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0+
      #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0;  { null field fill space }
    __fpkthdr := hdr;
  end;


  function __fnetmsg: string; { returns a __fnetmsg hdr string }
  var hdr: string;
  begin
    hdr := ''; hdr := __juststr(net.from, #0, 36, _left_just_str);
    with net do hdr := hdr +
      __juststr(too, #0, 36, _left_just_str) +
      __juststr(subject, #0, 72, _left_just_str) +
      __juststr(date, ' ', 19, _right_just_str) + #0 +
      chr(lo(timesread)) + chr(hi(timesread)) +
      chr(lo(destnode))  + chr(hi(destnode)) +
      chr(lo(orignode))  + chr(hi(orignode)) +
      chr(lo(cost))      + chr(hi(cost)) +
      chr(lo(orignet))   + chr(hi(orignet)) +
      chr(lo(destnet))   + chr(hi(destnet)) +
      #0#0#0#0#0#0#0#0 +
      chr(lo(replyto))   + chr(hi(replyto)) +
      chr(lo(attr))      + chr(hi(attr)) +
      chr(lo(nextreply)) + chr(hi(nextreply)) +
      __cvtstr(areaname, _to_upcase_str);
    __fnetmsg := hdr;
  end;



  function __fmsgdatestamp: string; { creates fido std- 01 jan 89 21: 05: 18 }
  var
    h, m, s, hs         :   word;    { standard msg hdr time/date stamp   }
    y, mo, d, dow       :   word;
    tmp,
    o1, o2, o3         : string;

  begin
    o1 := '';  o2 := '';  o3 := '';  tmp := '';
    getdate(y, mo, d, dow);  gettime(h, m, s, hs);
    o1 := __juststr(__num(d), '0', 2, _right_just_str);
    o2 := months[mo];
    o3 := last(2, __num(y));
    tmp := concat( o1, ' ', o2, ' ', o3, '  ');
    o1 := __juststr(__num(h), '0', 2, _right_just_str);
    o2 := __juststr(__num(m), '0', 2, _right_just_str);
    o3 := __juststr(__num(s), '0', 2, _right_just_str);
    tmp := tmp + concat(o1, ': ', o2, ': ', o3);
    __fmsgdatestamp := tmp;
  end;



  function first(n: byte; st: string): string;
  var temp: string;
  begin
    if n > length(st) then temp := st else temp := copy(st, 1, n);
    first := temp;
  end;  {func first}



  function msgtonum(fnm: string): integer; { used internally by __flastmsgnum }
  var p: byte;
  begin
    p := pos('.', fnm); fnm := first(p-1, fnm); msgtonum := __str(fnm);
  end;



  function __flastmsgnum(_netpath: string): integer;
  { returns the highest numbered xxx.msg in netpath directory }
  var
    _path  :    string;
    temp1,
    temp2  :    string;
    len    :      byte;
    dxirinf: searchrec;
    num,
    num1   :   integer;

  begin
    num := 0; num1 := 0; temp1 := ''; temp2 := ''; _path := '';
    _path := __backapp(_netpath) + '*.MSG';
    findfirst(_path, archive, dxirinf);
    while doserror=0 do begin
      temp1 := dxirinf.name; num1 := msgtonum(temp1);
      if num1 > num then num := num1; findnext(dxirinf);
    end;
    if num = 0 then num := 1;
    __flastmsgnum := num;
  end;




  function __fhex(n: word): string;
  { converts an integer or word to it's __fhex equivelent }
  var
    l        : string[16];
    bhi, blo :       byte;

  begin
    l := '0123456789ABCDEF'; bhi := hi(n); blo := lo(n);
    __fhex := (
      copy(l, succ(bhi shr 04), 1) +
      copy(l, succ(bhi and 15), 1) +
      copy(l, succ(blo shr 04), 1) +
      copy(l, succ(blo and 15), 1)
    );
  end;


{@}
  function __farcname: string;
  { returns the proper name of an echomail archive }
  var c1, c2: longint;
  begin
    c1 := 0; c2 := 0;
    c1 := arcn.mynet - arcn.hisnet;
    c2 := arcn.mynode - arcn.hisnode;
    if c1 < 0 then c1 := 65535 + c1;
    if c2 < 0 then c2 := 65535 + c2;
    __farcname := __fhex(c1) + __fhex(c2);
  end;



  function __fgetnet(gn: string): string;
  { returns the net portion of a net/node string }
  var p: byte;
  begin
    p := pos('/', gn); __fgetnet := first(p-1, gn);
  end;



  function __fgetnode( gn: string ): string;
  { returns the node portion of a net/node string }
  var p: byte;
  begin
    p := pos('/', gn); __fgetnode := last(length(gn)-p, gn);
  end;



  function strip(l, c: char; st: string): string;
  {l is left, center, right, all, ends}
  var i:  byte;
  begin
    case upcase(l) of
      'L': begin       {left}
        while (st[1] = c) and (length(st) > 0) do delete(st, 1, 1);
      end;
      'R': begin       {right}
        while (st[length(st)]=c) and (length(st)>0) do delete(st,length(st),1);
      end;
      'B': begin       {both left and right}
        while (st[1]=c) and (length(st) > 0) do delete(st, 1, 1);
        while (st[length(st)]=c) and (length(st)>0) do delete(st,length(st),1);
      end;
      'A': begin       {all}
        i := 1;
        repeat
          if (st[i]=c) and (length(st)>0) then delete(st, i, 1) else inc(i);
        until (i > length(st)) or (st = '');
      end;
    end; { case }
    strip := st;
  end;  { func }



  procedure __fexpnodenum(var list: string; var totalnumber: integer );
  { expands a list of short form node numbers to their proper       }
  { net/node representations. example:                              }
  { the string: 170/100 101 102 5 114/12 15 17 166/225 226          }
  { would return: 170/100 170/101 170/102 170/5 114/12 114/15 etc.. }
  var
    net, netnode : string[10];
    holdstr,
    ws1         :     string;
    n1          :    integer;
  begin
    net := ''; netnode := ''; holdstr := ''; ws1 := ''; n1 := 0;
    totalnumber := 0; totalnumber := wordcnt(list);
    for n1 := 1 to totalnumber do begin
      ws1 := extractwords(n1, 1, list);
      if pos('/', ws1) <> 0 then begin
        net := __fgetnet(ws1)+'/'; netnode := ws1;
      end else netnode := net+ws1;
      holdstr := holdstr + ' ' + strip('A', ' ', netnode);
    end;
  end;




  procedure __fcvtnetnode(netnode: string; var net, node: word);
  { returns net and node as words from a net/node string }
  var wstr: string[6];
  begin
    wstr := __fgetnet(netnode);  net  := __str(wstr);
    wstr := __fgetnode(netnode); node := __str(wstr);
  end;





begin
  { initialize the data structures }
  fillchar(net, sizeof(net), #0); fillchar(pm, sizeof(pm), #0);
  fillchar(ph, sizeof(ph), #0); fillchar(arcn, sizeof(arcn), #0);
end. { unit }



    { FIDONET UNIT by Kelly Drown, Copyright (C)1988, 89-LCP  }
    {                                   All rights reserved  }
    { If you use this unit in your own programming, I ask    }
    { only that you give me credit in your documentation.    }
    { I ask this instead of money. All of the following code }
    { is covered under the copyright of Laser Computing Co.  }
    { and may be used in your own programming provided the   }
    { terms above have been satisfactorily met.              }