* updates from TH for OS2

install/install.pas

@@ -16,10 +16,48 @@
  **********************************************************************}
 program install;
 
-{$DEFINE FV}
+{$DEFINE FV}       (* TH - added to make use of the original Turbo Vision possible. *)
+{ $DEFINE DLL}      (* TH - if defined, UNZIP32.DLL library is used to unpack. *)
+{ $DEFINE DOSSTUB}   (* TH - should _not_ be defined unless creating a bound DOS and OS/2 installer!!! *)
+(* Defining DOSSTUB causes adding a small piece of code    *)
+(* for starting the OS/2 part from the DOS part of a bound *)
+(* application if running in OS/2 VDM (DOS) window. Used   *)
+(* only if compiling with TP/BP (see conditionals below).  *)
+
+{$IFDEF VER60}
+ {$DEFINE TP}
+{$ENDIF}
+
+{$IFDEF VER70}
+ {$DEFINE TP}
+{$ENDIF}
 
 {$IFDEF OS2}
  {$UNDEF FV}
+ {$IFDEF DOSSTUB}
+  {$UNDEF DOSSTUB}
+ {$ENDIF}
+ {$IFDEF VIRTUALPASCAL}
+  {$DEFINE DLL}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF WIN32}
+ {$IFDEF DOSSTUB}
+  {$UNDEF DOSSTUB}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF FPC}
+ {$IFDEF DOSSTUB}
+  {$UNDEF DOSSTUB}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF DPMI}
+ {$IFDEF DOSSTUB}
+  {$UNDEF DOSSTUB}
+ {$ENDIF}
 {$ENDIF}
 
   uses
@@ -34,19 +72,32 @@ program install;
   {$ENDIF VirtualPascal}
  {$ENDIF FPC}
 {$ENDIF OS2}
+{$ifdef HEAPTRC}
+     heaptrc,
+{$endif HEAPTRC}
      strings,dos,objects,drivers,
 {$IFDEF FV}
      commands,
 {$ENDIF}
-     app,dialogs,views,menus,msgbox,
-     unzip,ziptypes;
+     unzip,ziptypes,
+{$IFDEF DLL}
+     unzipdll,
+{$ENDIF}
+     app,dialogs,views,menus,msgbox;
+
 
   const
      maxpackages=20;
-     maxdefcfgs=200;
+     maxdefcfgs=1024;
 
      cfgfile='install.dat';
 
+{$ifdef linux}
+     DirSep='/';
+{$else}
+     DirSep='\';
+{$endif}
+
   type
      tpackage=record
        name : string[60];
@@ -94,6 +145,30 @@ program install;
          procedure do_installdialog;
          procedure readcfg(const fn:string);
      end;
+{$IFDEF DOSSTUB}
+ PByte = ^byte;
+ PRunBlock = ^TRunBlock;
+ TRunBlock = record
+  Length: word;
+  Dependent: word;
+  Background: word;
+  TraceLevel: word;
+  PrgTitle: PChar;
+  PrgName: PChar;
+  Args: PChar;
+  TermQ: longint;
+  Environment: pointer;
+  Inheritance: word;
+  SesType: word;
+  Icon: pointer;
+  PgmHandle: longint;
+  PgmControl: word;
+  Column: word;
+  Row: word;
+  Width: word;
+  Height: word;
+ end;
+{$ENDIF}
 
   var
      installapp  : tapp;
@@ -132,6 +207,7 @@ program install;
     end;
 
 
+(* TH - not needed any more
   function lower(const s : string):string;
     var
        i : integer;
@@ -144,6 +220,7 @@ program install;
        lower[0]:=s[0];
     end;
 
+*)
 
   procedure Replace(var s:string;const s1,s2:string);
     var
@@ -166,16 +243,25 @@ program install;
     end;
 
 
