← Back to branch summary

~ubuntu-branches/ubuntu/lucid/fpc/lucid-proposed

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/unzip/unzipdll.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-10-09 23:29:00 UTC
  • mfrom: (4.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20081009232900-553f61m37jkp6upv
Tags: 2.2.2-4
http://bugs.debian.org/498882
[ Torsten Werner ]
* Update ABI version in fpc-depends automatically.
* Remove empty directories from binary package fpc-source.

[ Mazen Neifer ]
* Removed leading path when calling update-alternatives to remove a Linitian
  error.
* Fixed clean target.
* Improved description of packages. (Closes: #498882)

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/extra/unzip/unzipdll.pp
1
 
{
2
 
}
3
 
unit UnzipDLL;
4
 
 
5
 
{$IFDEF VIRTUALPASCAL}
6
 
{$Cdecl+,AlignRec-,OrgName+}
7
 
{$ELSE}
8
 
 {$IFDEF FPC}
9
 
  {$PACKRECORDS 1}
10
 
 {$ENDIF}
11
 
{$ENDIF}
12
 
 
13
 
interface
14
 
 
15
 
uses
16
 
 ZipTypes;
17
 
 
18
 
const
19
 
 UnzipErr: longint = 0;
20
 
 
21
 
type
22
 
 TArgV = array [0..1023] of PChar;
23
 
 PArgV = ^TArgV;
24
 
 TCharArray = array [1..1024*1024] of char;
25
 
 PCharArray = ^TCharArray;
26
 
 TFileUnzipEx = function (SourceZipFile, TargetDirectory,
27
 
                                                    FileSpecs: PChar): integer;
28
 
 
29
 
function DllFileUnzipEx (SourceZipFile, TargetDirectory,
30
 
                                                    FileSpecs: PChar): integer;
31
 
 
32
 
const
33
 
 FileUnzipEx: TFileUnzipEx = @DllFileUnzipEx;
34
 
 
35
 
(* Returns non-zero result on success. *)
36
 
 
37
 
implementation
38
 
 
39
 
uses
40
 
{$IFDEF OS2}
41
 
 {$IFDEF FPC}
42
 
     DosCalls,
43
 
 {$ELSE FPC}
44
 
  {$IFDEF VirtualPascal}
45
 
     OS2Base,
46
 
  {$ELSE VirtualPascal}
47
 
     BseDos,
48
 
  {$ENDIF VirtualPascal}
49
 
 {$ENDIF FPC}
50
 
{$ELSE}
51
 
 {$IFDEF WIN32}
52
 
     Windows,
53
 
 {$ENDIF WIN32}
54
 
{$ENDIF OS2}
55
 
 Unzip, Dos;
56
 
 
57
 
type
58
 
 UzpMainFunc = function (ArgC: longint; var ArgV: TArgV): longint; cdecl;
59
 
 
60
 
const
61
 
{$IFDEF OS2}
62
 
 AllFiles: string [1] = '*';
63
 
{$ELSE}
64
 
 {$IFDEF WIN32}
65
 
 AllFiles: string [3] = '*.*';
66
 
 {$ENDIF}
67
 
{$ENDIF}
68
 
{$IFDEF OS2}
69
 
 LibPath = 'LIBPATH';
70
 
{$ELSE}
71
 
 LibPath = 'PATH';
72
 
{$ENDIF}
73
 
 UzpMainOrd = 4;
74
 
 DLLName: string [8] = 'UNZIP32'#0;
75
 
 UzpMain: UzpMainFunc = nil;
76
 
 QuietOpt: array [1..4] of char = '-qq'#0;
77
 
 OverOpt: array [1..3] of char = '-o'#0;
78
 
 CaseInsOpt: array [1..3] of char = '-C'#0;
79
 
 ExDirOpt: array [1..3] of char = '-d'#0;
80
 
 OptCount = 4;
81
 
 
82
 
var
83
 
 DLLHandle: longint;
84
 
 OldExit: pointer;
85
 
 C: char;
86
 
 
87
 
function DLLInit: boolean;
88
 
var
89
 
{$IFDEF OS2}
90
 
 ErrPath: array [0..259] of char;
91
 
{$ENDIF}
92
 
 DLLPath: PathStr;
93
 
 Dir: DirStr;
94
 
 Name: NameStr;
95
 
 Ext: ExtStr;
96
 
begin
97
 
 DLLInit := false;
98
 
 FSplit (FExpand (ParamStr (0)), Dir, Name, Ext);
99
 
 DLLPath := Dir + DLLName;
100
 
 Insert ('.DLL', DLLPath, byte (DLLPath [0]));
101
 
{$IFDEF OS2}
102
 
 if (DosLoadModule (@ErrPath, SizeOf (ErrPath), @DLLPath [1], DLLHandle) <> 0)
103
 
 and (DosLoadModule (@ErrPath, SizeOf (ErrPath), @DLLName [1], DLLHandle) <> 0)
104
 
                                                                           then
105
 
 begin
106
 
  if ErrPath [0] <> #0 then
107
 
  begin
108
 
   Write (#13#10'Error while loading module ');
109
 
   WriteLn (PChar (@ErrPath));
110
 
  end;
111
 
 {$IFDEF FPC}
112
 
 end else DLLInit := DosQueryProcAddr (DLLHandle, UzpMainOrd, nil, pointer (UzpMain)) = 0;
113
 
 {$ELSE}
114
 
 end else DLLInit := DosQueryProcAddr (DLLHandle, UzpMainOrd, nil, @UzpMain) = 0;
115
 
 {$ENDIF}
116
 
{$ELSE}
117
 
 {$IFDEF WIN32}
118
 
 DLLHandle := LoadLibrary (@DLLPath [1]);
119
 
 if DLLHandle = 0 then DLLHandle := LoadLibrary (@DLLName [1]);
120
 
 if DLLHandle = 0 then WriteLn (#13#10'Error while loading DLL.') else
121
 
 begin
122
 
(*  UzpMain := UzpMainFunc (GetProcAddress (DLLHandle, 'UzpMain'));
123
 
*)
124
 
  UzpMain := UzpMainFunc (GetProcAddress (DLLHandle, 'Unz_Unzip'));
125
 
  DLLInit := Assigned (UzpMain);
126
 
 end;
127
 
 {$ENDIF}
128
 
{$ENDIF}
129
 
end;
130
 
 
131
 
procedure NewExit;
132
 
begin
133
 
 ExitProc := OldExit;
134
 
{$IFDEF OS2}
135
 
 DosFreeModule (DLLHandle);
136
 
{$ELSE}
137
 
 {$IFDEF WIN32}
138
 
 FreeLibrary (DLLHandle);
139
 
 {$ENDIF}
140
 
{$ENDIF}
141
 
end;
142
 
 
143
 
function DllFileUnzipEx (SourceZipFile, TargetDirectory,
144
 
                                                    FileSpecs: PChar): integer;
145
 
var
146
 
 I, FCount, ArgC: longint;
147
 
 ArgV: TArgV;
148
 
 P: PChar;
149
 
 StrLen: array [Succ (OptCount)..1023] of longint;
150
 
begin
151
 
 ArgV [0] := @DLLName;
152
 
 ArgV [1] := @QuietOpt;
153
 
 ArgV [2] := @OverOpt;
154
 
 ArgV [3] := @CaseInsOpt;
155
 
 ArgV [4] := SourceZipFile;
156
 
 FCount := 0;
157
 
 if FileSpecs^ <> #0 then
158
 
 begin
159
 
  P := FileSpecs;
160
 
  I := 0;
161
 
  repeat
162
 
   case FileSpecs^ of
163
 
    '"': begin
164
 
          Inc (FileSpecs);
165
 
          repeat Inc (I) until (FileSpecs^ = '"') or (FileSpecs^ = #0);
166
 
          Inc (FileSpecs);
167
 
          Inc (I);
168
 
         end;
169
 
    '''':  begin
170
 
            Inc (FileSpecs);
171
 
            repeat Inc (I) until (FileSpecs^ = '''') or (FileSpecs^ = #0);
172
 
            Inc (FileSpecs);
173
 
            Inc (I);
174
 
           end;
175
 
    #0, ' ', #9: begin
176
 
                  Inc (I);
177
 
                  Inc (FCount);
178
 
                  GetMem (ArgV [OptCount + FCount], I);
179
 
                  Move (P^, ArgV [OptCount + FCount]^, Pred (I));
180
 
                  PCharArray (ArgV [OptCount + FCount])^ [I] := #0;
181
 
                  StrLen [OptCount + FCount] := I;
182
 
                  while (FileSpecs^ = #9) or (FileSpecs^ = ' ') do Inc (FileSpecs);
183
 
                  P := FileSpecs;
184
 
                  I := 0;
185
 
                 end;
186
 
    else
187
 
    begin
188
 
     Inc (I);
189
 
     Inc (FileSpecs);
190
 
    end;
191
 
   end;
192
 
  until (FileSpecs^ = #0) and (I = 0);
193
 
 end else
194
 
 begin
195
 
  FCount := 1;
196
 
  StrLen [OptCount + FCount] := Succ (byte (AllFiles [0]));
197
 
  GetMem (ArgV [OptCount + FCount], StrLen [OptCount + FCount]);
198
 
  Move (AllFiles [1], ArgV [OptCount + FCount]^, StrLen [OptCount + FCount]);
199
 
 end;
200
 
 ArgC := Succ (FCount + OptCount);
201
 
 ArgV [ArgC] := @ExDirOpt;
202
 
 Inc (ArgC);
203
 
 ArgV [ArgC] := TargetDirectory;
204
 
 Inc (ArgC);
205
 
 ArgV [ArgC] := @ExDirOpt [3]; (* contains #0 *)
206
 
 UnzipErr := UzpMain (ArgC, ArgV);
207
 
 if UnzipErr <> 0 then DllFileUnzipEx := 0 else DllFileUnzipEx := FCount;
208
 
 for I := 1 to FCount do FreeMem (ArgV [I + OptCount], StrLen [I + OptCount]);
209
 
end;
210
 
 
211
 
begin
212
 
{$IFDEF EMX}
213
 
 if os_Mode <> osOS2 then
214
 
  FileUnzipEx := TFileUnzipEx (@Unzip.FileUnzipEx)
215
 
 else
216
 
{$ENDIF EMX}
217
 
 if DLLInit then
218
 
 begin
219
 
  OldExit := ExitProc;
220
 
  ExitProc := @NewExit;
221
 
  if GetEnv ('TZ') = '' then
222
 
  begin
223
 
   WriteLn (#13#10'TZ variable was not found in your environment.');
224
 
   WriteLn ('This variable is necessary for setting correct date/time of unpacked files.');
225
 
   WriteLn ('Please, add it to your environment and restart this program afterwards.');
226
 
   Halt (1);
227
 
  end;
228
 
 end else
229
 
 begin
230
 
  WriteLn (#13#10'Dynamic library UNZIP32.DLL from InfoZip is needed to unpack archives.');
231
 
  WriteLn ('This library could not be found on your system, however.');
232
 
  WriteLn ('Please, download the library, either from the location where you found');
233
 
  WriteLn ('this package, or from any FTP archive carrying InfoZip programs.');
234
 
  WriteLn ('If you already have this DLL, please, check your configuration (' + LibPath + ').');
235
 
  WriteLn (#13#10'If you want to try unpacking the files with internal unpacking routine,');
236
 
  WriteLn ('answer the following question with Y. However, this might not work correctly');
237
 
  WriteLn ('under some conditions (e.g. for long names and drives not supporting them).');
238
 
  Write (#13#10'Do you want to continue now (y/N)? ');
239
 
  ReadLn (C);
240
 
  if UpCase (C) = 'Y' then FileUnzipEx := TFileUnzipEx (@Unzip.FileUnzipEx) else Halt (255);
241
 
 end;
242
 
end.