← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to rtl/beos/beos.pp

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2004-08-12 16:29:37 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040812162937-moo8ulvysp1ln771
Tags: 1.9.4-5
http://bugs.debian.org/265265
fp-compiler: needs ld, adding dependency on binutils.  (Closes: #265265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/beos/beos.pp
 
1
unit beos;
 
2
 
 
3
interface
 
4
 
 
5
type
 
6
    Stat = packed record
 
7
      dev:longint;     {"device" that this file resides on}
 
8
      ino:int64;       {this file's inode #, unique per device}
 
9
      mode:dword;      {mode bits (rwx for user, group, etc)}
 
10
      nlink:longint;   {number of hard links to this file}
 
11
      uid:dword;       {user id of the owner of this file}
 
12
      gid:dword;       {group id of the owner of this file}
 
13
      size:int64;      {size of this file (in bytes)}
 
14
      rdev:longint;    {device type (not used)}
 
15
      blksize:longint; {preferref block size for i/o}
 
16
      atime:longint;   {last access time}
 
17
      mtime:longint;   {last modification time}
 
18
      ctime:longint;   {last change time, not creation time}
 
19
      crtime:longint;  {creation time}
 
20
    end;
 
21
    PStat=^Stat;
 
22
    TStat=Stat;
 
23
 
 
24
                ComStr  = String[255];
 
25
                  PathStr = String[255];
 
26
                    DirStr  = String[255];
 
27
                      NameStr = String[255];
 
28
        ExtStr  = String[255];
 
29
 
 
30
function FStat(Path:String;Var Info:stat):Boolean;
 
31
function FStat(var f:File;Var Info:stat):Boolean;
 
32
function GetEnv(P: string): pchar;
 
33
 
 
34
function  FExpand(Const Path: PathStr):PathStr;
 
35
function  FSearch(const path:pathstr;dirlist:string):pathstr;
 
36
procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
 
37
function  Dirname(Const path:pathstr):pathstr;
 
38
function  Basename(Const path:pathstr;Const suf:pathstr):pathstr;
 
39
function  FNMatch(const Pattern,Name:string):Boolean;
 
40
{function  StringToPPChar(Var S:STring):ppchar;}
 
41
 
 
42
function PExists(path:string):boolean;
 
43
function FExists(path:string):boolean;
 
44
 
 
45
Function Shell(const Command:String):Longint;
 
46
 
 
47
implementation
 
48
 
 
49
uses strings;
 
50
 
 
51
{$i filerec.inc}
 
52
{$i textrec.inc}
 
53
 
 
54
function sys_stat (a:cardinal;path:pchar;info:pstat;n:longint):longint; cdecl; external name 'sys_stat';
 
55
 
 
56
function FStat(Path:String;Var Info:stat):Boolean;
 
57
{
 
58
  Get all information on a file, and return it in Info.
 
59
}
 
60
var tmp:string;
 
61
var p:pchar;
 
62
begin
 
63
  tmp:=path+#0;
 
64
  p:=@tmp[1];
 
65
  FStat:=(sys_stat($FF000000,p,@Info,0)=0);
 
66
end;
 
67
 
 
68
function FStat(var f:File;Var Info:stat):Boolean;
 
69
{
 
70
  Get all information on a file, and return it in Info.
 
71
}
 
72
begin
 
73
  FStat:=(sys_stat($FF000000,PChar(@FileRec(f).Name),@Info,0)=0);
 
74
end;
 
75
 
 
76
 
 
77
 
 
78
Function GetEnv(P:string):Pchar;
 
79
{
 
80
  Searches the environment for a string with name p and
 
81
  returns a pchar to it's value.
 
82
  A pchar is used to accomodate for strings of length > 255
 
83
}
 
84
var
 
85
  ep    : ppchar;
 
86
  found : boolean;
 
87
Begin
 
88
  p:=p+'=';            {Else HOST will also find HOSTNAME, etc}
 
89
  ep:=envp;
 
90
  found:=false;
 
91
  if ep<>nil then
 
92
   begin
 
93
     while (not found) and (ep^<>nil) do
 
94
      begin
 
95
        if strlcomp(@p[1],(ep^),length(p))=0 then
 
96
         found:=true
 
97
        else
 
98
         inc(ep);
 
99
      end;
 
100
   end;
 
101
  if found then
 
102
   getenv:=ep^+length(p)
 
103
  else
 
104
   getenv:=nil;
 
105
{  writeln ('GETENV (',P,') =',getenv);}
 
106
end;
 
107
 
 
108
 
 
109
 
 
110
Function StringToPPChar(Var S:String; Var nr:longint):ppchar;
 
111
{
 
112
  Create a PPChar to structure of pchars which are the arguments specified
 
113
  in the string S. Especially usefull for creating an ArgV for Exec-calls
 
114
}
 
115
var
 
116
  Buf : ^char;
 
117
  p   : ppchar;
 
118
begin
 
119
  s:=s+#0;
 
120
  buf:=@s[1];
 
121
  nr:=0;
 
122
  while(buf^<>#0) do
 
123
   begin
 
124
     while (buf^ in [' ',#8,#10]) do
 
125
      inc(buf);
 
126
     inc(nr);
 
127
     while not (buf^ in [' ',#0,#8,#10]) do
 
128
      inc(buf);
 
129
   end;
 
130
  getmem(p,nr*4);
 
131
  StringToPPChar:=p;
 
132
  if p=nil then
 
133
   begin
 
134
{     LinuxError:=sys_enomem;}
 
135
     exit;
 
136
   end;
 
137
  buf:=@s[1];
 
138
  while (buf^<>#0) do
 
139
   begin
 
140
     while (buf^ in [' ',#8,#10]) do
 
141
      begin
 
142
        buf^:=#0;
 
143
        inc(buf);
 
144
      end;
 
145
     p^:=buf;
 
146
     inc(p);
 
147
     p^:=nil;
 
148
     while not (buf^ in [' ',#0,#8,#10]) do
 
149
      inc(buf);
 
150
   end;
 
151
end;
 
152
 
 
153
 
 
154
 
 
155
{
 
156
function FExpand (const Path: PathStr): PathStr;
 
157
- declared in fexpand.inc
 
158
}
 
159
 
 
160
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
 
161
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
 
162
 
 
163
{$I fexpand.inc}
 
164
 
 
165
{$UNDEF FPC_FEXPAND_GETENVPCHAR}
 
166
{$UNDEF FPC_FEXPAND_TILDE}
 
167
 
 
168
 
 
169
 
 
170
Function FSearch(const path:pathstr;dirlist:string):pathstr;
 
171
{
 
172
  Searches for a file 'path' in the list of direcories in 'dirlist'.
 
173
  returns an empty string if not found. Wildcards are NOT allowed.
 
174
  If dirlist is empty, it is set to '.'
 
175
}
 
176
Var
 
177
  NewDir : PathStr;
 
178
  p1     : Longint;
 
179
  Info   : Stat;
 
180
Begin
 
181
{Replace ':' with ';'}
 
182
  for p1:=1to length(dirlist) do
 
183
   if dirlist[p1]=':' then
 
184
    dirlist[p1]:=';';
 
185
{Check for WildCards}
 
186
  If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then
 
187
   FSearch:='' {No wildcards allowed in these things.}
 
188
  Else
 
189
   Begin
 
190
     Dirlist:='.;'+dirlist;{Make sure current dir is first to be searched.}
 
191
     Repeat
 
192
       p1:=Pos(';',DirList);
 
193
       If p1=0 Then
 
194
        p1:=255;
 
195
       NewDir:=Copy(DirList,1,P1 - 1);
 
196
       if NewDir[Length(NewDir)]<>'/' then
 
197
        NewDir:=NewDir+'/';
 
198
       NewDir:=NewDir+Path;
 
199
       Delete(DirList,1,p1);
 
200
       if FStat(NewDir,Info) then
 
201
        Begin
 
202
          If Pos('./',NewDir)=1 Then
 
203
           Delete(NewDir,1,2);
 
204
        {DOS strips off an initial .\}
 
205
        End
 
206
       Else
 
207
        NewDir:='';
 
208
     Until (DirList='') or (Length(NewDir) > 0);
 
209
     FSearch:=NewDir;
 
210
   End;
 
211
End;
 
212
 
 
213
 
 
214
 
 
215
Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
 
216
Var
 
217
  DotPos,SlashPos,i : longint;
 
218
Begin
 
219
  SlashPos:=0;
 
220
  DotPos:=256;
 
221
  i:=Length(Path);
 
222
  While (i>0) and (SlashPos=0) Do
 
223
   Begin
 
224
     If (DotPos=256) and (Path[i]='.') Then
 
225
      DotPos:=i;
 
226
     If (Path[i]='/') Then
 
227
      SlashPos:=i;
 
228
     Dec(i);
 
229
   End;
 
230
  Ext:=Copy(Path,DotPos,255);
 
231
  Dir:=Copy(Path,1,SlashPos);
 
232
  Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1);
 
233
End;
 
234
 
 
235
 
 
236
 
 
237
Function Dirname(Const path:pathstr):pathstr;
 
238
{
 
239
  This function returns the directory part of a complete path.
 
240
  Unless the directory is root '/', The last character is not
 
241
  a slash.
 
242
}
 
243
var
 
244
  Dir  : PathStr;
 
245
  Name : NameStr;
 
246
  Ext  : ExtStr;
 
247
begin
 
248
  FSplit(Path,Dir,Name,Ext);
 
249
  if length(Dir)>1 then
 
250
   Delete(Dir,length(Dir),1);
 
251
  DirName:=Dir;
 
252
end;
 
253
 
 
254
 
 
255
 
 
256
Function Basename(Const path:pathstr;Const suf:pathstr):pathstr;
 
257
{
 
258
  This function returns the filename part of a complete path. If suf is
 
259
  supplied, it is cut off the filename.
 
260
}
 
261
var
 
262
  Dir  : PathStr;
 
263
  Name : NameStr;
 
264
  Ext  : ExtStr;
 
265
begin
 
266
  FSplit(Path,Dir,Name,Ext);
 
267
  if Suf<>Ext then
 
268
   Name:=Name+Ext;
 
269
  BaseName:=Name;
 
270
end;
 
271
 
 
272
 
 
273
 
 
274
Function FNMatch(const Pattern,Name:string):Boolean;
 
275
Var
 
276
  LenPat,LenName : longint;
 
277
 
 
278
  Function DoFNMatch(i,j:longint):Boolean;
 
279
  Var
 
280
    Found : boolean;
 
281
  Begin
 
282
  Found:=true;
 
283
  While Found and (i<=LenPat) Do
 
284
   Begin
 
285
     Case Pattern[i] of
 
286
      '?' : Found:=(j<=LenName);
 
287
      '*' : Begin
 
288
            {find the next character in pattern, different of ? and *}
 
289
              while Found and (i<LenPat) do
 
290
                begin
 
291
                inc(i);
 
292
                case Pattern[i] of
 
293
                  '*' : ;
 
294
                  '?' : begin
 
295
                          inc(j);
 
296
                          Found:=(j<=LenName);
 
297
                        end;
 
298
                else
 
299
                  Found:=false;
 
300
                end;
 
301
               end;
 
302
            {Now, find in name the character which i points to, if the * or ?
 
303
             wasn't the last character in the pattern, else, use up all the
 
304
             chars in name}
 
305
              Found:=true;
 
306
              if (i<=LenPat) then
 
307
                begin
 
308
                repeat
 
309
                {find a letter (not only first !) which maches pattern[i]}
 
310
                while (j<=LenName) and (name[j]<>pattern[i]) do
 
311
                  inc (j);
 
312
                 if (j<LenName) then
 
313
                  begin
 
314
                    if DoFnMatch(i+1,j+1) then
 
315
                     begin
 
316
                       i:=LenPat;
 
317
                       j:=LenName;{we can stop}
 
318
                       Found:=true;
 
319
                     end
 
320
                    else
 
321
                     inc(j);{We didn't find one, need to look further}
 
322
                  end;
 
323
               until (j>=LenName);
 
324
                end
 
325
              else
 
326
                j:=LenName;{we can stop}
 
327
            end;
 
328
     else {not a wildcard character in pattern}
 
329
       Found:=(j<=LenName) and (pattern[i]=name[j]);
 
330
     end;
 
331
     inc(i);
 
332
     inc(j);
 
333
   end;
 
334
  DoFnMatch:=Found and (j>LenName);
 
335
  end;
 
336
 
 
337
Begin {start FNMatch}
 
338
  LenPat:=Length(Pattern);
 
339
  LenName:=Length(Name);
 
340
  FNMatch:=DoFNMatch(1,1);
 
341
End;
 
342
 
 
343
 
 
344
function PExists(path:string):boolean;
 
345
begin
 
346
  PExists:=FExists(path);
 
347
end;
 
348
 
 
349
function FExists(path:string):boolean;
 
350
var
 
351
    info:stat;
 
352
begin
 
353
  FExists:=Fstat(path,info);
 
354
end;
 
355
 
 
356
function sys_load_image(a:cardinal; argp:ppchar; envp:ppchar):longint; cdecl; external name 'sys_load_image';
 
357
function sys_wait_for_thread (th:longint; var exitcode:longint):longint; cdecl; external name 'sys_wait_for_thread';
 
358
 
 
359
Function Shell(const Command:String):Longint;
 
360
var s:string;
 
361
    argv:ppchar;
 
362
    argc:longint;
 
363
    th:longint;
 
364
begin
 
365
  s:=Command;
 
366
  argv:=StringToPPChar(s,argc);
 
367
  th:=0;
 
368
{  writeln ('argc = ',argc);
 
369
  while argv[th]<>Nil do begin
 
370
    writeln ('argv[',th,'] = ',argv[th]);
 
371
    th:=th+1;
 
372
  end;
 
373
}
 
374
  th:=sys_load_image(argc,argv,system.envp);
 
375
  if th<0 then begin
 
376
    shell:=0;
 
377
    exit;
 
378
  end;
 
379
  sys_wait_for_thread(th,Shell);
 
380
end;
 
381
 
 
382
 
 
383
 
 
384
end.