home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / TPKERMIT / UTILITY.PAS < prev   
Pascal/Delphi Source File  |  1987-03-25  |  6KB  |  143 lines
  1. (* +FILE+ UTILITY.PASMSCPM *)
  2. (* ============ Begining of   U T I L I T Y   Procedures ============ *)
  3. Type String2 = String[2];
  4.  
  5. (* ----------------------------------------------------------------- *)
  6. (* GETTOKEN - Function                                               *)
  7. (* ----------------------------------------------------------------- *)
  8. Function  GETTOKEN ( var instring : comstring) : comstring  ;
  9. Var
  10.     pt : byte ;
  11.  
  12.     Begin (* GETTOKEN *)
  13.     While (instring[1] = ' ') and (length(instring)>1) do
  14.           Delete(instring,1,1);    (* eliminate leading blanks *)
  15.     pt := POS(' ',instring);
  16.     if pt = 0 then pt := length(instring)+1 ;
  17.     GETTOKEN := copy(instring,1,pt-1);
  18.     DELETE(instring,1,pt);
  19.     End ; (* GETTOKEN *)
  20.  
  21. (* ----------------------------------------------------------------- *)
  22. (* UpperCase - Function                                               *)
  23. (* ----------------------------------------------------------------- *)
  24. Function UpperCase ( instring : comstring) : comstring ;
  25. Var
  26.     ix,slen : integer ;
  27.  
  28.     Begin (* UpperCase *)
  29.     slen := length(instring) ;
  30.     for ix := 1 to slen do
  31.       IF instring[ix] IN ['a'..'z'] THEN
  32.         instring[ix] := chr(ord(instring[ix])-32);
  33.     UpperCase := instring ;
  34.     End ; (* UpperCase *)
  35.  
  36. (* ----------------------------------------------------------------- *)
  37. (* CRCheck - Procedure - generates a CCITT CRC using the polynominal *)
  38. (*                       X^16 + X^12 + X^5 + 1                       *)
  39. (* Side Effects : Updates the global variable CRC which should be    *)
  40. (*                initialized to 0. It is call only once for each    *)
  41. (*                byte to be checked and all 8 bits are included.    *)
  42. (*                No terminating calls are necessary.                *)
  43. (* ----------------------------------------------------------------- *)
  44. Procedure CRCheck ( Abyte : byte ) ;
  45. Var    j,temp : integer ;
  46.     Begin (* CRCheck *)
  47.     For j := 0 to 7 do
  48.          Begin (* check all 8 bits *)
  49.          temp := CRC xor Abyte ;
  50.          CRC := CRC shr 1 ;             (* shift right *)
  51.          If Odd(temp) then CRC := CRC xor $8408 ;
  52.          abyte := abyte shr 1 ;
  53.          End ; (* check all 8 bits *)
  54.     End ; (* CRCheck *)
  55. (* ----------------------------------------------------------------- *)
  56. (* Prefixof Function - Returns a char string of the dir prefix.      *)
  57. (* ----------------------------------------------------------------- *)
  58.  function Prefixof(afilename:comstring) : comstring;
  59.  var i :integer;
  60.  label exit ;
  61.     begin (* Prefixof *)
  62.     while length(afilename)>0 do
  63.          If afilename[length(afilename)] in [':','\','/']
  64.              then goto exit
  65.              else delete(afilename,length(afilename),1);
  66.  exit:
  67.     Prefixof := afilename ;
  68.     end;  (* Prefixof *)
  69.  
  70. (* ----------------------------------------------------------------- *)
  71. (*  NewAsFile - returns a new ASFILE name in the parameter AsFile.   *)
  72. (*           MyFiles - is the wild char name.                        *)
  73. (*           Filename - is the filename to be renamed .              *)
  74. (*           AsFiles  - is the wild char name of new file.           *)
  75. (*           AsFile   - is the new file name.                        *)
  76. (*     returns TRUE if AsFile correctly assigned.                    *)
  77. (*     returns FALSE if AsFile detected an error in assignment       *)
  78. (*   There is a BUG in the MsDoS Call to get next Directory Entry    *)
  79. (*   therefore this function may return FALSE.                       *)
  80. (*                                                                   *)
  81. (* ----------------------------------------------------------------- *)
  82. Function NewAsFile (MyFiles,Filename,AsFiles: comstring;
  83.                     var AsFile : comstring                ): boolean;
  84. var
  85.     temp : comstring ;
  86.     si,ix,iy : integer ;
  87.     star : packed array[1..8] of string[20];
  88. Label  Subdir,Exit;
  89.  
  90. Begin (* NewAsFile Function *)
  91. for si := 1 to 8 do star[si] := '*';
  92. si := 0 ;
  93.  MyFiles  := Uppercase(Myfiles);
  94.  FileName := Uppercase(Filename);
  95.  AsFiles  := Uppercase(AsFiles);
  96.  ix := Pos(':',MyFiles) ;
  97.  If ix > 1 then delete(MyFiles,1,ix) ;  (* Eliminate filemode prefix *)
  98. subdir:
  99.  ix := Pos('\',MyFiles) ;
  100.  If ix > 1 then delete(MyFiles,1,ix) ;  (* Eliminate sub-dir  prefixs *)
  101.  if ix > 1 then goto subdir ;
  102.  ix := Pos(':',AsFiles) ;
  103.  If ix > 1 then delete(AsFiles,1,ix) ;  (* Eliminate filemode prefix *)
  104. While (length(Filename) > 0) and (length(Myfiles)>0) Do
  105.     Begin (* Scan filename *)
  106.     If MyFiles[1] = Filename[1] then
  107.         Begin delete(MyFiles,1,1) ; delete(Filename,1,1); end
  108.                                 else
  109.          Begin (* get star string *)
  110.          si:=si+1 ;
  111.          delete(MyFiles,1,1);
  112.          ix := Pos('*',MyFiles) - 1 ;  (* Next wild char *)
  113.          if ix <= 0 then  temp := MyFiles
  114.                     else  temp := copy(Myfiles,1,ix);
  115.          iy := Pos(temp,Filename)-1 ;
  116.          if iy < 0 then
  117.               begin NEWASFILE:=FALSE; Asfile:='temp.dat'; Goto exit ; end;
  118.          if iy = 0 then star[si] := filename
  119.                     else star[si] := copy(filename,1,iy);
  120.          delete(FileName,1,iy);
  121.          End ;(* get star string *)
  122.     End; (* Scan filename *)
  123. ix := 1 ;
  124. si := 1 ;
  125. AsFile := '';
  126. While ix <= length(AsFiles)  do
  127.     Begin (* Create AsFile name *)
  128.     If AsFiles[ix] in ['*','?'] then
  129.          Begin (* wild char *)
  130.          AsFile := Concat(AsFile,star[si]);
  131.          si := si + 1 ;
  132.          End
  133.                                 else
  134.         AsFile := Concat(AsFile,Asfiles[ix]);
  135.    ix := ix + 1 ;
  136.    End ; (* Create AsFile name *)
  137. NewAsFile := True ;
  138. Exit:
  139. End; (* NewASFile Function *)
  140.  
  141. (* ============ End of   U T I L I T Y   Procedures =================== *)
  142.  
  143.