-  function diskspace(const zipfile : string) : string;
+  function DiskSpaceN(const zipfile : string) : longint;
     var
       compressed,uncompressed : longint;
       s : string;
     begin
       s:=zipfile+#0;
       uncompressed:=UnzipSize(@s[1],compressed);
-      uncompressed:=uncompressed shr 10;
+      DiskSpaceN:=uncompressed shr 10;
+    end;
+
+
+  function diskspace(const zipfile : string) : string;
+    var
+      uncompressed : longint;
+      s : string;
+    begin
+      uncompressed:=DiskSpaceN (zipfile);
       str(uncompressed,s);
-      diskspace:=' ('+s+' Kb)';
+      diskspace:=' ('+s+' KB)';
     end;
 
 
@@ -183,7 +269,7 @@ program install;
     var
       start,
       s1 : string;
-      i,result : longint;
+      i : longint;
       err : boolean;
       dir : searchrec;
       params : array[0..0] of pointer;
@@ -193,10 +279,17 @@ program install;
        FindFirst(s,AnyFile,dir);
        if doserror=0 then
          begin
-            result:=messagebox('The installation directory exists already. '+
-              'Do you want to enter a new installation directory ?',nil,
-              mferror+mfyesbutton+mfnobutton);
-            createdir:=(result=cmNo);
+(* TH - check the directory attribute! *)
+            if Dir.Attr and Directory = 0 then
+              begin
+                messagebox('A file with the name chosen as the installation '+
+                'directory exists already. Cannot create this directory!',nil,
+                mferror+mfokbutton);
+                createdir:=false;
+              end else
+                createdir:=messagebox('The installation directory exists already. '+
+                'Do you want to enter a new installation directory ?',nil,
+                mferror+mfyesbutton+mfnobutton)=cmNo;
             exit;
          end;
        err:=false;
@@ -238,11 +331,24 @@ program install;
             exit;
          end;
 {$ifndef TP}
+ {$IFNDEF OS2}
        FindClose (dir);
+ {$ENDIF}
 {$endif}
        createdir:=true;
     end;
 
