Jason Aller Floppy Collection/270.img/FORUM25C.ZIP/GENSUBS.PAS

Pascal/Delphi Source File | 1988-12-27 | 6KB | 281 lines

{$R-,S-,I-,D-,V-,B-,N-,L- }
{$O-}

unit gensubs;


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

interface

uses dos,gentypes;

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


Function strr (n:integer):mstr;
Function streal (r:real):mstr;
Function strlong (l:longint):mstr;
Function valu (q:mstr):integer;
Function addrstr (p:pointer):sstr;
Procedure parse3 (s:lstr; VAR a,b,c:word);
Function packtime (VAR dt:datetime):longint;
    { Replaces Turbo's procedural version }
Function now:longint;
Function timestr (time:longint):sstr;
Function timeval (q:sstr):longint;
Function timepart (time:longint):longint;
Function datestr (time:longint):sstr;
Function dateval (q:sstr):longint;
Function datepart (time:longint):longint;
Function upstring (s:anystr):anystr;
Function match (s1,s2:anystr):boolean;
Function devicename (name:lstr):boolean;
Function exist (n:lstr):boolean;
Procedure appendfile (name:lstr; VAR q:text);


{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

implementation

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


type packedtimerec=record
       date,time:word
     end;

Function strr (n:integer):mstr;
VAR q:mstr;
begin
  str (n,q);
  strr:=q
end;

Function streal (r:real):mstr;
VAR q:mstr;
begin
  str (r:0:0,q);
  streal:=q
end;

Function strlong (l:longint):mstr;
VAR q:mstr;
begin
  str (l,q);
  strlong:=q
end;

Function valu (q:mstr):integer;
VAR i,s,pu:integer;
    r:real;
begin
  valu:=0;
  if length(q)=0 then exit;
  if not (q[1] in ['0'..'9','-']) then exit;
  if length(q)>5 then exit;
  val (q,r,s);
  if s<>0 then exit;
  if (r<=32767.0) and (r>=-32767.0)
    then valu:=round(r)
end;

Function addrstr (p:pointer):sstr;

  Function hexstr (n:integer):sstr;

    Function hexbytestr (b:byte):sstr;
    const hexchars:array[0..15] of char='0123456789ABCDEF';
    begin
      hexbytestr:=hexchars[b shr 4]+hexchars[b and 15]
    end;

  begin
    hexstr:=hexbytestr (hi(n))+hexbytestr(lo(n))
  end;

begin
  addrstr:=hexstr(seg(p^))+':'+hexstr(ofs(p^))
end;

Procedure parse3 (s:lstr; VAR a,b,c:word);
VAR p:integer;

  Procedure parse1 (VAR n:word);
  VAR ns:lstr;
  begin
    ns[0]:=#0;
    while (p<=length(s)) and (s[p] in ['0'..'9']) do begin
      ns:=ns+s[p];
      p:=p+1
    end;
    if length(ns)=0
      then n:=0
      else n:=valu(ns);
    if p<length(s) then p:=p+1
  end;

begin
  p:=1;
  parse1 (a);
  parse1 (b);
  parse1 (c)
end;

Function packtime (VAR dt:datetime):longint;
VAR l:longint;
begin
  dos.packtime (dt,l);
  packtime:=l
end;

Function now:longint;
VAR dt:datetime;
    t:word;
    l:longint;
begin
  gettime (dt.hour,dt.min,dt.sec,t);
  getdate (dt.year,dt.month,dt.day,t);
  l:=packtime (dt);
  now:=l
end;

Function timestr (time:longint):sstr;
VAR h1:integer;
    ms:sstr;
    dt:datetime;
const ampmstr:array [false..true] of string[2]=('am','pm');
begin
  unpacktime (time,dt);
  h1:=dt.hour;
  if h1=0
    then h1:=12
    else if h1>12
      then h1:=h1-12;
  ms:=strr(dt.min);
  if dt.min<10 then ms:='0'+ms;
  timestr:=strr(h1)+':'+ms+' '+ampmstr[dt.hour>11]
end;

Function datestr (time:longint):sstr;
VAR dt:datetime;
begin
  unpacktime (time,dt);
  datestr:=strr(dt.month)+'/'+strr(dt.day)+'/'+strr(dt.year-1900)
end;

Function timeval (q:sstr):longint;
VAR h1,t:word;
    k:char;
    dt:datetime;
begin
  parse3 (q,h1,dt.min,t);
  k:=upcase(q[length(q)-1]);
  if h1 in [1..11]
    then
      begin
        dt.hour:=h1;
        if k='P' then dt.hour:=dt.hour+12
      end
    else
      if k='P'
        then dt.hour:=12
        else dt.hour:=0;
  timeval:=packtime(dt)
end;

Function dateval (q:sstr):longint;
VAR dt:datetime;
begin
  parse3 (q,dt.month,dt.day,dt.year);
  if dt.year<100 then dt.year:=dt.year+1900;
  dateval:=packtime(dt)
end;

Function timepart (time:longint):longint;
begin
  timepart:=time and $0000ffff;
end;

Function datepart (time:longint):longint;
begin
  datepart:=time and $ffff0000;
end;

Function upstring (s:anystr):anystr;
VAR cnt:integer;
begin
  for cnt:=1 to length(s) do s[cnt]:=upcase(s[cnt]);
  upstring:=s
end;

Function match (s1,s2:anystr):boolean;
VAR cnt:integer;
begin
  match:=false;
  if length(s1)<>length(s2) then exit;
  for cnt:=1 to length(s1) do
    if upcase(s1[cnt])<>upcase(s2[cnt])
      then exit;
  match:=true
end;

Function devicename (name:lstr):boolean;
VAR f:file;
    n:integer absolute f;
    r:registers;
begin
  devicename:=false;
  assign (f,name);
  reset (f);
  if ioresult<>0 then exit;
  r.bx:=n;
  r.ax:=$4400;
  intr ($21,r);
  devicename:=(r.dx and 128)=128;
  close (f)
end;

Function exist (n:lstr):boolean;
VAR f:file;
    i:integer;
begin
  assign (f,n);
  reset (f);
  i:=ioresult;
  exist:=i=0;
  close (f);
  i:=ioresult
end;

Procedure appendfile (name:lstr; VAR q:text);
VAR n:integer;
    b:boolean;
    f:file of char;
begin
  close (q);
  n:=ioresult;
  assign (q,name);
  assign (f,name);
  reset (f);
  b:=(ioresult<>0) or (filesize(f)=0);
  close (f);
  n:=ioresult;
  if b
    then rewrite (q)
    else append (q)
end;



{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}

{initialization}

{/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\}


begin
end.