← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/rtl/watcom/sysdir.inc

  • 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/rtl/watcom/sysdir.inc
 
1
{*****************************************************************************
 
2
                           Directory Handling
 
3
*****************************************************************************}
 
4
 
 
5
procedure DosDir(func:byte;const s:string);
 
6
var
 
7
  buffer : array[0..255] of char;
 
8
  regs   : trealregs;
 
9
begin
 
10
  move(s[1],buffer,length(s));
 
11
  buffer[length(s)]:=#0;
 
12
  DoDirSeparators(pchar(@buffer));
 
13
  { True DOS does not like backslashes at end
 
14
    Win95 DOS accepts this !!
 
15
    but "\" and "c:\" should still be kept and accepted hopefully PM }
 
16
  if (length(s)>0) and (buffer[length(s)-1]='\') and
 
17
     Not ((length(s)=1) or ((length(s)=3) and (s[2]=':'))) then
 
18
    buffer[length(s)-1]:=#0;
 
19
  syscopytodos(longint(@buffer),length(s)+1);
 
20
  regs.realedx:=tb_offset;
 
21
  regs.realds:=tb_segment;
 
22
  if LFNSupport then
 
23
   regs.realeax:=$7100+func
 
24
  else
 
25
   regs.realeax:=func shl 8;
 
26
  sysrealintr($21,regs);
 
27
  if (regs.realflags and carryflag) <> 0 then
 
28
   GetInOutRes(lo(regs.realeax));
 
29
end;
 
30
 
 
31
 
 
32
procedure mkdir(const s : string);[IOCheck];
 
33
begin
 
34
  If (s='') or (InOutRes <> 0) then
 
35
   exit;
 
36
  DosDir($39,s);
 
37
end;
 
38
 
 
39
 
 
40
procedure rmdir(const s : string);[IOCheck];
 
41
begin
 
42
  if (s = '.' ) then
 
43
    InOutRes := 16;
 
44
  If (s='') or (InOutRes <> 0) then
 
45
   exit;
 
46
  DosDir($3a,s);
 
47
end;
 
48
 
 
49
 
 
50
procedure chdir(const s : string);[IOCheck];
 
51
var
 
52
  regs : trealregs;
 
53
begin
 
54
  If (s='') or (InOutRes <> 0) then
 
55
   exit;
 
56
{ First handle Drive changes }
 
57
  if (length(s)>=2) and (s[2]=':') then
 
58
   begin
 
59
     regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
 
60
     regs.realeax:=$0e00;
 
61
     sysrealintr($21,regs);
 
62
     regs.realeax:=$1900;
 
63
     sysrealintr($21,regs);
 
64
     if byte(regs.realeax)<>byte(regs.realedx) then
 
65
      begin
 
66
        Inoutres:=15;
 
67
        exit;
 
68
      end;
 
69
     { DosDir($3b,'c:') give Path not found error on
 
70
       pure DOS PM }
 
71
     if length(s)=2 then
 
72
       exit;
 
73
   end;
 
74
{ do the normal dos chdir }
 
75
  DosDir($3b,s);
 
76
end;
 
77
 
 
78
 
 
79
procedure getdir(drivenr : byte;var dir : shortstring);
 
80
var
 
81
  temp : array[0..255] of char;
 
82
  i    : longint;
 
83
  regs : trealregs;
 
84
begin
 
85
  regs.realedx:=drivenr;
 
86
  regs.realesi:=tb_offset;
 
87
  regs.realds:=tb_segment;
 
88
  if LFNSupport then
 
89
   regs.realeax:=$7147
 
90
  else
 
91
   regs.realeax:=$4700;
 
92
  sysrealintr($21,regs);
 
93
  if (regs.realflags and carryflag) <> 0 then
 
94
   Begin
 
95
     GetInOutRes(lo(regs.realeax));
 
96
     Dir := char (DriveNr + 64) + ':\';
 
97
     exit;
 
98
   end
 
99
  else
 
100
   syscopyfromdos(longint(@temp),251);
 
101
{ conversion to Pascal string including slash conversion }
 
102
  i:=0;
 
103
  while (temp[i]<>#0) do
 
104
   begin
 
105
     if temp[i] in AllowDirectorySeparators then
 
106
      temp[i]:=DirectorySeparator;
 
107
     dir[i+4]:=temp[i];
 
108
     inc(i);
 
109
   end;
 
110
  dir[2]:=':';
 
111
  dir[3]:='\';
 
112
  dir[0]:=char(i+3);
 
113
{ upcase the string }
 
114
  if not FileNameCaseSensitive then
 
115
   dir:=upcase(dir);
 
116
  if drivenr<>0 then   { Drive was supplied. We know it }
 
117
   dir[1]:=char(65+drivenr-1)
 
118
  else
 
119
   begin
 
120
   { We need to get the current drive from DOS function 19H  }
 
121
   { because the drive was the default, which can be unknown }
 
122
     regs.realeax:=$1900;
 
123
     sysrealintr($21,regs);
 
124
     i:= (regs.realeax and $ff) + ord('A');
 
125
     dir[1]:=chr(i);
 
126
   end;
 
127
end;
 
128