← Back to branch summary

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

« back to all changes in this revision

Viewing changes to rtl/unix/sysdir.inc

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2005-05-30 11:59:10 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050530115910-x5pbzm4qqta4i94h
Tags: 2.0.0-2
http://bugs.debian.org/310907
debian/fp-compiler.postinst.in: forgot to reapply the patch that
correctly creates the slave link to pc(1).  (Closes: #310907)

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/unix/sysdir.inc
 
1
{
 
2
    $Id: sysdir.inc,v 1.3 2005/02/14 17:13:31 peter Exp $
 
3
    This file is part of the Free Pascal run time library.
 
4
 
 
5
    Main OS dependant body of the system unit, loosely modelled
 
6
    after POSIX.  *BSD version (Linux version is near identical)
 
7
 
 
8
    See the file COPYING.FPC, included in this distribution,
 
9
    for details about the copyright.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
14
 
 
15
 **********************************************************************}
 
16
 
 
17
 
 
18
{*****************************************************************************
 
19
                           Directory Handling
 
20
*****************************************************************************}
 
21
 
 
22
Procedure MkDir(Const s: String);[IOCheck];
 
23
const
 
24
  { read/write search permission for everyone }
 
25
  MODE_MKDIR = S_IWUSR OR S_IRUSR OR
 
26
               S_IWGRP OR S_IRGRP OR
 
27
               S_IWOTH OR S_IROTH OR
 
28
               S_IXUSR OR S_IXGRP OR S_IXOTH;
 
29
Var
 
30
  Buffer: Array[0..255] of Char;
 
31
Begin
 
32
  If (s='') or (InOutRes <> 0) then
 
33
   exit;
 
34
  Move(s[1], Buffer, Length(s));
 
35
  Buffer[Length(s)] := #0;
 
36
  If Fpmkdir(@buffer, MODE_MKDIR)<0 Then
 
37
   Errno2Inoutres
 
38
  Else
 
39
   InOutRes:=0;
 
40
End;
 
41
 
 
42
 
 
43
Procedure RmDir(Const s: String);[IOCheck];
 
44
Var
 
45
  Buffer: Array[0..255] of Char;
 
46
Begin
 
47
  if (s = '.') then
 
48
    InOutRes := 16;
 
49
  If (s='') or (InOutRes <> 0) then
 
50
   exit;
 
51
  Move(s[1], Buffer, Length(s));
 
52
  Buffer[Length(s)] := #0;
 
53
  If Fprmdir(@buffer)<0 Then
 
54
   Errno2Inoutres
 
55
  Else
 
56
   InOutRes:=0;
 
57
End;
 
58
 
 
59
 
 
60
Procedure ChDir(Const s: String);[IOCheck];
 
61
Var
 
62
  Buffer: Array[0..255] of Char;
 
63
Begin
 
64
  If (s='') or (InOutRes <> 0) then
 
65
   exit;
 
66
  Move(s[1], Buffer, Length(s));
 
67
  Buffer[Length(s)] := #0;
 
68
  If Fpchdir(@buffer)<0 Then
 
69
   Errno2Inoutres
 
70
  Else
 
71
   InOutRes:=0;
 
72
  { file not exists is path not found under tp7 }
 
73
  if InOutRes=2 then
 
74
   InOutRes:=3;
 
75
End;
 
76
 
 
77
{ // $define usegetcwd}
 
78
 
 
79
procedure getdir(drivenr : byte;var dir : shortstring);
 
80
var
 
81
{$ifdef usegetcwd}
 
82
  buf          : array[0..254] of char;
 
83
{$else}
 
84
  cwdinfo      : stat;
 
85
  rootinfo     : stat;
 
86
  thedir,dummy : string[255];
 
87
  dirstream    : pdir;
 
88
  d            : pdirent;
 
89
  name         : string[255];
 
90
  thisdir      : stat;
 
91
  tmp          : string[255];
 
92
{$endif}
 
93
 
 
94
begin
 
95
  dir:='';
 
96
{$ifdef usegetcwd}
 
97
 if Fpgetcwd(@buf,sizeof(buf))<>nil then
 
98
   dir:=strpas(buf);
 
99
{$else}
 
100
  thedir:='';
 
101
  dummy:='';
 
102
 
 
103
  { get root directory information }
 
104
  tmp := '/'+#0;
 
105
  if Fpstat(@tmp[1],rootinfo)<0 then
 
106
    Exit;
 
107
  repeat
 
108
    tmp := dummy+'.'+#0;
 
109
    { get current directory information }
 
110
    if Fpstat(@tmp[1],cwdinfo)<0 then
 
111
      Exit;
 
112
    tmp:=dummy+'..'+#0;
 
113
    { open directory stream }
 
114
    { try to find the current inode number of the cwd }
 
115
    dirstream:=Fpopendir(@tmp[1]);
 
116
    if dirstream=nil then
 
117
       exit;
 
118
    repeat
 
119
      name:='';
 
120
      d:=Fpreaddir(dirstream);
 
121
      { no more entries to read ... }
 
122
      if not assigned(d) then
 
123
        break;
 
124
      tmp:=dummy+'../'+strpas(d^.d_name) + #0;
 
125
      if (Fpstat(@tmp[1],thisdir)=0) then
 
126
       begin
 
127
         { found the entry for this directory name }
 
128
         if (cwdinfo.st_dev=thisdir.st_dev) and (cwdinfo.st_ino=thisdir.st_ino) then
 
129
          begin
 
130
            { are the filenames of type '.' or '..' ? }
 
131
            { then do not set the name.               }
 
132
            if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
 
133
                    ((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
 
134
              name:='/'+strpas(d^.d_name);
 
135
          end;
 
136
       end;
 
137
    until (name<>'');
 
138
    if Fpclosedir(dirstream)<0 then
 
139
      Exit;
 
140
    thedir:=name+thedir;
 
141
    dummy:=dummy+'../';
 
142
    if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
 
143
      begin
 
144
        if thedir='' then
 
145
          dir:='/'
 
146
        else
 
147
          dir:=thedir;
 
148
        exit;
 
149
      end;
 
150
  until false;
 
151
 {$endif}
 
152
end;
 
153
 
 
154
{
 
155
  $Log: sysdir.inc,v $
 
156
  Revision 1.3  2005/02/14 17:13:31  peter
 
157
    * truncate log
 
158
 
 
159
  Revision 1.2  2005/02/13 20:01:38  peter
 
160
    * include file cleanup
 
161
 
 
162
  Revision 1.1  2005/02/07 22:04:55  peter
 
163
    * moved to unix
 
164
 
 
165
  Revision 1.1  2005/02/06 13:06:20  peter
 
166
    * moved file and dir functions to sysfile/sysdir
 
167
    * win32 thread in systemunit
 
168
 
 
169
}