Ignore:
Timestamp:
Apr 30, 2016, 8:19:42 PM (9 years ago)
Author:
RBRi
Message:

update FileUtilsUnit (merged from old 2.20)

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/Library/FileUtilsUnit.pas

    r388 r392  
    22
    33// NewView - a new OS/2 Help Viewer
    4 // Copyright 2006/2007 Ronald Brill (rbri at rbri dot de)
     4// Copyright 2003-2006 Aaron Lawrence
     5// Copyright 2006-2009 Ronald Brill (rbri at rbri dot de)
    56// This software is released under the GNU Public License - see readme.txt
    67
    … …  
    1516
    1617const
    17   DirectorySeparator = '\';
     18  DIRECTORY_SEPARATOR = '\';
    1819  PATH_SEPARATOR = ';';
     20  CURRENT_DIRECTORY = '.';
     21  PARENT_DIRECTORY = '..';
     22  FILE_EXTENSION_DELIMITER = '.';
     23
     24  // Drive numbers are one based
     25  MinDriveNumber = 1;
     26  MaxDriveNumber = 26;
     27
    1928
    2029  // TODO
    … …  
    2332  LanguageEnvironmentVar = 'LANG';
    2433  DEFAULT_LANGUAGE = 'EN_US';
    25   HELP_FILE_EXTENSION = '.hlp';
    26   INF_FILE_EXTENSION = '.inf';
     34  HELP_FILE_DELIMITER = '+';
     35  HELP_FILE_EXTENSION = FILE_EXTENSION_DELIMITER + 'hlp';
     36  INF_FILE_EXTENSION = FILE_EXTENSION_DELIMITER + 'inf';
     37
     38
     39type
     40  TDriveType =
     41  (
     42    dtNone,
     43    dtFloppy,
     44    dtHard,
     45    dtCD,
     46    dtNetwork,
     47    dtRemovable
     48  );
    2749
    2850
    … …  
    5880  // this always clears the list at the beginning
    5981  Procedure GetDirsInPath(const aPathEnvVar: String; var aList: TStrings);
     82
     83  // Breaks up specified Env var path
     84  // then adds all matching files to the list
     85  Procedure GetFilesInPath(     const aPathEnvVar: String;
     86                                const aFilter: String;
     87                                var aList: TStrings );
    6088
    6189  // searches for all files in aDirectory matching aFilter and add
    … …  
    6896
    6997  // searches for all directories in aDirectory and add them to aList
    70   Procedure ListSubDirectories(const aDirectory: String; var aList: TStrings);
     98  Procedure ListSubDirectories(const aDirectory: String; const anIncludeSystemAndHiddenFlag: boolean; var aList: TStrings);
    7199
    72100  Procedure ListFilesInDirectoryRecursiveWithTermination(const aDirectory : String;
    73101                                                         const aFilter : String;
    74102                                                         const aWithDirectoryFlag : boolean;
     103                                                         const anIncludeSystemAndHiddenFlag: boolean;
    75104                                                         var aList : TStrings;
    76105                                                         const aTerminateCheck : TTerminateCheck;
    … …  
    79108  Function ParentDir(const aDirectory : String) : String;
    80109
     110  // In the directory startpath, create directory and subdirectories
     111  // specified in DirsString
     112  // e.g. bob\bill\fred will make bob, then bill in bob, then fred in bob
     113  // returns path to lowest dir created
     114  Function MakeDirs(const aFullDirectoryPath: String) : String;
     115
     116
     117  // Checks if a directory exists
    81118  Function DirectoryExists(const aDirectory : String) : boolean;
     119
     120  Function DriveLetterToDriveNumber(const aDriveLetter : char) : longint;
     121  Function DriveNumberToDriveLetter(const aDriveNumber : longint) : char;
     122
     123  Function GetVolumeLabel(aDrive: char) : String;
     124
     125  Function GetBootDriveLetter: char;
     126
     127  // Returns true if file exists and is read only
     128  Function FileIsReadOnly(const aFilename : String) : boolean;
     129
     130
     131  // TODO
     132  Function IsFloppyDrive( DriveNumber: longint ): Boolean;
     133  Function GetLocalDriveType( DriveNumber: longint ): TDriveType;
     134  Function GetDriveType( DriveNumber: longint ): TDriveType;
     135  Function GetNetworkDriveRemotePath( DriveNumber: longint ): String;
     136
    82137
    83138Implementation
    … …  
    86141  Dos,
    87142  BseDos,
     143  BseErr,
     144  BseDev,
    88145  Os2Def,
    89146  SysUtils,
    90   StringUtilsUnit;
     147  StringUtilsUnit,
     148  CharUtilsUnit;
     149
     150imports
     151  FUNCTION _DosQueryFSAttach( VAR pszDeviceName: CSTRING;
     152                              ulOrdinal: ULONG;
     153                              ulFSAInfoLevel:ULONG;
     154                              pfsqb: PFSQBUFFER2;
     155                              VAR pcbBuffLength: ULONG ): APIRET; APIENTRY;
     156  'DOSCALLS' index 277;
     157end;
     158
     159
     160type
     161  TWord = Record                    // Bytes of a Word
     162    LoByte, HiByte : Byte;
     163  End;
     164
     165  TBPB = Array[0..30] Of Byte;    // Puffer fuer BPB-Struktur
     166
     167  TDeviceParameters = Record
     168    BPB: TBPB;
     169    Cylinders: word;
     170    DeviceType: Byte;
     171    Attributes: Word;
     172  End;
     173
     174
    91175
    92176  Function AddDirectorySeparator(aDirectory : String) : String;
    … …  
    94178    if aDirectory = '' then
    95179    begin
    96       Result:= DirectorySeparator;
     180      Result:= DIRECTORY_SEPARATOR;
    97181      exit;
    98182    end;
    99183
    100     if aDirectory[length(aDirectory)] <> DirectorySeparator then
    101     begin
    102       Result := aDirectory + DirectorySeparator;
     184    if aDirectory[length(aDirectory)] <> DIRECTORY_SEPARATOR then
     185    begin
     186      Result := aDirectory + DIRECTORY_SEPARATOR;
    103187      exit;
    104188    end;
    … …  
    121205  Function RemoveRightDirectorySeparator(aDirectory : String) : String;
    122206  begin
    123     Result := StrTrimRightChars(aDirectory, [DirectorySeparator]);
     207    Result := StrTrimRightChars(aDirectory, [DIRECTORY_SEPARATOR]);
    124208  end;
    125209
    … …  
    135219    if aPath = '' then
    136220    begin
    137       Result := StrTrimRightChars(Result, [DirectorySeparator]);
     221      Result := StrTrimRightChars(Result, [DIRECTORY_SEPARATOR]);
    138222      exit;
    139223    end;
    … …  
    148232        if Length(aPath) > 3 then
    149233        begin
    150           Result := StrTrimRightChars(Result, [DirectorySeparator]);
     234          Result := StrTrimRightChars(Result, [DIRECTORY_SEPARATOR]);
    151235        end;
    152236        exit;
    … …  
    157241    begin
    158242      // check for root dir spec
    159       if aPath[1] = DirectorySeparator then
     243      if aPath[1] = DIRECTORY_SEPARATOR then
    160244      begin
    161245        // take just the drive from the basedir
    … …  
    166250        else
    167251        begin
    168           Result := DirectorySeparator;
     252          Result := DIRECTORY_SEPARATOR;
    169253        end;
    170           aPath := StrTrimLeftChars(aPath, [DirectorySeparator]);
     254          aPath := StrTrimLeftChars(aPath, [DIRECTORY_SEPARATOR]);
    171255      end;
    172256    end;
    173257
    174258    tmpDirectories := TStringList.Create;
    175     StrExtractStringsIgnoreEmpty(tmpDirectories, aPath, [DirectorySeparator], #0);
     259    StrExtractStringsIgnoreEmpty(tmpDirectories, aPath, [DIRECTORY_SEPARATOR], #0);
    176260    for i := 0 to tmpDirectories.count-1 do
    177261    begin
    178262      tmpDirectory := tmpDirectories[i];
    179       if tmpDirectory = '..' then
     263      if tmpDirectory = PARENT_DIREcTORY then
    180264      begin
    181265        if NOT ((Length(Result) = 2) AND (Result[2] = ':')) then
    … …  
    184268        end;
    185269      end
    186       else if tmpDirectory = '.' then
     270      else if tmpDirectory = CURRENT_DIRECTORY then
    187271      begin
    188272        ; // nothing to do
    … …  
    194278
    195279      // strip any extra leading slashes
    196       aPath := StrTrimLeftChars(aPath, [DirectorySeparator]);
     280      aPath := StrTrimLeftChars(aPath, [DIRECTORY_SEPARATOR]);
    197281    end;
    198282    tmpDirectories.Destroy;
    … …  
    203287      begin
    204288        // just a drive spec X:, so add a slash
    205         Result := Result + DirectorySeparator;
     289        Result := Result + DIRECTORY_SEPARATOR;
    206290      end;
    207291    end;
    … …  
    355439
    356440    StrExtractStringsIgnoreEmpty(aList, StrPas(tmpPszPathEnvVar), [PATH_SEPARATOR], #0);
     441  end;
     442
     443
     444  Procedure GetFilesInPath(     const aPathEnvVar: String;
     445                                const aFilter: String;
     446                                var aList: TStrings );
     447  var
     448    tmpDirectories : TStringList;
     449    i : integer;
     450  begin
     451    tmpDirectories := TStringList.Create;
     452    GetDirsInPath(aPathEnvVar, tmpDirectories);
     453
     454    for i:=0 to tmpDirectories.count-1 do
     455    begin
     456      ListFilesInDirectory(tmpDirectories[i], aFilter, false, aList);
     457    end;
     458
     459    tmpDirectories.Destroy;
    357460  end;
    358461
    … …  
    402505
    403506
    404   Procedure ListSubDirectories(const aDirectory: String; var aList: TStrings);
     507  Procedure ListSubDirectories(const aDirectory: String; const anIncludeSystemAndHiddenFlag: boolean; var aList: TStrings);
    405508  var
    406509    tmpRC : APIRET;
    407510    tmpSearchResults: TSearchRec;
    408511    tmpName : String;
    409   begin
    410 
    411     tmpRC := FindFirst(AddDirectorySeparator(aDirectory) + '*', faDirectory or faMustDirectory, tmpSearchResults);
     512    tmpFileAttributes : ULONG;
     513  begin
     514
     515    if anIncludeSystemAndHiddenFlag then
     516    begin
     517      tmpFileAttributes := faArchive or faReadonly or faHidden or faSysFile or faDirectory or faMustDirectory;
     518    end
     519    else
     520    begin
     521      tmpFileAttributes := faArchive or faReadonly or faDirectory or faMustDirectory;
     522    end;
     523
     524    tmpRC := FindFirst(AddDirectorySeparator(aDirectory) + '*', tmpFileAttributes, tmpSearchResults);
    412525    if (tmpRC <> 0) then
    413526    begin
    … …  
    418531    begin
    419532      tmpName := tmpSearchResults.Name;
    420       if (tmpName <> '.') AND (tmpName <> '..') then
     533      if (tmpName <> CURRENT_DIRECTORY) AND (tmpName <> PARENT_DIRECTORY) then
    421534      begin
    422535        aList.Add(AddDirectorySeparatorIfNotEmpty(aDirectory) + tmpSearchResults.Name );
    … …  
    431544                                                         const aFilter : String;
    432545                                                         const aWithDirectoryFlag : boolean;
     546                                                         const anIncludeSystemAndHiddenFlag: boolean;
    433547                                                         var aList : TStrings;
    434548                                                         const aTerminateCheck : TTerminateCheck;
    … …  
    444558    // now determine all subdirectories
    445559    tmpSubDirectories := TStringList.Create;
    446     ListSubDirectories(aDirectory, tmpSubDirectories);
     560    ListSubDirectories(aDirectory, anIncludeSystemAndHiddenFlag, tmpSubDirectories);
    447561
    448562    for i := 0 to tmpSubDirectories.Count - 1 do
    … …  
    455569      tmpSubDirectory := tmpSubDirectories[i];
    456570
    457       ListFilesInDirectoryRecursiveWithTermination(tmpSubDirectory, aFilter, aWithDirectoryFlag, aList, aTerminateCheck, aUseTerminateCheck);
     571      ListFilesInDirectoryRecursiveWithTermination(     tmpSubDirectory,
     572                                                        aFilter,
     573                                                        aWithDirectoryFlag,
     574                                                        anIncludeSystemAndHiddenFlag,
     575                                                        aList,
     576                                                        aTerminateCheck,
     577                                                        aUseTerminateCheck);
    458578    end;
    459579    tmpSubDirectories.Destroy;
    … …  
    468588
    469589    // ends with slash
    470     while (aDirectory[tmpPos] = DirectorySeparator) AND (tmpPos > 0) do
     590    while (aDirectory[tmpPos] = DIRECTORY_SEPARATOR) AND (tmpPos > 0) do
    471591    begin
    472592      dec(tmpPos);
    … …  
    474594
    475595    // find slash
    476     while (aDirectory[tmpPos] <> DirectorySeparator) AND (tmpPos > 0) do
     596    while (aDirectory[tmpPos] <> DIRECTORY_SEPARATOR) AND (tmpPos > 0) do
    477597    begin
    478598      dec(tmpPos);
    … …  
    480600
    481601    result:= StrLeft(aDirectory, tmpPos-1);
     602  end;
     603
     604
     605  Function MakeDirs(const aFullDirectoryPath: String) : String;
     606  Var
     607    tmpDirectoryParts : TStringList;
     608    tmpDirectoryPart : String;
     609    tmpCompletePart : String;
     610    i : integer;
     611  begin
     612    tmpDirectoryParts := TStringList.Create;
     613    StrExtractStringsIgnoreEmpty(tmpDirectoryParts, aFullDirectoryPath, [DIRECTORY_SEPARATOR], #0);
     614
     615    tmpCompletePart := '';
     616    for i:=0 to tmpDirectoryParts.count-1 do
     617    begin
     618      tmpDirectoryPart := trim(tmpDirectoryParts[i]);
     619
     620      if tmpDirectoryPart <> '' then
     621      begin
     622        tmpCompletePart := AddDirectorySeparatorIfNotEmpty(tmpCompletePart) + tmpDirectoryPart;
     623
     624        if not DirectoryExists(tmpCompletePart) then
     625        begin
     626          MkDir(tmpCompletePart);
     627        end;
     628      end;
     629    end;
     630
     631    Result := tmpCompletePart;
    482632  end;
    483633
    … …  
    498648    if tmpDirectory = '' then
    499649    begin
    500       Result:= true;
     650      Result := true;
    501651      exit;
    502652    end;
    … …  
    507657      begin
    508658        // a drive only has been specified
    509         tmpDrive:= UpCase(tmpDirectory[1] );
     659        tmpDrive := UpCase(tmpDirectory[1] );
    510660        if (tmpDrive < 'A') or (tmpDrive > 'Z') then
    511661        begin
    … …  
    523673    end;
    524674
    525     tmpRC := FindFirst(tmpDirectory, faDirectory or faMustDirectory, tmpSearchResults);
     675    tmpRC := FindFirst( tmpDirectory,
     676                        faArchive or faReadonly or faHidden or faSysFile or faDirectory or faMustDirectory,
     677                        tmpSearchResults);
    526678    if tmpRC = 0 then
    527679    begin
    … …  
    532684
    533685
     686  Function DriveLetterToDriveNumber(const aDriveLetter : char) : longint;
     687  begin
     688    if     (aDriveLetter >= 'a')
     689       and (aDriveLetter <= 'z') then
     690    begin
     691      Result := Ord(aDriveLetter) - Ord('a') + 1;
     692      exit;
     693    end;
     694
     695    if     (aDriveLetter >= 'A')
     696       and (aDriveLetter <= 'Z') then
     697    begin
     698      Result := Ord(aDriveLetter) - Ord('A') + 1;
     699      exit;
     700    end;
     701
     702    // not a valid drive letter
     703    Result := 0;
     704  end;
     705
     706
     707  Function DriveNumberToDriveLetter(const aDriveNumber: longint) : char;
     708  begin
     709    Result := Chr(aDriveNumber - 1 + Ord('A'));
     710  end;
     711
     712
     713  Function GetVolumeLabel(aDrive: char) : String;
     714  var
     715    tmpRC : APIRET;
     716    tmpFileSystemInfo : FSINFO;
     717    e : EInOutError;
     718  begin
     719    DosErrorAPI( FERR_DISABLEHARDERR );
     720    Result := '';
     721    tmpRC := DosQueryFSInfo( DriveLetterToDriveNumber(aDrive),
     722                             FSIL_VOLSER,
     723                             tmpFileSystemInfo,
     724                             sizeof(tmpFileSystemInfo));
     725    if tmpRC = 0 then
     726    begin
     727      Result := StrPasWithLength(Addr(tmpFileSystemInfo.vol.szVolLabel), tmpFileSystemInfo.vol.cch);
     728      Result := LowerCase(Result);
     729    end;
     730    DosErrorAPI( FERR_ENABLEHARDERR );
     731
     732    if tmpRC <> 0 then
     733    begin
     734      e := EInOutError.Create( 'Cannot read drive ' + aDrive + ':');
     735      e.ErrorCode := tmpRC;
     736      raise e;
     737    end;
     738  end;
     739
     740
     741  Function GetBootDriveLetter: char;
     742  var
     743    tmpBuffer: longword;
     744  begin
     745    DosQuerySysInfo( QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, tmpBuffer, sizeof(tmpBuffer));
     746    Result := Chr(ord('A') + tmpBuffer - 1);
     747  end;
     748
     749
     750  Function FileIsReadOnly(const aFilename : String ) : boolean;
     751  begin
     752    Result :=(FileGetAttr(aFilename) AND faReadonly) > 0;
     753  end;
     754
     755
     756
     757
     758  // TODO
     759
     760
     761Function IsFloppyDrive( DriveNumber: longint ): Boolean;
     762Var
     763  bResult : Byte;
     764Begin
     765  DosDevConfig( bResult, DEVINFO_FLOPPY );
     766  Result := ( Abs( DriveNumber ) <= bResult);
     767End;
     768
     769// -------------------------------------------------------------------------
     770// Funktion/Function: QueryCDRoms()
     771//
     772// Beschreibung:
     773//   Die Funktion QueryCDRom ermittelt ueber eine nicht dokumentierte
     774//   Schnittstelle die Anzahl der CDRom-Laufwerke und den ersten, fuer
     775//   ein CDRom-Laufwerk, vergebenen UnitIdentifier.
     776//   Der Treiber OS2CDROM.DMD stellt dem System zwei Devices (CD-ROM1$
     777//   und CD-ROM2$) zur Verfuegung. Die beiden Devices unterscheiden sich
     778//   durch DeviceAttribute. Beide Devices unterstuetzen (zumindest unter
     779//   Warp) den undokumentierten Generic IOCtl 0x82/0x60, welcher Infor-
     780//   mationen ueber die angeschlossenen CDRom-Laufwerke liefert.
     781//
     782// Description:
     783//   This Functions finds out how many CD-Rom Drives are present in System
     784//   and which Drive Letter is the first occupied by a CD-Rom. It uses an
     785//   undocumented Interface to OS2CDROM.DMD.
     786//   OS2CDROM.DMD presents two Devices (CD-ROM1$ and CD-ROM2$). These De-
     787//   vices are distinguished by their Device-Attributes. Both Devices sup-
     788//   port (under Warp) the undocumented generic IOCtl-Call 0x82/0x60 which
     789//   deliver some Information about the connected CD-Rom Drives.
     790//
     791// Parameter:
     792//   Var ulCDRomCount        ULONG     Anzahl CD-Rom Laufwerke im System
     793//                                     Number of CD-Rom Drives in System
     794//
     795//   Var ulFirstCDRomDiskNo  ULONG     erste Laufwerksnummer, die an ein
     796//                                     CD-Rom vergeben ist
     797//                                     first Drive-Letter occupied by a
     798//                                     CD-Rom Drive
     799//
     800// Rueckgabe/Returnvalue:  keine/none
     801// -------------------------------------------------------------------------
     802Procedure QueryCDRoms(Var ulCDRomCount, ulFirstCDRomDiskNo: ULONG);
     803
     804Const cszDriverName : CSTRING = 'CD-ROM?$';
     805
     806Var cCurDriver : Char;                    // Indexvariable fuer aktuell bearbeites Device (1 oder 2)
     807                                          // Index for current Device (1 or 2)
     808
     809    hDevHandle : HFILE;                   // Handle fuer Device
     810                                          // Device handle
     811
     812    ulAction   : ULONG;                   // Aktionscode (DosOpen())
     813                                          // Actioncode (DosOpen())
     814
     815    ulParams   : ULONG;                   // Anzahl Bytes von IOCtl gelieferter Parameterdaten
     816                                          // Number of Bytes for delivered Parameterdata
     817
     818    ulData     : ULONG;                   // Anzahl Bytes von IOCtl gelieferter Daten
     819                                          // Number of Bytes delivered by IOCtl
     820
     821    rCDInfo    : Record                   // Ergebnisstruktur der IOCtl-Funktion (s.o.)
     822                                          // Record for Results of IOCtl-Call (see above)
     823                   usCDRomCount : USHORT; // Anzahl CD-Roms                   / Number of CD-Rom Drives
     824                   usFirstUnitNo: USHORT; // erste vergebene Laufwerksnummer  / first Driver Letter
     825                 End;
     826
     827Begin (* uQueryCDRom *)
     828                                       /************************************
     829                                        * Vorbelegungen
     830                                        *
     831                                        * initial assignments
     832                                        ************************************/
     833  ulCDRomCount := 0;
     834  ulFirstCDRomDiskNo := 0;
     835
     836  ulParams := 0;
     837
     838                                       /************************************
     839                                        * die beiden Devices abarbeiten
     840                                        *
     841                                        * accessing both Devices
     842                                        ************************************/
     843  For cCurDriver := '1' To '2' Do
     844    Begin
     845                                       /************************************
     846                                        * Device oeffnen
     847                                        *
     848                                        * open Device
     849                                        ************************************/
     850      cszDriverName[6] := cCurDriver;
     851      If (DosOpen(cszDriverName,              // Devicename
     852                  hDevHandle,                 // Handle
     853                  ulAction,                   // Aktionscode
     854                  0,                          // Dateigr”áe
     855                  FILE_NORMAL,                // Attribute: read/write
     856                  OPEN_ACTION_OPEN_IF_EXISTS, // OpenFlag: ”ffnen, wenn vorhanden
     857                  OPEN_FLAGS_FAIL_ON_ERROR Or // Modus: Fehlermeldung per Returncode
     858                    OPEN_SHARE_DENYNONE Or    //        keine Einschr„nkungen fr Dritte
     859                    OPEN_ACCESS_READONLY,     //        nur lesender Zugriff
     860                  NIL)=NO_ERROR) Then         // keine EA
     861        Begin
     862                                       /************************************
     863                                        * IOCtl-Funktion aufrufen
     864                                        *
     865                                        * Call to IOCtl
     866                                        ************************************/
     867          If (DosDevIOCtl(hDevHandle,             // Handle                 / Handle
     868                          $82,                    // Kategorie              / Category
     869                          $60,                    // Funktion               / Function
     870                          NIL,                    // keine Parameterliste   / No Parameterlist
     871                          0,                      // Laenge Parameterliste  / Length of Parameterlist
     872                          ulParams,               // Groesse der gelieferten Parameterdaten
     873                                                  //                        / Number of Bytes for Parameterdata
     874                          rCDInfo,                // Puffer fuer gelieferte Daten
     875                                                  //                        / Buffer for returned Data
     876                          SizeOf(rCDInfo),        // Groesse des Datenpuffers
     877                                                  //                        / Size of Databuffer
     878                          ulData)=NO_ERROR) Then  // Groesse der gelieferten Daten
     879                                                  //                        / Number of Bytes for returned Data
     880            Begin
     881              ulCDRomCount := rCDInfo.usCDRomCount;
     882              ulFirstCDRomDiskNo := Succ(rCDInfo.usFirstUnitNo);
     883            End;
     884
     885          DosClose(hDevHandle);
     886        End;
     887
     888   End; (* For *)
     889
     890End; (* uQueryCDRom *)
     891
     892
     893Function GetLocalDriveType( DriveNumber: longint ): TDriveType;
     894var
     895  IOCtlParameters: Word;
     896  rc: APIRET;
     897  ParameterLength: longWord;
     898  DataLength: longword;
     899  DeviceData: TDeviceParameters;
     900  Fixed: boolean;
     901  FirstCDDrive: ULONG;
     902  NumCDDrives: ULONG;
     903begin
     904
     905  TWord( IOCtlParameters ).LoByte := 0;  // BPB of physical Device
     906  TWord( IOCtlParameters ).HiByte := DriveNumber - 1; // drive number, zero base
     907
     908  ParameterLength := SizeOf( IOCtlParameters ); // input length of parameters
     909  DataLength := 0;                              // input length of data (none)
     910
     911  rc := DosDevIOCTL( HFILE(-1),                 // Open Device (not a file)
     912                     IOCTL_DISK,                // Category
     913                     DSK_GETDEVICEPARAMS,       // Function
     914                     IOCtlParameters,           // Parameters
     915                     SizeOf( IOCtlParameters ), // (max) size of parameters
     916                     ParameterLength,           // parameters length
     917                     DeviceData,                // results
     918                     SizeOf( DeviceData ),      // (max) size of data block
     919                     DataLength );              // data block length
     920
     921  Fixed := ( DeviceData.Attributes and 1 ) > 0;    // bit 0 indicates fixed (1) or removable (0)
     922  if not Fixed then
     923  begin
     924    result := dtRemovable;
     925
     926    QueryCDRoms( FirstCDDrive,
     927                 NumCDDrives );
     928
     929    if     ( DriveNumber >= FirstCDDrive )
     930       and ( DriveNumber < FirstCDDrive + NumCDDrives ) then
     931      result := dtCD;
     932
     933    exit;
     934  end;
     935
     936  result := dtHard;
     937end;
     938
     939// Takes a one-based drive number
     940Function GetDriveType( DriveNumber: longint ): TDriveType;
     941var
     942  szDrive: CString;
     943
     944  FSData: array[ 0..sizeof( FSQBuffer) + 3*_MAX_PATH ] of char;
     945  pBuffer: PFSQBUFFER2;
     946  FSDataLength: ULONG;
     947
     948  rc: APIRET;
     949begin
     950  assert( DriveNumber >= 1 );
     951  assert( DriveNumber <= 26 );
     952
     953  if ( DriveNumber >=1 ) and ( DriveNumber <= 2 ) then
     954  begin
     955    if IsFloppyDrive( DriveNumber ) then
     956    begin
     957      result := dtFloppy;
     958      exit;
     959    end;
     960
     961    result := dtNone; // don't let OS/2 try a fake B: drive
     962    exit;
     963  end;
     964
     965  DosErrorAPI( FERR_DISABLEHARDERR );
     966
     967  szDrive := DriveNumberToDriveLetter( DriveNumber ) + ':';
     968  FSDataLength := sizeof( FSData );
     969  pBuffer := Addr( FSData );
     970  rc := _DosQueryFSAttach( szDrive,
     971                           0, // ignored
     972                           FSAIL_QUERYNAME,
     973                           pBuffer,
     974                           FSDataLength );
     975
     976  if rc = 0 then
     977  begin
     978    case pBuffer^.iType of
     979      FSAT_REMOTEDRV:
     980        result := dtNetwork;
     981
     982      FSAT_LOCALDRV:
     983        // Figure out what kind of local drive it is...
     984        result := GetLocalDriveType( DriveNumber );
     985
     986      else
     987      begin
     988        // should never happen
     989        result := dtNone;
     990        exit;
     991      end;
     992    end;
     993  end
     994  else if rc = ERROR_NOT_READY then
     995  begin
     996    // No media?
     997    // Have a look for a local disk anyway.
     998    result := GetLocalDriveType( DriveNumber );
     999  end
     1000  else
     1001  begin
     1002    result := dtNone;
     1003  end;
     1004
     1005  DosErrorAPI( FERR_ENABLEHARDERR );
     1006end;
     1007
     1008const
     1009  DEVLEN = 8;
     1010  CNLEN  = 15;               // Computer name length
     1011  UNCLEN = (CNLEN+2);        // UNC computer name length
     1012  NNLEN  = 12;               // 8.3 Net name length  (share name length)
     1013  RMLEN  = (UNCLEN+1+NNLEN); // Maximum remote name length
     1014
     1015type
     1016  use_info_0 = record
     1017    ui0_local: cstring[ DEVLEN ]; // note this is of size DEVLEN + 1
     1018    ui0_pad_1: char;
     1019    ui0_remote: pchar;
     1020    space: array[ 0..RMLEN ] of char; // remote path is written to somewhere in here
     1021  end;
     1022
     1023  use_info_1 = record
     1024    ui0_local: cstring[ DEVLEN ];
     1025    ui0_pad_1: char;
     1026    ui0_remote: pchar; // address of a buffer to hold remote path
     1027    ui1_password: pchar; //
     1028    ui1_status: USHORT;
     1029    ui1_asg_type: SHORT;
     1030    ui1_refcount: USHORT;
     1031    ui1_usecount: USHORT;
     1032    space: array[ 0..RMLEN ] of char; // remote path is written to somewhere in here
     1033  end;
     1034
     1035  TNet32UseGetInfo = Function( pszServer: pchar;
     1036                               pszUseName: pchar; // e.g. drive x:
     1037                               ulLevel: ULONG;
     1038                               pbBuffer: pointer; // pointer to output buffer
     1039                               ulBuffer: ULONG; // size of output in buffer
     1040                               Var pulTotalAvail: ULONG )
     1041                               : word; CDecl;
     1042
     1043Var
     1044  Net32UseGetInfo: TNet32UseGetInfo;
     1045  hNetAPI32DLL: HMODULE;
     1046  TriedLoading: boolean;
     1047
     1048//   129 Net32UseGetInfo
     1049Function GetNetworkDriveRemotePath( DriveNumber: longint ): string;
     1050var
     1051  ErrorName: array[ 0..255 ] of char;
     1052  dummy: cstring;
     1053  rc: word;
     1054  UseName: array[ 0..255 ] of char;
     1055  UseInfo: use_info_0;
     1056  pUseInfo: pointer;
     1057  TotalBytesNeeded: ULONG;
     1058  RemotePath: array[ 0..255 ] of char;
     1059  Dummy2: array[ 0..4096 ] of char; // try to fix stack probs
     1060begin
     1061  Result := '';
     1062
     1063  if not TriedLoading then
     1064  begin
     1065    TriedLoading := true;
     1066    rc := DosLoadModule( ErrorName,
     1067                         sizeof( ErrorName ),
     1068                         'NETAPI32',
     1069                         hNetAPI32DLL );
     1070    if rc = NO_ERROR then
     1071    begin
     1072      // NetAPI32.DLL loaded OK
     1073      rc := DosQueryProcAddr( hNetAPI32DLL,
     1074                              129,
     1075                              dummy,
     1076                              pointer( Net32UseGetInfo ) );
     1077      if rc <> 0 then
     1078        Net32UseGetInfo := nil;
     1079    end;
     1080  end;
     1081
     1082  if Assigned( Net32UseGetInfo ) then
     1083  begin
     1084    UseName[ 0 ] := DriveNumberToDriveLetter( DriveNumber );
     1085    UseName[ 1 ] := ':';
     1086    UseName[ 2 ] := #0;
     1087
     1088    RemotePath[ 0 ] := #0;
     1089//    UseInfo.ui0_remote := Addr( RemotePath );
     1090
     1091    pUseInfo := Addr( UseInfo );
     1092    rc := Net32UseGetInfo( nil, // server - always nil
     1093                           Addr( UseName ),
     1094                           0, // info level 0
     1095                           pUseInfo,
     1096                           sizeof( UseInfo ),
     1097                           TotalBytesNeeded );
     1098
     1099    if rc = 0 then
     1100      Result := StrPas( UseInfo.ui0_remote );
     1101
     1102  end;
     1103end;
     1104
     1105
    5341106Initialization
    5351107End.
Note: See TracChangeset for help on using the changeset viewer.