home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / filutl / ldiff12s.arc / MYTOOL.PAS < prev    next >
Pascal/Delphi Source File  |  1989-07-15  |  13KB  |  567 lines
  1. (*---------------------------------------------------------------------------*)
  2. (*mytool.pas ö─ùpè╓Éö               (C) ÄOû╪ÿaòF NIFTY SDR SDI00147 1989/2/12*)
  3. (*$B-,F-,I-,N-                                                               *)
  4. (*---------------------------------------------------------------------------*)
  5. UNIT MyTool;
  6.  
  7.  
  8. INTERFACE
  9.  
  10.  
  11. USES
  12.    Dos,
  13.    KErr,
  14.    MyType;
  15.  
  16.  
  17. CONST
  18.    KanjiCharSet  : CSet   = [#$81..#$9F,#$E0..#$FC];
  19.    ErrStr        : STRING = '';
  20. VAR
  21.    Regs          : Registers;
  22.    ERRF,OUTF,INF : Text;
  23.    SwitchChar    : Char;
  24.    PathDelim     : Char;
  25.  
  26.  
  27. FUNCTION  AscZ         (VAR _h):STRING;
  28. FUNCTION  Byte16Chr    (i:BYTE):CHAR;
  29. FUNCTION  Byte16Str    (i:WORD):Str2;
  30. FUNCTION  Byte10Str    (i:BYTE):Str2;
  31. FUNCTION  ChkDir       (path:PathStr):BOOLEAN;
  32. FUNCTION  ChkWild      (path:PathStr):CHAR;
  33. FUNCTION  ClrL         (len:BYTE;c:CHAR):STRING;
  34. FUNCTION  CmpExt       (s:STRING):BOOLEAN;
  35. FUNCTION  CmpStr       (s1,s2:STRING):INTEGER;
  36. FUNCTION  CmpWithWild  (s1,s2:STRING):BOOLEAN;
  37. FUNCTION  DateTimeStr  (time:LONGINT):Str18;
  38. FUNCTION  DelSpace     (s:STRING):STRING;
  39. FUNCTION  DosFree      :LONGINT;
  40. FUNCTION  FExist       (path:PathStr):WORD;
  41. FUNCTION  FileAtrStr   (VAR attr:BYTE):Str6;
  42. FUNCTION  Fill         (n:BYTE;c:CHAR):STRING;
  43. PROCEDURE FSplit       (path:PathStr;VAR d:DirStr;VAR n:NameStr;VAR e:ExtStr);
  44. FUNCTION  FTime        (path:PathStr):LONGINT;
  45. FUNCTION  GetChar      :CHAR;
  46. FUNCTION  GetDirName   (VAR s:DirStr):Str13;
  47. FUNCTION  GetEnviro    (s:STRING):STRING;
  48. FUNCTION  GetStr       (VAR s:STRING):STRING;
  49. FUNCTION  Long16Str    (n:longint):Str8;
  50. FUNCTION  Long2Char    (l:LONGINT):Str4;
  51. FUNCTION  LengZ        (VAR _h):WORD;
  52. FUNCTION  MaxLong      (x,y:LONGINT):LONGINT;
  53. FUNCTION  MinLong      (x,y:LONGINT):LONGINT;
  54. FUNCTION  NewFname     (old:PathStr;ext:ExtStr;mode:CHAR):PathStr;
  55. FUNCTION  NoCheckCTRL  (fh:WORD):BYTE;
  56. FUNCTION  ChangeDirName(d:DirStr):DirStr;
  57. FUNCTION  ReMove       (fn:PathStr):BOOLEAN;
  58. FUNCTION  ResetFn      (fn:PathStr):Str12;
  59. FUNCTION  ResetPath    (path:PathStr):PathStr;
  60. PROCEDURE SetIOCTRL    (fh:WORD;code:BYTE);
  61. FUNCTION  UpCaseStr    (s:STRING):STRING;
  62. FUNCTION  Word16Str    (i:WORD):Str4;
  63.  
  64.  
  65. IMPLEMENTATION
  66.  
  67.  
  68. VAR
  69.    ExitSave : POINTER;
  70.  
  71. CONST
  72.    CHR16    : ARRAY[0..15] OF CHAR='0123456789ABCDEF';
  73.  
  74.  
  75. FUNCTION MinLong(x,y:LONGINT):LONGINT;
  76. BEGIN
  77.    IF x<y THEN MinLong:=x ELSE MinLong:=y;
  78. END;
  79.  
  80.  
  81. FUNCTION MaxLong(x,y:LONGINT):LONGINT;
  82. BEGIN
  83.    IF x>y THEN MaxLong:=x ELSE MaxLong:=y;
  84. END;
  85.  
  86.  
  87. FUNCTION NewFname(old:PathStr;ext:ExtStr;mode:CHAR):PathStr;
  88. VAR
  89.    d : DirStr;
  90.    n : NameStr;
  91.    e : ExtStr;
  92. BEGIN
  93.    FSplit(old,d,n,e);
  94.    IF e='' THEN
  95.       NewFname:=old+'.'+ext
  96.    ELSE
  97.       CASE mode OF
  98.          '+' : NewFname:=old;
  99.          '-' : NewFname:=d+n+'.'+ext;
  100.       END;
  101. END;
  102.  
  103.  
  104. PROCEDURE FSplit(path:PathStr;VAR d:DirStr;VAR n:NameStr;VAR e:ExtStr);
  105. VAR
  106.    l,p,np,ep : BYTE;
  107. BEGIN
  108.    d:='';
  109.    n:='';
  110.    e:='';
  111.    path:=path+NUL;
  112.    l:=Length(path);
  113.    ep:=l;
  114.    np:=1;
  115.    p :=1;
  116.    WHILE path[p]<>NUL DO BEGIN
  117.       IF path[p] IN [':','\',PathDelim] THEN np:=SUCC(p);
  118.       IF path[p]='.'                    THEN ep:=p;
  119.       IF path[p] IN KanjiCharSet THEN Inc(p,2) ELSE Inc(p);END;
  120.    IF (Copy(path,np,l-np)='.') OR (copy(path,np,l-np)='..') THEN BEGIN
  121.       e:='';
  122.       d:=copy(path,1,PRED(np));
  123.       n:=copy(path,np,l-np);END
  124.    ELSE BEGIN
  125.       IF ep<np THEN ep:=l;
  126.       d:=copy(path, 1,PRED(np));
  127.       n:=copy(path,np,ep-np   );
  128.       e:=copy(path,ep,l-ep    );
  129.    END;
  130. END;
  131.  
  132.  
  133. FUNCTION DosFree:LONGINT;
  134. VAR
  135.    env,n,m : WORD;
  136. BEGIN
  137.    env:=Pred(MemW[PrefixSeg:$2C]);
  138.    n:=MemW[env:3];
  139.    DosFree:=LONGINT(16)*(n+MemW[Succ(env+n):3]);
  140. END;
  141.  
  142.  
  143. FUNCTION GetEnviro(s:STRING):STRING;
  144. VAR
  145.    i,EnviroSeg : WORD;
  146.    SS          : STRING;
  147. BEGIN
  148.    EnviroSeg:=memw[PrefixSeg:$002c];
  149.    i:=0;
  150.    REPEAT
  151.       ss:=AscZ(mem[EnviroSeg:i]);
  152.       IF ss='' THEN BEGIN GetEnviro:='';Exit;END
  153.       ELSE IF Copy(ss,1,Succ(length(s)))=(s+'=') THEN BEGIN
  154.          GetEnviro:=copy(ss,length(s)+2,255);Exit;END
  155.       ELSE
  156.          Inc(i,LengZ(mem[EnviroSeg:i]));
  157.   UNTIL FALSE;
  158. END;
  159.  
  160.  
  161. FUNCTION GetStr(VAR s:STRING):STRING;
  162. VAR
  163.    ss : STRING;
  164. BEGIN
  165.    s:=DelSpace(s);
  166.    ss:='';
  167.    WHILE (s<>'') AND (NOT (s[1] IN [SPACE,TAB])) DO BEGIN
  168.        ss:=ss+s[1];Delete(s,1,1);END;
  169.    s:=DelSpace(s);
  170.    GetStr:=ss;
  171. END;
  172.  
  173.  
  174. FUNCTION DelSpace(s:STRING):STRING;
  175. VAR
  176.    n  : INTEGER;
  177.   _s : ARRAY[0..256] OF BYTE ABSOLUTE s;
  178. BEGIN
  179.    n:=1;
  180.    WHILE (n<=_s[0]) and (S[n] in [SPACE,TAB]) DO INC(n);
  181.    delete(s,1,PRED(n));
  182.    n:=length(s);
  183.    WHILE (n>0) and (s[n] IN [SPACE,TAB]) DO DEC(n);
  184.    _s[0]:=n;
  185.    DelSpace:=s;
  186. END;
  187.  
  188.  
  189. PROCEDURE SetIOCTRL(fh:WORD;code:BYTE);
  190. BEGIN
  191.    WITH Regs DO BEGIN
  192.       BX:=fh;
  193.       AX:=$4401;
  194.       DX:=code;
  195.       MsDos(Regs);
  196.    END;
  197. END;
  198.  
  199.  
  200. FUNCTION NoCheckCTRL(fh:WORD):BYTE;
  201. BEGIN
  202.    WITH Regs DO BEGIN
  203.       AX:=$4400;
  204.       BX:=fh;
  205.       MsDos(Regs);
  206.       NoCheckCTRL:=DL;
  207.       AX:=$4401;
  208.       DX:=(DL OR $20);
  209.       MsDos(Regs);
  210.    END;
  211. END;
  212.  
  213.  
  214. FUNCTION GetChar:CHAR;
  215. VAR
  216.    IOflg : BYTE;
  217.    c     : CHAR;
  218.    fh1   : WORD;
  219. BEGIN
  220.    WITH Regs DO BEGIN
  221.       IOflg:=NoCheckCTRL(2);
  222.       AH:=$45;  BX:=1;                                  MsDos(Regs); FH1:=AX;
  223.       AH:=$46;  BX:=2;   CX:=1;                         MsDos(Regs);
  224.       AH:=$3F;  BX:=2;   CX:=1; DS:=Seg(c); DX:=Ofs(c); MsDos(Regs);
  225.       AH:=$46;  BX:=FH1; CX:=1;                         MsDos(Regs);
  226.       AH:=$3E;  BX:=FH1;                                MsDos(Regs);
  227.       SetIOCTRL(2,IOflg);END;
  228.    GetChar:=c;
  229. END;
  230.  
  231.  
  232. FUNCTION ClrL(len:BYTE;c:CHAR):STRING;
  233. BEGIN
  234.    ClrL:=Fill(len,c)+Fill(len,BS);
  235. END;
  236.  
  237.  
  238. FUNCTION ChkDir(path:PathStr):BOOLEAN;
  239. VAR
  240.    d   : DirStr;
  241.    n   : NameStr;
  242.    e   : ExtStr;
  243.    dta : SearchRec;
  244. BEGIN
  245.    IF ChkWild(path)=NUL THEN
  246.      IF ((Length(path)=2) AND (path[2]=':')) OR
  247.        ((Length(path)<>0) AND (path[Length(path)] IN [PathDelim,'\']))
  248.       THEN ChkDir:=TRUE
  249.       ELSE BEGIN
  250.          path:=UpCaseStr(path);
  251.          FSplit(path,d,n,e);
  252.          FindFirst(d+'*.*',AnyFile,dta);
  253.          WHILE DosError=0 DO WITH dta DO BEGIN
  254.             IF (n+e=name) AND ((attr AND Directory)<>0) THEN BEGIN
  255.                ChkDir:=TRUE;Exit;END;
  256.             FindNext(dta);END;
  257.          ChkDir:=FALSE;END
  258.    ELSE
  259.       ChkDir:=FALSE;
  260. END;
  261.  
  262.  
  263. FUNCTION FileAtrStr(VAR attr:BYTE):Str6;
  264. BEGIN
  265.    FileAtrStr:=copy('-w',succ(Attr AND readonly),1)+
  266.                copy('-h',succ(ord((Attr AND hidden   )= 2)),1)+
  267.                copy('-s',succ(ord((Attr AND sysfile  )= 4)),1)+
  268.                copy('-v',succ(ord((Attr AND volumeid )= 8)),1)+
  269.                copy('-d',succ(ord((Attr AND directory)=16)),1)+
  270.                copy('-a',succ(ord((Attr AND archive  )=32)),1);
  271. END;
  272.  
  273.  
  274. FUNCTION DateTimeStr(time:LONGINT):Str18;
  275. VAR
  276.    years,hours           : Str4;
  277.    months,days,mins,secs : Str2;
  278.    dt                    : datetime;
  279. BEGIN
  280.    WITH dt DO BEGIN
  281.       unpacktime (time,dt);
  282.       Str(year    ,years );
  283.       Str(month:2 ,months);
  284.       Str(day:2   ,days  );
  285.       Str(hour:4  ,hours );
  286.       Str(min:2   ,mins  );
  287.       Str(sec:2   ,secs  );
  288.       IF months[1]=' ' THEN months[1]:='0';
  289.       IF days  [1]=' ' THEN days  [1]:='0';
  290.       IF mins  [1]=' ' THEN mins  [1]:='0';
  291.       IF secs  [1]=' ' THEN secs  [1]:='0';
  292.       DateTimeStr:=copy(years,3,2)+'/'+months+'/'+days+
  293.                    hours          +':'+mins  +':'+secs;
  294.    END;
  295. END;
  296.  
  297.  
  298. FUNCTION CmpWithWild(s1,s2:STRING):BOOLEAN;
  299. VAR
  300.    i : BYTE;
  301.    s : STRING;
  302. BEGIN
  303.    CmpWithWild:=FALSE;
  304.    CASE ChkWild(s1) OF
  305.       NUL : BEGIN CmpWithWild:=(s1=s2);Exit;END;
  306.       '?' : IF length(s1)<>length(s2) THEN Exit ELSE s:=s1;
  307.    ELSE
  308.       IF Pred(Length(s1))>Length(s2) THEN Exit;
  309.       s:=Fill(Length(s2),'?');
  310.       IF s1[Length(s1)]='*' THEN
  311.          FOR i:=1 TO Pred(Length(s1)) DO s[i]:=s1[i]
  312.       ELSE
  313.          FOR i:=Length(s1) DOWNTO 2 DO s[Length(s)-Length(s1)+i]:=s1[i];END;
  314.    FOR i:=1 to Length(s) DO IF (s[i]<>'?') AND (s[i]<>s2[i]) THEN Exit;
  315.    CmpWithWild:=TRUE;
  316. END;
  317.  
  318.  
  319. FUNCTION ChkWild(path:PathStr):CHAR;
  320. VAR
  321.    i : BYTE;
  322. BEGIN
  323.    ChkWild:=NUL;
  324.    i:=1;
  325.    WHILE i<=Length(path) DO BEGIN
  326.       IF path[i]='*' THEN BEGIN ChkWild:='*';Exit;END
  327.       ELSE IF path[i]='?' THEN  ChkWild:='?'
  328.       ELSE IF path[i] IN KanjiCharSet THEN Inc(i);
  329.       Inc(i);
  330.    END;
  331. END;
  332.  
  333.  
  334. FUNCTION CmpExt(s:STRING):BOOLEAN;
  335. BEGIN
  336.    CmpExt:=((Length(s)=4) AND
  337.             (s[1]='.') AND
  338.             (s[2]='V') AND
  339.             (s[3] IN ['0'..'9','?']) AND
  340.             (s[4] IN ['0'..'9','?']))
  341.            OR
  342.             (s='.V*')
  343.            OR
  344.             (s='.*')
  345.            OR
  346.             (s='.???');
  347. END;
  348.  
  349.  
  350. FUNCTION CmpStr(s1,s2:STRING):INTEGER;
  351. var
  352.    i : INTEGER;
  353. BEGIN
  354.    i:=1;
  355.    while i<=length(s1) do begin
  356.       if length(s2)<i then begin cmpStr:=1;Exit;end;
  357.       if ord(s1[i])<>ord(s2[i]) then begin
  358.          if ord(s1[i])>ord(s2[i]) then cmpStr:=1 else cmpStr:=-1;
  359.      Exit;end;
  360.       inc(i);end;
  361.    if length(s2)>length(s1) then cmpStr:=-1 else cmpStr:=0;
  362. END;
  363.  
  364.  
  365. FUNCTION Byte16Chr(i:BYTE):CHAR;
  366. BEGIN
  367.    Byte16Chr:=CHR16[i MOD 16];
  368. END;
  369.  
  370.  
  371. FUNCTION Byte10Str(i:BYTE):Str2;
  372. BEGIN
  373.    i:=i MOD 100;
  374.    Byte10Str:=CHR16[i DIV 10]+CHR16[i MOD 10];
  375. END;
  376.  
  377.  
  378. FUNCTION Byte16Str(i:WORD):Str2;
  379. BEGIN
  380.    Byte16Str:=CHR16[(i SHR 4) AND $F]+CHR16[i AND $F];
  381. END;
  382.  
  383.  
  384. FUNCTION Word16Str(i:WORD):Str4;
  385. BEGIN
  386.    Word16Str:=Byte16Str(hi(i))+Byte16Str(lo(i));
  387. END;
  388.  
  389.  
  390. FUNCTION Long16Str(n:longint):Str8;
  391. VAR
  392.    n1 : RECORD lo,hi:word END ABSOLUTE n;
  393. BEGIN
  394.    Long16Str:=Word16Str(n1.hi)+Word16Str(n1.lo)
  395. END;
  396.  
  397.  
  398. FUNCTION Fill(n:BYTE;c:CHAR):STRING;
  399. VAR
  400.    s : STRING;
  401. BEGIN
  402.    FillChar(s[1],n,c);
  403.    s[0]:=CHAR(n);
  404.    Fill:=s;
  405. END;
  406.  
  407.  
  408. FUNCTION UpCaseStr(s:STRING):STRING;
  409. VAR
  410.    i : INTEGER;
  411. BEGIN
  412.    i:=1;
  413.    WHILE i<=length(s) DO
  414.       IF s[i] in KanjiCharSet THEN i:=i+2 ELSE BEGIN
  415.          s[i]:=UpCase(s[i]);i:=SUCC(i);END;
  416.   UpCaseStr:=s;
  417. END;
  418.  
  419.  
  420. FUNCTION LengZ(VAR _h):WORD;
  421. VAR
  422.    i : WORD;
  423.    h : ARRAY[1..5000] OF CHAR ABSOLUTE _h;
  424. BEGIN
  425.    i:=1;
  426.    WHILE h[i]<>NUL DO Inc(i);
  427.    LengZ:=i;
  428. END;
  429.  
  430.  
  431. FUNCTION AscZ(VAR _h):STRING;
  432. VAR
  433.    i : BYTE;
  434.    h : ARRAY[1..255] OF CHAR ABSOLUTE _h;
  435. BEGIN
  436.    FOR i:=1 TO 255 DO
  437.       IF h[i]=NUL
  438.      THEN BEGIN AscZ[0]:=CHR(PRED(i));Exit;END
  439.          ELSE AscZ[i]:=h[i];
  440.    AscZ[0]:=#$FF;
  441. END;
  442.  
  443.  
  444. FUNCTION Long2Char(l:LONGINT):Str4;
  445. VAR
  446.    ls : array[1..4] OF CHAR ABSOLUTE l;
  447. BEGIN
  448.    long2char:=ls[1]+ls[2]+ls[3]+ls[4];
  449. END;
  450.  
  451.  
  452. FUNCTION FTime(path:PathStr):LONGINT;
  453. VAR
  454.    dta : SearchRec;
  455. BEGIN
  456.    FindFirst(Path,AnyFile,dta);
  457.    IF DosError=0 THEN BEGIN
  458.       ftime:=dta.time;
  459.       FindNext(dta);
  460.       IF DosError<>0 THEN Exit;END;
  461.    ftime:=-1;
  462. END;
  463.  
  464.  
  465. FUNCTION ResetPath(path:PathStr):PathStr;
  466. VAR
  467.    d   : DirStr;
  468.    n   : NameStr;
  469.    e   : ExtStr;
  470. BEGIN
  471.    FSplit(path,d,n,e);
  472.    IF (path<>d+n+e) THEN ResetPath:=''
  473.    ELSE IF (n+e='') OR (n='.') THEN ResetPath:=d+'*.*'
  474.    ELSE IF ChkDir(path) THEN ResetPath:=path+PathDelim+'*.*'
  475.    ELSE ResetPath:=path;
  476. END;
  477.  
  478.  
  479. FUNCTION GetDirName(VAR s:DirStr):Str13;
  480. VAR
  481.    l,p,np : INTEGER;
  482. BEGIN
  483.    IF s[2]=':' THEN Delete(s,1,2);
  484.    s:=s+NUL;
  485.    l:=Length(s);
  486.    np:=0;
  487.    p :=1;
  488.    WHILE (s[p]<>NUL) AND (np=0) DO BEGIN
  489.       IF s[p] IN ['\',PathDelim] THEN np:=p;
  490.       IF s[p] IN kanjicharset THEN Inc(p,2) ELSE Inc(p);END;
  491.    GetDirName:=copy(s,1 ,np);
  492.    s         :=copy(s,Succ(np),l-Succ(np));
  493. END;
  494.  
  495.  
  496. FUNCTION FExist(path:PathStr):WORD;
  497. VAR
  498.    n   : WORD;
  499.    dta : searchrec;
  500. BEGIN
  501.    n:=0;
  502.    FindFirst(Path,AnyFile,dta);
  503.    IF DosError=0 THEN BEGIN
  504.       WHILE DosError=0 DO BEGIN
  505.          Inc(n);
  506.          FindNext(dta);
  507.       END;END;
  508.    FExist:=n;
  509. END;
  510.  
  511.  
  512. FUNCTION ReMove(FN:PathStr):BOOLEAN;
  513. VAR
  514.    f : FILE;
  515. BEGIN
  516.    Assign(f,fn);
  517.    Reset(f);
  518.    Close(f);
  519.    Erase(f);
  520.    ReMove:=IOresult=0;
  521. END;
  522.  
  523.  
  524. FUNCTION ResetFn(fn:PathStr):Str12;
  525. VAR
  526.    d : DirStr;
  527.    n : NameStr;
  528.    e : ExtStr;
  529. BEGIN
  530.    FSplit(fn,d,n,e);
  531.    ResetFn:=Copy(n+'        ',1,8)+Copy(e+'    ',1,4);
  532. END;
  533.  
  534.  
  535. FUNCTION ChangeDirName(d:DirStr):DirStr;
  536. BEGIN
  537.    IF NOT (d[Length(d)] IN [':','\',PathDelim])
  538.       THEN ChangeDirName:=d+PathDelim
  539.       ELSE ChangeDirName:=d;
  540. END;
  541.  
  542.  
  543. {$F+}
  544. PROCEDURE ToolOut;{$F-}
  545. BEGIN
  546.    IF ErrStr<>'' THEN WriteLn(ERRF,ErrStr+BEL);
  547.    Close(ERRF);
  548.    Close(OUTF);
  549.    Close(INF);
  550.    ExitProc:=ExitSave;
  551. END;
  552.  
  553.  
  554. BEGIN
  555.    ExitSave :=ExitProc;
  556.    ExitProc :=@ToolOut;
  557.    AssignErr(ERRF   );ReWrite(ERRF);
  558.    Assign   (OUTF,'');ReWrite(OUTF);
  559.    Assign   (INF ,'');ReSet  (INF );
  560.    WITH Regs DO BEGIN
  561.       AX:=$3700;
  562.       MsDos(Regs);
  563.       SwitchChar:=Chr(Regs.DL);
  564.       IF SwitchChar='/' THEN PathDelim:='\' ELSE PathDelim:='/';
  565.    END;
  566. END.
  567.