+  function GetProgDir: DirStr;
+    var
+      D: DirStr;
+      N: NameStr;
+      E: ExtStr;
+    begin
+       FSplit (FExpand (ParamStr (0)), D, N, E);
+       if (D [0] <> #0) and (D [byte (D [0])] = '\') then Dec (D [0]);
+       GetProgDir := D;
+    end;
+
 
 {*****************************************************************************
                           Writing of ppc386.cfg
@@ -256,7 +362,7 @@ program install;
       dir    : searchrec;
       params : array[0..0] of pointer;
     begin
-      findfirst(fn,$ff,dir);
+      findfirst(fn,AnyFile,dir);
       if doserror=0 then
        begin
          params[0]:=@fn;
@@ -273,7 +379,7 @@ program install;
          MessageBox(#3'Default config not written.'#13#3'%s'#13#3'couldn''t be created',@params,mfinformation+mfokbutton);
          exit;
        end;
-      for i:=1to cfg.defcfgs do
+      for i:=1 to cfg.defcfgs do
        if assigned(cfg.defcfg[i]) then
          begin
            s:=cfg.defcfg[i]^;
@@ -317,8 +423,18 @@ program install;
        fn:=startpath+DirSep+s+#0;
        dir:=topath+#0;
        wild:=AllFiles + #0;
-       FileUnzipEx(@fn[1],@dir[1],@wild[1]);
+(* TH - added to clear the previous state of DosError *)
+       DosError := 0;
+{$IFDEF DLL}
+       if
+{$ENDIF}
+          FileUnzipEx(@fn[1],@dir[1],@wild[1])
+{$IFDEF DLL}
+                                               = 0 then
+{$ELSE}
+                                              ;
        if doserror<>0 then
+{$ENDIF}
          begin
             messagebox('Error when extracting. Disk full?',nil,mferror+mfokbutton);
             errorhalt;
@@ -335,19 +451,69 @@ program install;
       R       : TRect;
       P       : PStaticText;
       Control : PButton;
+      YB: word;
+{$IFNDEF LINUX}
+      S: string;
+      WPath: boolean;
+{$ENDIF}
+{$IFDEF OS2}
+      ErrPath: array [0..259] of char;
+      Handle: longint;
+      WLibPath: boolean;
+    const
+      EMXName: array [1..4] of char = 'EMX'#0;
+{$ENDIF}
     begin
-      R.Assign(6, 6, 74, 16);
+      YB := 14;
+
+{$IFNDEF LINUX}
+      S := Data.BasePath + Cfg.BinSub;
+      if Pos (Upper (S), Upper (GetEnv ('PATH'))) = 0 then
+      begin
+       WPath := true;
+       Inc (YB, 2);
+      end else WPath := false;
+ {$IFDEF OS2}
+      if DosLoadModule (@ErrPath, SizeOf (ErrPath), @EMXName, Handle) = 0 then
+      begin
+       WLibPath := false;
+       DosFreeModule (Handle);
+      end else
+      begin
+       WLibPath := true;
+       Inc (YB, 2);
+      end;
+ {$ENDIF}
+{$ENDIF}
+
+      R.Assign(6, 6, 74, YB);
       inherited init(r,'Installation Successfull');
 
-      R.Assign(2, 2, 64, 5);
-      P:=new(pstatictext,init(r,'Extend your PATH variable with '''+data.basepath+cfg.binsub+''''));
-      insert(P);
+{$IFNDEF LINUX}
+      if WPath then
+      begin
+       R.Assign(2, 3, 64, 5);
+       P:=new(pstatictext,init(r,'Extend your PATH variable with '''+S+''''));
+       insert(P);
+      end;
+
+ {$IFDEF OS2}
+      if WLibPath then
+      begin
+       if WPath then S := 'and your LIBPATH with ''' + S + '\dll''' else
+                             S := 'Extend your LIBPATH with ''' + S + '\dll''';
+       R.Assign (2, YB - 13, 64, YB - 11);
+       P := New (PStaticText, Init (R, S));
+       Insert (P);
+      end;
+ {$ENDIF}
+{$ENDIF}
 
-      R.Assign(2, 4, 64, 5);
+      R.Assign(2, YB - 11, 64, YB - 10);
       P:=new(pstatictext,init(r,'To compile files enter '''+cfg.ppc386+' [file]'''));
       insert(P);
 
-      R.Assign (29, 7, 39, 9);
+      R.Assign (29, YB - 9, 39, YB - 7);
       Control := New (PButton, Init (R,'~O~k', cmOK, bfDefault));
       Insert (Control);
     end;
@@ -442,7 +608,8 @@ program install;
        r    : trect;
        result,
        c    : word;
-       i    : longint;
+       i, DSize, Space : longint;
+       S: DirStr;
     begin
       data.basepath:=cfg.basepath;
       data.mask:=0;
@@ -453,18 +620,43 @@ program install;
         c:=executedialog(p,@data);
         if (c=cmok) then
           begin
-            if (data.mask>0) then
-             begin
-               if createdir(data.basepath) then
-                break;
-             end
-            else
+            if Data.BasePath = '' then
+              messagebox('Please, choose the directory for installation first.',nil,
+                 mferror+mfokbutton) else
              begin
+              if (data.mask>0) then
+               begin
+(* TH - check the available disk space here *)
+{$IFNDEF LINUX}
+                DSize := 0;
+                for i:=1 to cfg.packages do
+                begin
+                 if data.mask and packagemask(i)<>0 then
+                 Inc (DSize, DiskSpaceN(cfg.package[i].zip));
+                end;
+                S := FExpand (Data.BasePath);
+                Space := DiskFree (byte (S [1]) - 64) shr 10;
+                if Space < DSize then S := 'is not' else S := '';
+                if Space < DSize + 500 then
+                 begin
+                  if S = '' then S := 'might not be';
+                  if messagebox('There ' + S + ' enough space on the target ' +
+                    'drive for all the selected components. Do you ' +
+                    'want to change the installation path?',nil,
+                    mferror+mfyesbutton+mfnobutton) = cmYes then Continue;
+                 end;
+{$ENDIF}
+                if createdir(data.basepath) then
+                 break;
+              end
+             else
+              begin
                result:=messagebox('No components selected.'#13#13'Abort installation?',nil,
                  mferror+mfyesbutton+mfnobutton);
                if result=cmYes then
                 exit;
-             end;
+              end;
+            end;
           end
         else
           exit;
@@ -474,7 +666,7 @@ program install;
       r.assign(20,7,60,16);
       p2:=new(punzipdialog,init(r,'Extracting files'));
       desktop^.insert(p2);
-      for i:=1to cfg.packages do
+      for i:=1 to cfg.packages do
        begin
          if data.mask and packagemask(i)<>0 then
           p2^.do_unzip(cfg.package[i].zip,data.basepath);
@@ -524,15 +716,23 @@ program install;
 {$endif}
 
     begin
-      assign(t,fn);
+      assign(t,StartPath + DirSep + fn);
       {$I-}
        reset(t);
       {$I+}
       if ioresult<>0 then
        begin
-         params[0]:=@fn;
-         messagebox('File %s not found!',@params,mferror+mfokbutton);
-         errorhalt;
+         StartPath := GetProgDir;
+         assign(t,StartPath + DirSep + fn);
+         {$I-}
+          reset(t);
+         {$I+}
+         if ioresult<>0 then
+          begin
+            params[0]:=@fn;
+            messagebox('File %s not found!',@params,mferror+mfokbutton);
+            errorhalt;
+          end;
        end;
       line:=0;
       while not eof(t) do
@@ -625,8 +825,83 @@ program install;
            end;
     end;
 
+{$IFDEF DOSSTUB}
+function CheckOS2: boolean;
+var
+ OwnName: PathStr;
+ OwnDir: DirStr;
+ Name: NameStr;
+ Ext: ExtStr;
+ DosV, W: word;
+ P: PChar;
+const
+ Title: string [15] = 'FPC Installer'#0;
+ RunBlock: TRunBlock = (Length: $32;
+                        Dependent: 0;
+                        Background: 0;
+                        TraceLevel: 0;
+                        PrgTitle: @Title [1];
+                        PrgName: nil;
+                        Args: nil;
+                        TermQ: 0;
+                        Environment: nil;
+                        Inheritance: 0;
+                        SesType: 2;
+                        Icon: nil;
+                        PgmHandle: 0;
+                        PgmControl: 2;
+                        Column: 0;
+                        Row: 0;
+                        Width: 80;
+                        Height: 25);
+begin
+ CheckOS2 := false;
+ asm
+  mov ah, 30h
+  int 21h
+  xchg ah, al
+  mov DosV, ax
+  mov ax, 4010h
+  int 2Fh
+  cmp ax, 4010h
+  jnz @0
+  xor bx, bx
+@0:
+  mov W, bx
+ end;
+ if DosV > 3 shl 8 then
+ begin
+  OwnName := FExpand (ParamStr (0));
+  FSplit (OwnName, OwnDir, Name, Ext);
+  if (DosV >= 20 shl 8 + 10) and (W >= 20 shl 8 + 10) then
+                       (* OS/2 version 2.1 or later running (double-checked) *)
+  begin
+   OwnName [Succ (byte (OwnName [0]))] := #0;
+   RunBlock.PrgName := @OwnName [1];
+   P := Ptr (PrefixSeg, $80);
+   if PByte (P)^ <> 0 then
+   begin
+    Inc (P);
+    RunBlock.Args := Ptr (PrefixSeg, $81);
+   end;
+   asm
+    mov ax, 6400h
+    mov bx, 0025h
+    mov cx, 636Ch
+    mov si, offset RunBlock
+    int 21h
+    jc @0
+    mov DosV, 0
+@0:
+   end;
+   CheckOS2 := DosV = 0;
+  end;
+ end;
+end;
+{$ENDIF}
 
 begin
+(* TH - no error boxes if checking an inaccessible disk etc. *)
 {$IFDEF OS2}
  {$IFDEF FPC}
    DosCalls.DosError (0);
@@ -637,6 +912,9 @@ begin
    BseDos.DosError (0);
   {$ENDIF VirtualPascal}
  {$ENDIF FPC}
+{$ENDIF}
+{$IFDEF DOSSTUB}
+   if CheckOS2 then Halt;
 {$ENDIF}
    getdir(0,startpath);
    successfull:=false;
@@ -646,12 +924,16 @@ begin
 
    installapp.init;
    installapp.readcfg(cfgfile);
+{   installapp.readcfg(startpath+dirsep+cfgfile);}
    installapp.do_installdialog;
    installapp.done;
 end.
 {
   $Log$
-  Revision 1.14  1998-12-22 22:47:34  peter
+  Revision 1.15  1999-02-17 22:34:08  peter
+    * updates from TH for OS2
+
+  Revision 1.14  1998/12/22 22:47:34  peter
     * updates for OS2
     * small fixes
 
@@ -695,3 +977,4 @@ end.
     + version/release/patch numbers as string added
 
 }
+

install/unzipdll.pas

@@ -0,0 +1,173 @@
+unit UnzipDLL;
+
+{$Cdecl+,AlignRec-,OrgName+}
+
+interface
+
+const
+{$IFDEF OS2}
+ AllFiles: string [1] = '*';
+{$ELSE}
+ AllFiles: string [3] = '*.*';
+{$ENDIF}
+
+type
+ TArgV = array [0..1024] of PChar;
+ PArgV = ^TArgV;
+ TCharArray = array [1..1024*1024] of char;
+ PCharArray = ^TCharArray;
+
+function FileUnzipEx (SourceZipFile, TargetDirectory,
+                                                    FileSpecs: PChar): integer;
+
+implementation
+
+uses
+{$IFDEF OS2}
+ {$IFDEF FPC}
+     DosCalls,
+ {$ELSE FPC}
+  {$IFDEF VirtualPascal}
+     OS2Base,
+  {$ELSE VirtualPascal}
+     BseDos,
+  {$ENDIF VirtualPascal}
+ {$ENDIF FPC}
+{$ENDIF OS2}
+ Dos;
+
+type
+ UzpMainFunc = function (ArgC: longint; var ArgV: TArgV): longint;
+(* var ArgV ??? *)
+
+const
+{$IFDEF OS2}
+ LibPath = 'LIBPATH';
+{$ELSE}
+ LibPath = 'PATH';
+{$ENDIF}
+ UzpMainOrd = 4;
+ DLLName: string [8] = 'UNZIP32'#0;
+ UzpMain: UzpMainFunc = nil;
+ QuiteOpt: array [1..4] of char = '-qq'#0;
+ OverOpt: array [1..3] of char = '-o'#0;
+ CaseInsOpt: array [1..3] of char = '-C'#0;
+ ExDirOpt: array [1..3] of char = '-d'#0;
+ OptCount = 4;
+
+var
+ DLLHandle: longint;
+ OldExit: pointer;
+
+function DLLInit: boolean;
+var
+ ErrPath: array [0..259] of char;
+ DLLPath: PathStr;
+ Dir: DirStr;
+ Name: NameStr;
+ Ext: ExtStr;
+begin
+ DLLInit := false;
+ FSplit (FExpand (ParamStr (0)), Dir, Name, Ext);
+ DLLPath := Dir + DLLName;
+ Insert ('.DLL', DLLPath, byte (DLLPath [0]));
+ if (DosLoadModule (@ErrPath, SizeOf (ErrPath), @DLLPath [1], DLLHandle) <> 0)
+ and (DosLoadModule (@ErrPath, SizeOf (ErrPath), @DLLName [1], DLLHandle) <> 0)
+                                                                           then
+ begin
+  if ErrPath [0] <> #0 then
+  begin
+   Write (#13#10'Error while loading module ');
+   WriteLn (PChar (@ErrPath));
+  end;
+ end else DLLInit := DosQueryProcAddr (DLLHandle, UzpMainOrd, nil, @UzpMain) = 0;
+end;
+
+procedure NewExit;
+begin
+ ExitProc := OldExit;
+ DosFreeModule (DLLHandle);
+end;
+
+function FileUnzipEx;
+var
+ I, FCount, ArgC: longint;
+ ArgV: TArgV;
+ P: PChar;
+ StrLen: array [Succ (OptCount)..1024] of longint;
+begin
+ ArgV [0] := @DLLName;
+ ArgV [1] := @QuiteOpt;
+ ArgV [2] := @OverOpt;
+ ArgV [3] := @CaseInsOpt;
+ ArgV [4] := SourceZipFile;
+ FCount := 0;
+ if FileSpecs^ <> #0 then
+ begin
+  P := FileSpecs;
+  I := 0;
+  repeat
+   case FileSpecs^ of
+    '"': begin
+          Inc (FileSpecs);
+          repeat Inc (I) until (FileSpecs^ = '"') or (FileSpecs^ = #0);
+          Inc (FileSpecs);
+          Inc (I);
+         end;
+    '''':  begin
+            Inc (FileSpecs);
+            repeat Inc (I) until (FileSpecs^ = '''') or (FileSpecs^ = #0);
+            Inc (FileSpecs);
+            Inc (I);
+           end;
+    #0, ' ', #9: begin
+                  Inc (I);
+                  Inc (FCount);
+                  GetMem (ArgV [OptCount + FCount], I);
+                  Move (P^, ArgV [OptCount + FCount]^, Pred (I));
+                  PCharArray (ArgV [OptCount + FCount])^ [I] := #0;
+                  StrLen [OptCount + FCount] := I;
+                  while (FileSpecs^ = #9) or (FileSpecs^ = ' ') do Inc (FileSpecs);
+                  P := FileSpecs;
+                  I := 0;
+                 end;
+    else
+    begin
+     Inc (I);
+     Inc (FileSpecs);
+    end;
+   end;
+  until (FileSpecs^ = #0) and (I = 0);
+ end else
+ begin
+  FCount := 1;
+  StrLen [OptCount + FCount] := Succ (byte (AllFiles [0]));
+  GetMem (ArgV [OptCount + FCount], StrLen [OptCount + FCount]);
+  Move (AllFiles [1], ArgV [OptCount + FCount]^, StrLen [OptCount + FCount]);
+ end;
+ ArgC := Succ (FCount + OptCount);
+ ArgV [ArgC] := @ExDirOpt;
+ Inc (ArgC);
+ ArgV [ArgC] := TargetDirectory;
+ Inc (ArgC);
+ ArgV [ArgC] := @ExDirOpt [3]; (* contains #0 *)
+ if UzpMain (ArgC, ArgV) <> 0 then FileUnzipEx := 0 else FileUnzipEx := FCount;
+ for I := 1 to FCount do FreeMem (ArgV [I + OptCount], StrLen [I + OptCount]);
+end;
+
+begin
+ if DLLInit then
+ begin
+  OldExit := ExitProc;
+  ExitProc := @NewExit;
+ end else
+ begin
+  WriteLn (#13#10'Dynamic library UNZIP32.DLL from InfoZip is needed to install.');
+  WriteLn ('This library could not be found on your system, however.');
+  WriteLn ('Please, download the library, either from the location where you found');
+  WriteLn ('this installer, or from any FTP archive carrying InfoZip programs.');
+  WriteLn ('If you have this DLL on your disk, please, check your configuration (' + LIBPATH + ').');
+  Halt (255);
+ end;
+end.
+