home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / Libraries / PNL Libraries / MyFileSystemUtils.p < prev    next >
Encoding:
Text File  |  1995-10-22  |  14.2 KB  |  574 lines  |  [TEXT/CWIE]
  1. unit MyFileSystemUtils;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Files;
  7.  
  8.     procedure MyResolveAliasFile (var fs: FSSpec);
  9.     function MyGetCatInfo (vrn: integer; dirID: longint; var name: string; index: integer; var pb: CInfoPBRec): OSErr;
  10.     function FSpGetCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
  11.     function FSpSetCatInfo (var fs: FSSpec; var pb: CInfoPBRec): OSErr;
  12.     function MyFSMakeFSSpec (vrn: integer; dirID: longint; name: Str255; var fs: FSSpec): OSErr;
  13.     procedure MyGetModDate (var fs: FSSpec; var moddate: longint);
  14.     function DuplicateFile (var org, new: FSSpec): OSErr;
  15.     function CopyData (src, dst: integer; len: longint): OSErr;
  16.     function TouchDir (fs: FSSpec): OSErr;
  17.     function TouchFolder (vrn: integer; dirID: longint): OSErr;
  18.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  19.     function MyFSReadLineEOL (refnum: integer; ch: char; var s: Str255): OSErr;
  20.     function MyFSReadLine (refnum: integer; var s: Str255): OSErr;
  21.     function MyFSReadLineAt (refnum: integer; pos: longint; var s: Str255): OSErr;
  22.     function MyFSWrite (refnum: integer; len: longint; p: ptr): OSErr;
  23.     function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longint; p: ptr): OSErr;
  24.     function MyFSReadAt (refnum: integer; pos, len: longint; p: ptr): OSErr;
  25.     function FSSpecToFullPath (fs: FSSpec; var path: Str255): OSErr;
  26.     function DiskFreeSpace (vrn: integer): longint; { result in k }
  27.     function DiskSize (vrn: integer): longint; { result in k }
  28.     function BlessSystemFolder (vrn: integer; dirID: longint): OSErr;
  29.     function SameFSSpec (var fs1, fs2: FSSpec): boolean;
  30.     procedure GetSFLocation (var vrn: integer; var dirID: longint);
  31.     procedure SetSFLocation (vrn: integer; dirID: longint);
  32.     procedure SafeFindFolder (vRefNum: integer; folderType: OSType; var foundVRefNum: integer; var foundDirID: longint);
  33.     function CreateTemporaryFile (var fs: FSSpec): OSErr;
  34.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longint): OSErr;
  35.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
  36.  
  37. implementation
  38.  
  39.     uses
  40.         Errors, Packages, GestaltEqu, Folders, Aliases, LowMem, Devices,
  41.         MyTypes, TextUtils, MyStrings;
  42.  
  43.     procedure SafeFindFolder (vRefNum: integer; folderType: OSType; var foundVRefNum: integer; var foundDirID: longint);
  44.         var
  45.             theWorld: SysEnvRec;
  46.             gv: longint;
  47.     begin
  48.         foundVRefNum := -1;
  49.         foundDirID := 2;
  50.         if (Gestalt(gestaltFindFolderAttr, gv) <> noErr) | (not BTST(gv, gestaltFindFolderPresent)) | (FindFolder(vRefNum, folderType, true, foundVRefNum, foundDirID) <> noErr) then begin
  51.             if SysEnvirons(1, theWorld) = noErr then begin
  52.                 foundVRefNum := theWorld.sysVRefNum;
  53.                 foundDirID := 0;
  54.             end
  55.             else begin
  56.                 foundVRefNum := -1;
  57.                 foundDirID := 2;
  58.             end;
  59.         end;
  60.     end;
  61.  
  62.     function CreateTemporaryFile (var fs: FSSpec): OSErr;
  63.     begin
  64.         SafeFindFolder(-1, kTemporaryFolderType, fs.vRefNum, fs.parID);
  65.         CreateTemporaryFile := CreateUniqueFile(fs, 'trsh', 'trsh');
  66.     end;
  67.  
  68.     procedure GetSFLocation (var vrn: integer; var dirID: longint);
  69.     begin
  70.         vrn:= -LMGetSFSaveDisk;
  71.         dirID:=LMGetCurDirStore;
  72.     end;
  73.  
  74.     procedure SetSFLocation (vrn: integer; dirID: longint);
  75.     begin
  76.         LMSetSFSaveDisk(vrn);
  77.         LMSetCurDirStore(dirID);
  78.     end;
  79.  
  80.     function FSSPecToFullPath (fs: FSSpec; var path: Str255): OSErr;
  81.         var
  82.             err: OSErr;
  83.             pb: CInfoPBRec;
  84.             s: str63;
  85.     begin
  86.         s := fs.name;
  87.         err := FSMakeFSSpec(fs.vRefNum, fs.parID, s, fs);
  88.         if err = fnfErr then begin
  89.             err := noErr;
  90.         end;
  91.         if err = noErr then begin
  92.             if fs.parID = 1 then begin
  93.                 path := concat(fs.name, ':');
  94.             end
  95.             else begin
  96.                 path := fs.name;
  97.                 while (err = noErr) & (fs.parID <> 1) do begin
  98.                     err := FSpGetCatInfo(fs, -1, pb);
  99.                     path := concat(fs.name, ':', path);
  100.                     fs.parID := pb.ioFlParID;
  101.                 end;
  102.             end;
  103.         end;
  104.         FSSPecToFullPath := err;
  105.     end;
  106.  
  107.     function TouchDir (fs: FSSpec): OSErr;
  108.         var
  109.             pb: CInfoPBRec;
  110.             err: OSErr;
  111.     begin
  112.         if fs.name = '' then begin
  113.             TouchDir := TouchFolder(fs.vRefNum, fs.parID);
  114.         end
  115.         else begin
  116.             pb.ioVRefNum := fs.vRefNum;
  117.             pb.ioDirID := fs.parID;
  118.             pb.ioNamePtr := @fs.name;
  119.             pb.ioFDirIndex := 0;
  120.             err := PBGetCatInfoSync(@pb);
  121.             if err = noErr then begin
  122.                 pb.ioNamePtr := nil;
  123.                 GetDateTime(pb.ioDrMdDat);
  124.                 err := PBSetCatInfoSync(@pb);
  125.             end;
  126.             TouchDir := err;
  127.         end;
  128.     end;
  129.  
  130.     function TouchFolder (vrn: integer; dirID: longint): OSErr;
  131.         var
  132.             pb: CInfoPBRec;
  133.             err: OSErr;
  134.     begin
  135.         pb.ioVRefNum := vrn;
  136.         pb.ioDirID := dirID;
  137.         pb.ioNamePtr := nil;
  138.         pb.ioFDirIndex := -1;
  139.         err := PBGetCatInfoSync(@pb);
  140.         if err = noErr then begin
  141.             pb.ioVRefNum := vrn;
  142.             pb.ioDirID := dirID;
  143.             pb.ioNamePtr := nil;
  144.             GetDateTime(pb.ioDrMdDat);
  145.             err := PBSetCatInfoSync(@pb);
  146.         end;
  147.         TouchFolder := err;
  148.     end;
  149.  
  150.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  151.         var
  152.             oname: str31;
  153.             n: Str255;
  154.             i: integer;
  155.             oe: OSErr;
  156.     begin
  157.         oname := fs.name;
  158.         LimitStringLength(oname, 27, '…');
  159.         oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  160.         i := 1;
  161.         while oe = dupFNErr do begin
  162.             NumToString(i, n);
  163.             fs.name := concat(oname, '#', n);
  164.             oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  165.             i := i + 1;
  166.         end;
  167.         CreateUniqueFile := oe;
  168.     end;
  169.  
  170.     function MyFSReadAt (refnum: integer; pos, len: longint; p: ptr): OSErr;
  171.         var
  172.             pb: ParamBlockRec;
  173.             oe: OSErr;
  174.     begin
  175.         pb.ioRefNum := refnum;
  176.         pb.ioBuffer := p;
  177.         pb.ioReqCount := len;
  178.         pb.ioPosMode := fsFromStart;
  179.         pb.ioPosOffset := pos;
  180.         oe := PBReadSync(@pb);
  181.         if (oe = noErr) & (pb.ioActCount <> len) then begin
  182.             oe := -1;
  183.         end;
  184.         MyFSReadAt := oe;
  185.     end;
  186.  
  187.     function MyFSReadLineEOL (refnum: integer; ch: char; var s: Str255): OSErr;
  188.         var
  189.             pb: ParamBlockRec;
  190.             err: OSErr;
  191.     begin
  192.         pb.ioRefNum := refnum;
  193. {$PUSH}
  194. {$R-}
  195.         pb.ioBuffer := @s[1];
  196.         pb.ioReqCount := SizeOf(s) - 1;
  197.         pb.ioPosMode := fsFromMark + fsNewLine + BSL(ord(ch), 8);
  198.         pb.ioPosOffset := 0;
  199.         err := PBReadSync(@pb);
  200.         if (err = eofErr) & (pb.ioActCount > 0) then begin
  201.             err := noErr;
  202.         end;
  203.         if err = noErr then begin
  204.             if s[pb.ioActCount] = ch then begin
  205.                 pb.ioActCount := pb.ioActCount - 1;
  206.             end;
  207.             s[0] := chr(pb.ioActCount);
  208.         end;
  209. {$POP}
  210.         MyFSReadLineEOL := err;
  211.     end;
  212.  
  213.     function MyFSReadLine (refnum: integer; var s: Str255): OSErr;
  214.     begin
  215.         MyFSReadLine := MyFSReadLineEOL(refnum, cr, s);
  216.     end;
  217.  
  218.     function MyFSReadLineAt (refnum: integer; pos: longint; var s: Str255): OSErr;
  219.         var
  220.             pb: ParamBlockRec;
  221.             err: OSErr;
  222.     begin
  223.         pb.ioRefNum := refnum;
  224. {$PUSH}
  225. {$R-}
  226.         pb.ioBuffer := @s[1];
  227.         pb.ioReqCount := SizeOf(s) - 1;
  228.         pb.ioPosMode := fsFromStart + fsNewLine + BSL(ord(cr), 8);
  229.         pb.ioPosOffset := pos;
  230.         err := PBReadSync(@pb);
  231.         if (err = eofErr) & (pb.ioActCount > 0) then begin
  232.             err := noErr;
  233.         end;
  234.         if err = noErr then begin
  235.             s[0] := chr(pb.ioActCount - 1);
  236.         end;
  237. {$POP}
  238.         MyFSReadLineAt := err;
  239.     end;
  240.  
  241.     function MyFSWrite (refnum: integer; len: longint; p: ptr): OSErr;
  242.         var
  243.             oe: OSErr;
  244.             count: longint;
  245.     begin
  246.         oe := noErr;
  247.         if len > 0 then begin
  248.             count := len;
  249.             oe := FSWrite(refnum, count, p);
  250.             if (oe = noErr) & (count <> len) then begin
  251.                 oe := -1;
  252.             end;
  253.         end;
  254.         MyFSWrite := oe;
  255.     end;
  256.  
  257.     procedure MyResolveAliasFile (var fs: FSSpec);
  258.         var
  259.             isfolder, wasalias: boolean;
  260.             temp: FSSpec;
  261.             gv: longint;
  262.             oe: OSErr;
  263.     begin
  264.         if (Gestalt(gestaltAliasMgrAttr, gv) = noErr) & (BTST(gv, gestaltAliasMgrPresent)) then begin
  265.             temp := fs;
  266.             oe := ResolveAliasFile(fs, true, isfolder, wasalias);
  267.             if oe <> noErr then begin
  268.                 fs := temp;
  269.             end;
  270.         end;
  271.     end;
  272.  
  273.     function MyGetCatInfo (vrn: integer; dirID: longint; var name: string; index: integer; var pb: CInfoPBRec): OSErr;
  274.     begin
  275.         pb.ioVRefNum := vrn;
  276.         pb.ioDirID := dirID;
  277.         pb.ioNamePtr := @name;
  278.         pb.ioFDirIndex := index;
  279.         MyGetCatInfo := PBGetCatInfoSync(@pb);
  280.     end;
  281.  
  282.     function FSpGetCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
  283.     begin
  284.         pb.ioVRefNum := fs.vRefNum;
  285.         pb.ioDirID := fs.parID;
  286.         pb.ioNamePtr := @fs.name;
  287.         pb.ioFDirIndex := index;
  288.         FSpGetCatInfo := PBGetCatInfoSync(@pb);
  289.     end;
  290.  
  291.     function FSpSetCatInfo (var fs: FSSpec; var pb: CInfoPBRec): OSErr;
  292.     begin
  293.         pb.ioVRefNum := fs.vRefNum;
  294.         pb.ioDirID := fs.parID;
  295.         pb.ioNamePtr := @fs.name;
  296.         FSpSetCatInfo := PBSetCatInfoSync(@pb);
  297.     end;
  298.  
  299.     function MyFSMakeFSSpec (vrn: integer; dirID: longint; name: Str255; var fs: FSSpec): OSErr;
  300.         var
  301.             pb: CInfoPBRec;
  302.             oe: OSErr;
  303.             gv: longint;
  304.     begin
  305.         if (Gestalt(gestaltFSAttr, gv) = noErr) & (BTST(gv, gestaltHasFSSpecCalls)) then begin
  306.             oe := FSMakeFSSpec(vrn, dirID, name, fs);
  307.         end
  308.         else begin
  309.             oe := MyGetCatInfo(vrn, dirID, name, 0, pb);
  310.             if (oe = noErr) then begin
  311.                 fs.vRefNum := pb.ioVRefNum;
  312.                 fs.parID := pb.ioFlParID;
  313.                 fs.name := name;
  314.             end;
  315.         end;
  316.         MyFSMakeFSSpec := oe;
  317.     end;
  318.  
  319.     procedure MyGetModDate (var fs: FSSpec; var moddate: longint);
  320.         var
  321.             oe: OSErr;
  322.             pb: CInfoPBRec;
  323.     begin
  324.         oe := MyGetCatInfo(fs.vRefNum, fs.parID, fs.name, 0, pb);
  325.         if oe = noErr then begin
  326.             moddate := pb.ioFlMdDat
  327.         end
  328.         else begin
  329.             moddate := $80000000;
  330.         end;
  331.     end;
  332.  
  333.     function CopyData (src, dst: integer; len: longint): OSErr;
  334.         const
  335.             buffer_len = 4096;
  336.         var
  337.             buffer: array[1..buffer_len] of signedByte;
  338.             l: longint;
  339.             oe: OSErr;
  340.     begin
  341.         oe := noErr;
  342.         while (len > 0) & (oe = noErr) do begin
  343.             if len > SizeOf(buffer) then begin
  344.                 l := SizeOf(buffer);
  345.             end else begin
  346.                 l := len;
  347.             end;
  348.             oe := FSRead(src, l, @buffer);
  349.             if (l = 0) & (oe = noErr) then begin
  350.                 oe := -1;
  351.             end;
  352.             if oe = noErr then begin
  353.                 oe := MyFSWrite(dst, l, @buffer);
  354.             end;
  355.             len := len - l;
  356.         end;
  357.         CopyData := oe;
  358.     end;
  359.  
  360.     function DuplicateFile (var org, new: FSSpec): OSErr;
  361.         var
  362.             oe, ooe: OSErr;
  363.             fi: FInfo;
  364.             pb: CInfoPBRec;
  365.             orn, nrn: integer;
  366.             rlen, dlen: longint;
  367.     begin
  368.         oe := FSpGetFInfo(org, fi);
  369.         if oe = noErr then begin
  370.             oe := FSpCreate(new, fi.fdCreator, fi.fdType, 0);
  371.         end;
  372.         if oe = noErr then begin
  373.             oe := MyGetCatInfo(org.vRefNum, org.parID, org.name, 0, pb);
  374.             if oe = noErr then begin
  375.                 dlen := pb.ioFlLgLen;
  376.                 rlen := pb.ioFlRLgLen;
  377.                 pb.ioVRefNum := new.vRefNum;
  378.                 pb.ioDirID := new.parID;
  379.                 pb.ioNamePtr := @new.name;
  380.                 pb.ioFDirIndex := 0;
  381.                 oe := PBGetCatInfoSync(@pb);
  382.             end;
  383.  
  384.             if oe = noErr then begin
  385.                 oe := FSpOpenDF(org, fsRdPerm, orn);
  386.                 if oe = noErr then begin
  387.                     oe := FSpOpenDF(new, fsWrPerm, nrn);
  388.                     if oe = noErr then begin
  389.                         oe := CopyData(orn, nrn, dlen);
  390.                         ooe := FSClose(nrn);
  391.                         if oe = noErr then begin
  392.                             ooe := oe;
  393.                         end;
  394.                     end;
  395.                     ooe := FSClose(orn);
  396.                 end;
  397.             end;
  398.  
  399.             if oe = noErr then begin
  400.                 oe := FSpOpenRF(org, fsRdPerm, orn);
  401.                 if oe = noErr then begin
  402.                     oe := FSpOpenRF(new, fsWrPerm, nrn);
  403.                     if oe = noErr then begin
  404.                         oe := CopyData(orn, nrn, rlen);
  405.                         ooe := FSClose(nrn);
  406.                         if oe = noErr then begin
  407.                             ooe := oe;
  408.                         end;
  409.                     end;
  410.                     ooe := FSClose(orn);
  411.                 end;
  412.             end;
  413.  
  414.             if oe <> noErr then begin
  415.                 ooe := FSpDelete(new);
  416.             end;
  417.         end;
  418.         DuplicateFile := oe;
  419.     end;
  420.  
  421.     function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longint; p: ptr): OSErr;
  422.         var
  423.             pb: ParamBlockRec;
  424.             oe: OSErr;
  425.     begin
  426.         pb.ioRefNum := refnum;
  427.         pb.ioBuffer := p;
  428.         pb.ioReqCount := len;
  429.         pb.ioPosMode := mode;
  430.         pb.ioPosOffset := pos;
  431.         oe := PBWriteSync(@pb);
  432.         if (oe = noErr) & (pb.ioActCount <> len) then begin
  433.             oe := -1;
  434.         end;
  435.         MyFSWriteAt := oe;
  436.     end;
  437.  
  438.     const
  439.         maxk = $70000000 div 1024;
  440.  
  441.     function MultiplyAllocation (blocks, blocksize: longint): longint; { result in k }
  442.         var
  443.             size: longint;
  444.     begin
  445.         blocks := BAND(BSR(blocks, 1), $00007FFF); { div 2 }
  446.         blocksize := BAND(BSR(blocksize, 9), $007FFFFF); { div 512 }
  447.         if (blocksize > 256) & (blocks > 256) then begin
  448.             size := (blocksize div 16) * (blocks div 16);
  449.             if size > maxk div 256 then begin
  450.                 size := maxk div 256;
  451.             end;
  452.             size := size * 256;
  453.         end
  454.         else begin
  455.             size := blocksize * blocks; { in k }
  456.             if size > maxk then begin
  457.                 size := maxk;
  458.             end;
  459.         end;
  460.         MultiplyAllocation := size;
  461.     end;
  462.  
  463.  
  464.     function OldDiskFreeSpace (vrn: integer): longint; { result in k }
  465.         var
  466.             err: OSErr;
  467.             pb: HParamBlockRec;
  468.             free: longint;
  469.     begin
  470.         free := maxk;
  471.         pb.ioNamePtr := nil;
  472.         pb.ioVRefNum := vrn;
  473.         pb.ioVolIndex := 0;
  474.         err := PBHGetVInfoSync(@pb);
  475.         if err = noErr then begin
  476.             free := MultiplyAllocation(pb.ioVFrBlk, pb.ioVAlBlkSiz);
  477.         end;
  478.         OldDiskFreeSpace := free;
  479.     end;
  480.  
  481.     function DiskFreeSpace (vrn: integer): longint; { result in k }
  482.         var
  483.             err: OSErr;
  484.             free: longint;
  485.     begin
  486.         err := GetVInfo(vrn, nil, vrn, free);
  487.         if err <> noErr then begin
  488.             free := maxk;
  489.         end
  490.         else begin
  491.             if free < 0 then begin
  492.                 free := maxk;
  493.             end
  494.             else begin
  495.                 free := free div 1024;
  496.                 if free > maxk then begin
  497.                     free := maxk;
  498.                 end;
  499.             end;
  500.         end;
  501.         DiskFreeSpace := free;
  502.     end;
  503.  
  504.     function DiskSize (vrn: integer): longint; { result in k }
  505.         var
  506.             err: OSErr;
  507.             pb: HParamBlockRec;
  508.             size: longint;
  509.     begin
  510.         size := 0;
  511.         pb.ioNamePtr := nil;
  512.         pb.ioVRefNum := vrn;
  513.         pb.ioVolIndex := 0;
  514.         err := PBHGetVInfoSync(@pb);
  515.         if err = noErr then begin
  516.             size := MultiplyAllocation(pb.ioVNmAlBlks, pb.ioVAlBlkSiz);
  517.         end;
  518.         DiskSize := size;
  519.     end;
  520.  
  521.     function BlessSystemFolder (vrn: integer; dirID: longint): OSErr;
  522.         var
  523.             err: OSErr;
  524.             pb: HParamBlockRec;
  525.     begin
  526.         pb.ioNamePtr := nil;
  527.         pb.ioVRefNum := vrn;
  528.         pb.ioVolIndex := 0;
  529.         err := PBHGetVInfoSync(@pb);
  530.         if err = noErr then begin
  531.             pb.ioVFndrInfo[0] := dirID;  { ARGHHHHHHH! }
  532.             err := PBSetVInfoSync(@pb);
  533.         end;
  534.         BlessSystemFolder := err;
  535.     end;
  536.  
  537.     function SameFSSpec (var fs1, fs2: FSSpec): boolean;
  538.     begin
  539.         SameFSSpec := (fs1.vRefNum = fs2.vRefNum) & (fs1.parID = fs2.parID) & (IUEqualString(fs1.name, fs2.name) = 0);
  540.     end;
  541.  
  542.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longint): OSErr;
  543.         var
  544.             procID: longint;
  545.             oe: OSErr;
  546.     begin
  547.         oe := GetWDInfo(wdrn, vrn, dirID, procID);
  548.         if oe <> noErr then begin
  549.             vrn := wdrn;
  550.             dirID := 0;
  551.         end;
  552.         GetDirID := oe;
  553.     end;
  554.  
  555.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
  556.         var
  557.             pb: paramBlockRec;
  558.             oe: OSErr;
  559.     begin
  560.         if (name <> '') & (name[length(name)] <> ':') then begin
  561.             name := concat(name, ':');
  562.         end;
  563.         pb.ioNamePtr := @name;
  564.         pb.ioVRefNum := vrn;
  565.         pb.ioVolIndex := index;
  566.         oe := PBGetVInfoSync(@pb);
  567.         if oe = noErr then begin
  568.             vrn := pb.ioVRefNum;
  569.             CrDate := pb.ioVCrDate;
  570.         end;
  571.         GetVolInfo := oe;
  572.     end;
  573.  
  574. end.