paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 12:59:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fixes Posix dir copied to devel branch

Browse Source
This commit is contained in:
marco 2002-08-10 13:42:36 +00:00
parent c7aefd286b
commit 3c59d6dfb9
10 changed files with 2381 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
rtl/posix/errno.tem Normal file
View File

@ -0,0 +1,72 @@
{***********************************************************************}
{ POSIX ERROR DEFINITIONS }
{***********************************************************************}
const
{ The following constants are system dependent but must all exist }
Sys_E2BIG =
Sys_EACCES =
Sys_EAGAIN =
Sys_EBADF =
Sys_EBUSY =
Sys_ECANCELED =
Sys_ECHILD =
Sys_EDEADLK =
Sys_EDOM =
Sys_EEXIST =
Sys_EFAULT =
Sys_EFBIG =
Sys_EINPROGRESS =
Sys_EINTR =
Sys_EINVAL =
Sys_EIO =
Sys_EISDIR =
Sys_EMFILE =
Sys_EMLINK =
Sys_EMSGSIZE =
Sys_ENAMETOOLONG=
Sys_ENFILE =
Sys_ENODEV =
Sys_ENOENT =
Sys_ENOEXEC =
Sys_ENOLCK =
Sys_ENOMEM =
Sys_ENOSPC =
Sys_ENOSYS =
Sys_ENOTDIR =
Sys_ENOTEMPTY =
Sys_ENOTTY =
Sys_ENXIO =
Sys_EPERM =
Sys_EPIPE =
Sys_ERANGE =
Sys_EROFS =
Sys_ESPIPE =
Sys_ESRCH =
Sys_ETIMEDOUT =
Sys_EXDEV =
{ These next errors are POSIX, but only defined when }
{ certain types of POSIX extensions are defined: }
{Sys_EBADMSG = realtime extension POSIX only }
{Sys_ECANCELED = async. I/O extension POSIX only }
{Sys_EMSGSIZE = realtime extension POSIX only }
{Sys_EINPROGRESS = async. I/O extension POSIX only }
{Sys_ENOTSUP = unsupported syscall - optional }
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.3 2001/11/30 03:50:17 carl
* update a small spelling mistake Sys_EACCESS -> Sys_EACCES
Revision 1.1.2.2 2001/11/28 03:07:59 carl
Sys_ENOTSUP added
Revision 1.1.2.1 2001/08/15 00:14:52 carl
- renamed
Revision 1.1.2.1 2001/07/07 03:51:32 carl
+ errno.inc template
}

139
rtl/posix/objinc.inc Normal file
View File

@ -0,0 +1,139 @@
{
$Id$
Copyright (c) 2001 by the Freepascal development team
Objects unit OS specific implementation
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
{$i errno.inc}
{$i osposixh.inc}
{$i osposix.inc}
const
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle;
Var FileMode : cint;
BEGIN
FileMode:=0;
if Mode=stCreate then
Begin
FileMode:=O_CREAT;
FileMode:=FileMode or O_RDWR;
end
else
Begin
Case (Mode and 3) of
0 : FileMode:=FileMode or O_RDONLY;
1 : FileMode:=FileMode or O_WRONLY;
2 : FileMode:=FileMode or O_RDWR;
end;
end;
FileOpen:=sys_open (pchar(@FileName[0]),FileMode,MODE_OPEN);
if (ErrNo=Sys_EROFS) and ((FileMode and O_RDWR)<>0) then
begin
FileMode:=FileMode and not(O_RDWR);
FileOpen:=sys_open(pchar(@FileName[0]),Filemode,MODE_OPEN);
end;
If FileOpen=-1 then
FileOpen:=0;
DosStreamError:=Errno;
END;
FUNCTION FileRead (Handle: THandle; Var BufferArea; BufferLength: Sw_Word;
Var BytesMoved: Sw_Word): word;
var result : cint;
BEGIN
repeat
result:=Sys_read (Handle,pchar(@BufferArea),BufferLength);
until errno<>Sys_EINTR;
if result = -1 then
BytesMoved := 0
else
BytesMoved := result;
DosStreamError:=Errno;
FileRead:=Errno;
END;
FUNCTION FileWrite (Handle: THandle; Var BufferArea; BufferLength: Sw_Word;
Var BytesMoved: Sw_Word): Word;
var result: cint;
BEGIN
repeat
result:=Sys_Write (Handle,pchar(@BufferArea),BufferLength);
until errno<>Sys_EINTR;
if result = -1 then
BytesMoved := 0
else
BytesMoved := result;
FileWrite:=Errno;
DosStreamError:=Errno;
END;
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
VAR NewPos: LongInt): Word;
var
whence : cint;
BEGIN
whence := SEEK_SET;
case MoveType of
1 : whence := SEEK_CUR;
2 : whence := SEEK_END;
end;
NewPos:=Sys_LSeek (Handle,Pos,whence);
SetFilePos:=Errno;
END;
FUNCTION FileClose (Handle: THandle): Word;
BEGIN
Sys_Close (Handle);
DosStreamError:=Errno;
FileClose := Errno;
END;
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
var
Actual : longint;
BEGIN
SetFilePos(Handle,FileSize,0,Actual);
If (Actual = FileSize) Then
Begin
if (Sys_FTruncate(Handle,Filesize)=-1) then
SetFileSize:=103
else
SetFileSize:=0;
end;
END;
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.1 2001/08/13 05:54:54 carl
+ objects unit implementation based on POSIX
}

118
rtl/posix/osposix.tem Normal file
View File

@ -0,0 +1,118 @@
{
$Id$
Copyright (c) 2001 by Carl Eric Codere
Implements POSIX 1003.1 conforming interface
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
{$Linklib c}
{ var
Errno : cint; external name 'errno';}
function sys_fork : pid_t; cdecl; external name 'fork';
function sys_execve(const path : pchar; const argv : ppchar; const envp: ppchar): cint; cdecl; external name 'execve';
function sys_waitpid(pid : pid_t; var stat_loc : cint; options: cint): pid_t; cdecl; external name 'waitpid';
procedure sys_exit(status : cint); cdecl; external name '_exit';
function sys_uname(var name: utsname): cint; cdecl; external name 'uname';
function sys_opendir(const dirname : pchar): pdir; cdecl; external name 'opendir';
function sys_readdir(dirp : pdir) : pdirent;cdecl; external name 'readdir';
function sys_closedir(dirp : pdir): cint; cdecl; external name 'closedir';
function sys_chdir(const path : pchar): cint; cdecl; external name 'chdir';
function sys_open(const path: pchar; flags : cint; mode: mode_t):cint; cdecl; external name 'open';
function sys_mkdir(const path : pchar; mode: mode_t):cint; cdecl; external name 'mkdir';
function sys_unlink(const path: pchar): cint; cdecl; external name 'unlink';
function sys_rmdir(const path : pchar): cint; cdecl; external name 'rmdir';
function sys_rename(const old : pchar; const newpath: pchar): cint; cdecl;external name 'rename';
function sys_fstat(fd : cint; var sb : stat): cint; cdecl; external name 'fstat';
function sys_stat(const path: pchar; var buf : stat): cint; cdecl; external name 'stat';
function sys_access(const pathname : pchar; amode : cint): cint; cdecl; external name 'access';
function sys_close(fd : cint): cint; cdecl; external name 'close';
function sys_read(fd: cint; buf: pchar; nbytes : size_t): ssize_t; cdecl; external name 'read';
function sys_write(fd: cint;const buf:pchar; nbytes : size_t): ssize_t; cdecl; external name 'write';
function sys_lseek(fd : cint; offset : off_t; whence : cint): off_t; cdecl; external name 'lseek';
function sys_time(var tloc:time_t): time_t; cdecl; external name 'time';
function sys_ftruncate(fd : cint; flength : off_t): cint; cdecl; external name 'ftruncate';
function sys_sigaction(sig: cint; var act : sigactionrec; var oact : sigactionrec): cint; cdecl; external name 'sigaction';
function S_ISDIR(m : mode_t): boolean;
begin
end;
function S_ISCHR(m : mode_t): boolean;
begin
end;
function S_ISBLK(m : mode_t): boolean;
begin
end;
function S_ISREG(m : mode_t): boolean;
begin
end;
function S_ISFIFO(m : mode_t): boolean;
begin
end;
function wifexited(status : cint): cint;
begin
end;
function wexitstatus(status : cint): cint;
begin
end;
function wstopsig(status : cint): cint;
begin
end;
function wifsignaled(status : cint): cint;
begin
end;
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.5 2001/12/09 03:31:50 carl
+ wifsignaled() added
Revision 1.1.2.4 2001/12/03 03:13:30 carl
* fix ftruncate prototype
* fix rename prototype
* change readdir / closedir prototype
Revision 1.1.2.3 2001/11/30 03:50:43 carl
+ int -> cint
+ missing prototypes added
Revision 1.1.2.2 2001/11/28 03:08:29 carl
* int -> cint
+ several other stuff renamed
Revision 1.1.2.1 2001/08/15 00:15:04 carl
- renamed
}

133
rtl/posix/osposixh.tem Normal file
View File

@ -0,0 +1,133 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the types/constants which must
be defined to port FPC to a new POSIX compliant OS.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{***********************************************************************}
{ POSIX TYPE DEFINITIONS }
{***********************************************************************}
type
{ the following type definitions are compiler dependant }
{ and system dependant }
cint = { minimum range is : 32-bit }
cuint = { minimum range is : 32-bit }
dev_t = { used for device numbers }
gid_t = { used for group IDs }
ino_t = { used for file serial numbers }
mode_t = { used for file attributes }
nlink_t = { used for link counts }
off_t = { used for file sizes }
pid_t = { used as process identifier }
size_t = { as definied in the C standard }
ssize_t = { used by function for returning number of bytes }
uid_t = { used for user ID type }
time_t = { used for returning the time }
{***********************************************************************}
{ POSIX STRUCTURES }
{***********************************************************************}
CONST
_UTSNAME_LENGTH = ;
_UTSNAME_NODENAME_LENGTH = ;
TYPE
{ system information services }
utsname = packed record { don't forget to verify the alignment }
end;
{ file characteristics services }
stat = packed record { verify the alignment of the members }
end;
{ directory services }
pdirent = ^dirent;
dirent = packed record { directory entry record - verify alignment }
end;
pdir = ^dir;
dir = packed record
end;
{***********************************************************************}
{ POSIX CONSTANT ROUTINE DEFINITIONS }
{***********************************************************************}
CONST
{ access routine - these maybe OR'ed together }
F_OK = ; { test for existence of file }
R_OK = ; { test for read permission on file }
W_OK = ; { test for write permission on file }
X_OK = ; { test for execute or search permission }
{ seek routine }
SEEK_SET = ; { seek from beginning of file }
SEEK_CUR = ; { seek from current position }
SEEK_END = ; { seek from end of file }
{ open routine }
{ File access modes for `open' and `fcntl'. }
O_RDONLY = ; { Open read-only. }
O_WRONLY = ; { Open write-only. }
O_RDWR = ; { Open read/write. }
{ Bits OR'd into the second argument to open. }
O_CREAT = ; { Create file if it doesn't exist. }
O_EXCL = ; { Fail if file already exists. }
O_TRUNC = ; { Truncate file to zero length. }
O_NOCTTY = ; { Don't assign a controlling terminal. }
{ File status flags for `open' and `fcntl'. }
O_APPEND = ; { Writes append to the file. }
O_NONBLOCK = ; { Non-blocking I/O. }
{ mode_t possible values }
S_IRUSR = ; { Read permission for owner }
S_IWUSR = ; { Write permission for owner }
S_IXUSR = ; { Exec permission for owner }
S_IRGRP = ; { Read permission for group }
S_IWGRP = ; { Write permission for group }
S_IXGRP = ; { Exec permission for group }
S_IROTH = ; { Read permission for world }
S_IWOTH = ; { Write permission for world }
S_IXOTH = ; { Exec permission for world }
{ Used for waitpid }
WNOHANG = ; { don't block waiting }
WUNTRACED = ; { report status of stopped children }
{ POSIX limits, used for buffer and stack allocation }
ARG_MAX = { Maximum number of argument size }
NAME_MAX = { Maximum number of bytes in filename }
PATH_MAX = { Maximum number of bytes in pathname }
{*************************************************************************}
{ SIGNALS }
{*************************************************************************}
{$i signal.inc}
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.2 2001/11/28 03:08:46 carl
- removed signal stuff , moved to signal.inc
Revision 1.1.2.1 2001/08/15 00:15:08 carl
- renamed
}

95
rtl/posix/posix.tem Normal file
View File

@ -0,0 +1,95 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Carl Eric Codere
development team
POSIX Compliant interface unit
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit posix;
interface
{***********************************************************************}
{ POSIX PUBLIC INTERFACE }
{***********************************************************************}
{$i errno.inc}
{$i osposixh.inc}
function sys_fork : pid_t;
function sys_execve(const path : pchar; const argv : ppchar; const envp: ppchar): cint;
function sys_waitpid(pid : pid_t; var stat_loc : cint; options: cint): pid_t;
procedure sys_exit(status : cint);
{ get system specific information }
function sys_uname(var name: utsname): cint;
function sys_opendir(const dirname : pchar): pdir;
function sys_readdir(var dirp : dir) : pdirent;
function sys_closedir(var dirp : pdir): cint;
function sys_chdir(const path : pchar): cint;
function sys_open(const path: pchar; flags : cint; mode: mode_t):cint;
function sys_mkdir(const path : pchar; mode: mode_t):cint;
function sys_unlink(const path: pchar): cint;
function sys_rmdir(const path : pchar): cint;
function sys_rename(const old : pchar; const newpath: pchar): cint;
function sys_fstat(fd : cint; var sb : stat): cint;
function sys_stat(const path: pchar; var buf : stat): cint;
function sys_access(const pathname : pchar; amode : cint): cint;
function sys_close(fd : cint): cint;
function sys_read(fd: cint; buf: pchar; nbytes : size_t): ssize_t;
function sys_write(fd: cint;const buf:pchar; nbytes : size_t): ssize_t;
function sys_lseek(fd : cint; offset : off_t; whence : cint): off_t;
function sys_time(var tloc:time_t): time_t;
function sys_sigaction(sig: cint; var act : sigactionrec; var oact : sigactionrec): cint;
function sys_ftruncate(fd : cint; flength : off_t): cint;
function S_ISDIR(m : mode_t): boolean;
function S_ISCHR(m : mode_t): boolean;
function S_ISBLK(m : mode_t): boolean;
function S_ISREG(m : mode_t): boolean;
function S_ISFIFO(m : mode_t): boolean;
function wifexited(status : cint): cint;
function wexitstatus(status : cint): cint;
function wstopsig(status : cint): cint;
function wifsignaled(status : cint): cint;
implementation
{$i osposix.inc}
end.
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.2 2001/12/09 03:31:56 carl
+ wifsignaled() added
Revision 1.1.2.1 2001/12/04 02:29:59 carl
+ posix unit template file
Revision 1.1.2.1 2001/08/15 01:06:32 carl
+ first version of posix unit
}

108
rtl/posix/readme.txt Normal file
View File

@ -0,0 +1,108 @@
POSIX directory information
---------------------------
This directory contains the system call interface to
POSIX compliant systems. These files should be
completed by OS-specific files. This permits to
easily create common and maintanable base
runtime library units (such as dos and system).
Limitations:
------------
- Only single byte character sets are supported (ASCII, ISO8859-1)
- Path and filenames are limited to 255 characters
(shortstrings are limited to 255 characters)
Files in this directory
posix.tem
----------
Posix unit template.
dos.pp
------
POSIX compliant dos unit. The following routines
and variables must be implemented / declared on
a platform by platform basis:
DiskFree()
DiskSize()
DosVersion()
GetTimeZoneString(): Should return the string of
the timezone information , as defined by POSIX,
if not available, should return an empty string.
This string is usually stored in the 'TZ' environment
variable.
GetTimeZoneFileName() : Should return the absolute path to
the timezone filename to use to convert the UTC time to
local time. The format of the timezone files are those
specific in glibc.
FixDriveStr : Array of pchar which contains
the names of the fixed disks :
(index 0 : current directory
index 1 : first floppy disk
index 2 : second floppy disk
index 3 : boot disk
)
sysposix.inc
------------
Most of the specific operating system
routines which can be implemented using
the POSIX interface are implemented in
this unit. This should be included in
the target operating system system unit
to create a complete system unit.
Files required to port the compiler to a POSIX
compliant system (should reside in the target
OS directory):
osposixh.inc : This includes all constants,
type definitions and structures used
(this is operating system dependant), except
for those related to signals. It includes
the signal file.
osposix.inc : The actuall system call routines
to the routine prototypes defined in posixh.inc.
(either these can be an interface to a libc, or
actual system calls).
errno.inc : All possible error codes which
can be returned by the operating system.
signal.inc : Defines all constants and types
related to signals, it must at least define
the POSIX signal types and constants, but
can also add other OS specific types and
constants related to signals.
Templates for the osposix.inc file (when linked
with the GNU libc), errno.inc and osposixh.inc
are included in this directory and have the
extension .tem . They should be used as a basis
to port to a new operating system.
When sysposix.inc is used, the following system
unit routines must be implemented for each new
operating system, as they are not reproducable
under the POSIX interface:
function sbrk(size : longint): longint;
procedure do_truncate (handle,pos:longint);
function do_isdevice(handle:longint):boolean;
When dos.pp is used, the following dos
unit routines must be implemented for each new
operating system, as they are not reproducable
under the POSIX interface:
function diskfree(drive : byte) : int64;
function disksize(drive: byte) : int64;

67
rtl/posix/signal.tem Normal file
View File

@ -0,0 +1,67 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the types/constants which must
be defined to port FPC to a new POSIX compliant OS.
This defines all signal related types and constants.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
type
sigset_t =; { used for additional signal }
sighandler_t = procedure (signo: cint); cdecl;
{ signal services }
sigactionrec = packed record
end;
const
{************************ signals *****************************}
{ more can be provided. Herein are only included the required }
{ values. }
{**************************************************************}
SIGABRT = ; { abnormal termination }
SIGALRM = ; { alarm clock (used with alarm() }
SIGFPE = ; { illegal arithmetic operation }
SIGHUP = ; { Hangup }
SIGILL = ; { Illegal instruction }
SIGINT = ; { Interactive attention signal }
SIGKILL = ; { Kill, cannot be caught }
SIGPIPE = ; { Broken pipe signal }
SIGQUIT = ; { Interactive termination signal }
SIGSEGV = ; { Detection of invalid memory reference }
SIGTERM = ; { Termination request }
SIGUSR1 = ; { Application defined signal 1 }
SIGUSR2 = ; { Application defined signal 2 }
SIGCHLD = ; { Child process terminated / stopped }
SIGCONT = ; { Continue if stopped }
SIGSTOP = ; { Stop signal. cannot be cuaght }
SIGSTP = ; { Interactive stop signal }
SIGTTIN = ; { Background read from TTY }
SIGTTOU = ; { Background write to TTY }
SIGBUS = ; { Access to undefined memory }
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.1 2001/11/28 03:10:37 carl
+ signal stuff posix include
}

652
rtl/posix/sysposix.inc Normal file
View File

@ -0,0 +1,652 @@
{
$Id$
This file is part of the Free Pascal run time library.
POSIX Interface to the system unit
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This is the core of the system unit *nix systems (now FreeBSD
and Unix).
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
const
{ Default creation mode for directories and files }
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
{ read/write search permission for everyone }
MODE_MKDIR = MODE_OPEN OR
S_IXUSR OR S_IXGRP OR S_IXOTH;
{*****************************************************************************
Stack check code
*****************************************************************************}
{$IFOPT S+}
{$DEFINE STACKCHECK}
{$ENDIF}
{$S-}
procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
var
c: cardinal;
begin
c := cardinal(Sptr) - cardinal(stack_size) - STACK_MARGIN;
if (c <= cardinal(StackBottom)) then
HandleError(202);
end;
{$IFDEF STACKCHECK}
{$S+}
{$ENDIF}
{$UNDEF STACKCHECK}
{*****************************************************************************
Misc. System Dependent Functions
*****************************************************************************}
procedure System_exit;
begin
sys_exit(cint(ExitCode));
End;
Function ParamCount: Longint;
Begin
Paramcount:=argc-1
End;
function BackPos(c:char; const s: shortstring): integer;
var
i: integer;
Begin
for i:=length(s) downto 0 do
if s[i] = c then break;
if i=0 then
BackPos := 0
else
BackPos := i;
end;
{ variable where full path and filename and executable is stored }
{ is setup by the startup of the system unit. }
var
execpathstr : shortstring;
function paramstr(l: longint) : string;
var
s: string;
s1: string;
begin
{ stricly conforming POSIX applications }
{ have the executing filename as argv[0] }
if l=0 then
begin
paramstr := execpathstr;
end
else
paramstr:=strpas(argv[l]);
end;
Procedure Randomize;
var
t: time_t;
Begin
randseed:=longint(sys_time(t));
End;
{*****************************************************************************
Heap Management
*****************************************************************************}
var
_HEAP : longint;external name 'HEAP';
_HEAPSIZE : longint;external name 'HEAPSIZE';
{$ifndef SYSTEM_HAS_GETHEAPSTART}
function getheapstart:pointer;
begin
getheapstart := @_HEAP;
end;
{$endif}
{$ifndef SYSTEM_HAS_GETHEAPSIZE}
function getheapsize:longint;
begin
getheapsize := _HEAPSIZE;
end;
{$endif}
{*****************************************************************************
Low Level File Routines
*****************************************************************************}
{
The lowlevel file functions should take care of setting the InOutRes to the
correct value if an error has occured, else leave it untouched
}
Procedure Errno2Inoutres;
{
Convert ErrNo error to the correct Inoutres value
}
begin
if ErrNo=0 then { Else it will go through all the cases }
exit;
case ErrNo of
Sys_ENFILE,
Sys_EMFILE : Inoutres:=4;
Sys_ENOENT : Inoutres:=2;
Sys_EBADF : Inoutres:=6;
Sys_ENOMEM,
Sys_EFAULT : Inoutres:=217;
Sys_EINVAL : Inoutres:=218;
Sys_EPIPE,
Sys_EINTR,
Sys_EIO,
Sys_EAGAIN,
Sys_ENOSPC : Inoutres:=101;
Sys_ENAMETOOLONG : Inoutres := 3;
Sys_EROFS,
Sys_EEXIST,
Sys_ENOTEMPTY,
Sys_EACCES : Inoutres:=5;
Sys_EISDIR : InOutRes:=5;
else
begin
InOutRes := Integer(Errno);
end;
end;
end;
Procedure Do_Close(Handle:Longint);
Begin
sys_close(cint(Handle));
End;
Procedure Do_Erase(p:pchar);
var
fileinfo : stat;
Begin
{ verify if the filename is actually a directory }
{ if so return error and do nothing, as defined }
{ by POSIX }
if sys_stat(p,fileinfo)<0 then
begin
Errno2Inoutres;
exit;
end;
if S_ISDIR(fileinfo.st_mode) then
begin
InOutRes := 2;
exit;
end;
sys_unlink(p);
Errno2Inoutres;
End;
{ truncate at a given position }
procedure do_truncate (handle,fpos:longint);
begin
{ should be simulated in cases where it is not }
{ available. }
sys_ftruncate(handle,fpos);
Errno2Inoutres;
end;
Procedure Do_Rename(p1,p2:pchar);
Begin
sys_rename(p1,p2);
Errno2Inoutres;
End;
Function Do_Write(Handle,Addr,Len:Longint):longint;
Begin
repeat
Do_Write:=sys_write(Handle,pchar(addr),len);
until ErrNo<>Sys_EINTR;
Errno2Inoutres;
if Do_Write<0 then
Do_Write:=0;
End;
Function Do_Read(Handle,Addr,Len:Longint):Longint;
Begin
repeat
Do_Read:=sys_read(Handle,pchar(addr),len);
until ErrNo<>Sys_EINTR;
Errno2Inoutres;
if Do_Read<0 then
Do_Read:=0;
End;
function Do_FilePos(Handle: Longint):longint;
Begin
do_FilePos:=sys_lseek(Handle, 0, SEEK_CUR);
Errno2Inoutres;
End;
Procedure Do_Seek(Handle,Pos:Longint);
Begin
sys_lseek(Handle, pos, SEEK_SET);
Errno2Inoutres;
End;
Function Do_SeekEnd(Handle:Longint): Longint;
begin
Do_SeekEnd:=sys_lseek(Handle,0,SEEK_END);
errno2inoutres;
end;
Function Do_FileSize(Handle:Longint): Longint;
var
Info : Stat;
Begin
if sys_fstat(handle,info)=0 then
Do_FileSize:=Info.st_size
else
Do_FileSize:=0;
Errno2InOutRes;
End;
Procedure Do_Open(var f;p:pchar;flags:longint);
{
FileRec and textrec have both Handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
oflags : cint;
Begin
{ close first if opened }
if ((flags and $10000)=0) then
begin
case FileRec(f).mode of
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file Handle }
FileRec(f).Handle:=UnusedHandle;
{ We do the conversion of filemodes here, concentrated on 1 place }
case (flags and 3) of
0 : begin
oflags :=O_RDONLY;
FileRec(f).mode:=fminput;
end;
1 : begin
oflags :=O_WRONLY;
FileRec(f).mode:=fmoutput;
end;
2 : begin
oflags :=O_RDWR;
FileRec(f).mode:=fminout;
end;
end;
if (flags and $1000)=$1000 then
oflags:=oflags or (O_CREAT or O_TRUNC)
else
if (flags and $100)=$100 then
oflags:=oflags or (O_APPEND);
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
FileRec(f).Handle:=sys_open(p,oflags,MODE_OPEN);
if (ErrNo=Sys_EROFS) and ((OFlags and O_RDWR)<>0) then
begin
Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle:=sys_open(p,oflags,MODE_OPEN);
end;
Errno2Inoutres;
End;
{*****************************************************************************
Directory Handling
*****************************************************************************}
Procedure MkDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
sys_mkdir(@buffer, MODE_MKDIR);
Errno2Inoutres;
End;
Procedure RmDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
if (s = '.') then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
sys_rmdir(@buffer);
Errno2Inoutres;
End;
Procedure ChDir(Const s: String);[IOCheck];
Var
Buffer: Array[0..255] of Char;
Begin
If (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
sys_chdir(@buffer);
Errno2Inoutres;
{ file not exists is path not found under tp7 }
if InOutRes=2 then
InOutRes:=3;
End;
procedure getdir(drivenr : byte;var dir : shortstring);
var
cwdinfo : stat;
rootinfo : stat;
thedir,dummy : string[255];
dirstream : pdir;
d : pdirent;
name : string[255];
tmp : string[255];
thisdir : stat;
begin
dir:='';
thedir:='';
dummy:='';
{ get root directory information }
tmp := '/'+#0;
if sys_stat(@tmp[1],rootinfo)<0 then
exit;
repeat
tmp := dummy+'.'+#0;
{ get current directory information }
if sys_stat(@tmp[1],cwdinfo)<0 then
exit;
tmp:=dummy+'..'+#0;
{ open directory stream }
{ try to find the current inode number of the cwd }
dirstream:=sys_opendir(@tmp[1]);
if dirstream=nil then
exit;
repeat
name:='';
d:=sys_readdir(dirstream);
{ no more entries to read ... }
if not assigned(d) then
begin
break;
end;
tmp:=dummy+'../'+strpas(d^.d_name) + #0;
if sys_stat(@tmp[1],thisdir)<0 then
begin
exit;
end;
{ found the entry for this directory name }
if (cwdinfo.st_dev=thisdir.st_dev) and (cwdinfo.st_ino=thisdir.st_ino) then
begin
{ are the filenames of type '.' or '..' ? }
{ then do not set the name. }
if (not ((d^.d_name[0]='.') and ((d^.d_name[1]=#0) or
((d^.d_name[1]='.') and (d^.d_name[2]=#0))))) then
begin
name:='/'+strpas(d^.d_name);
end;
end
until (name<>'');
sys_closedir(dirstream);
thedir:=name+thedir;
dummy:=dummy+'../';
if ((cwdinfo.st_dev=rootinfo.st_dev) and (cwdinfo.st_ino=rootinfo.st_ino)) then
begin
if thedir='' then
dir:='/'
else
dir:=thedir;
exit;
end;
until false;
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
procedure SignalToRunerror(signo: cint); cdecl;
var
res : word;
begin
res:=0;
if signo = SIGFPE then
begin
res := 200;
end
else
if (signo = SIGILL) or (signo = SIGBUS) or (signo = SIGSEGV) then
begin
res := 216;
end;
{ give runtime error at the position where the signal was raised }
if res<>0 then
begin
HandleError(res);
end;
end;
var
act: SigActionRec;
Procedure InstallSignals;
var
oldact: SigActionRec;
begin
{ Initialize the sigaction structure }
{ all flags and information set to zero }
FillChar(act, sizeof(SigActionRec),0);
{ initialize handler }
act.sa_handler := @SignalToRunError;
sys_SigAction(SIGFPE,act,oldact);
sys_SigAction(SIGSEGV,act,oldact);
sys_SigAction(SIGBUS,act,oldact);
sys_SigAction(SIGILL,act,oldact);
end;
procedure SetupCmdLine;
var
bufsize,
len,j,
size,i : longint;
found : boolean;
buf : pchar;
procedure AddBuf;
begin
reallocmem(cmdline,size+bufsize);
move(buf^,cmdline[size],bufsize);
inc(size,bufsize);
bufsize:=0;
end;
begin
GetMem(buf,ARG_MAX);
size:=0;
bufsize:=0;
i:=0;
while (i<argc) do
begin
len:=strlen(argv[i]);
if len>ARG_MAX-2 then
len:=ARG_MAX-2;
found:=false;
for j:=1 to len do
if argv[i][j]=' ' then
begin
found:=true;
break;
end;
if bufsize+len>=ARG_MAX-2 then
AddBuf;
if found then
begin
buf[bufsize]:='"';
inc(bufsize);
end;
move(argv[i]^,buf[bufsize],len);
inc(bufsize,len);
if found then
begin
buf[bufsize]:='"';
inc(bufsize);
end;
if i<argc then
buf[bufsize]:=' '
else
buf[bufsize]:=#0;
inc(bufsize);
inc(i);
end;
AddBuf;
FreeMem(buf,ARG_MAX);
end;
(*
Begin
{ Set up signals handlers }
InstallSignals;
{ Setup heap }
InitHeap;
InitExceptions;
{ Arguments }
SetupCmdLine;
{ Setup stdin, stdout and stderr }
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Reset IO Error }
InOutRes:=0;
End.
*)
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.18 2002/03/10 11:45:02 carl
* InOutRes := 16 with rmdir()
* InOutRes := 5 more checking
Revision 1.1.2.17 2002/03/03 15:11:51 carl
* erase() bugfix (erasing a directory is done via rmdir() only!)
Revision 1.1.2.16 2002/02/15 18:13:35 carl
* bugfix for paramstr(0)
Revision 1.1.2.15 2001/12/03 03:15:15 carl
* update readdir prototype
Revision 1.1.2.14 2001/09/27 02:24:43 carl
* correct problem with getting paramstr(0) when in root
Revision 1.1.2.13 2001/08/15 01:05:22 carl
+ add do_truncate()
Revision 1.1.2.12 2001/08/13 09:38:12 carl
* changed prototype of sys_readdir
* bugfix of problems of changing signs with errno!
Revision 1.1.2.11 2001/08/13 05:55:43 carl
- removed some debug code
Revision 1.1.2.10 2001/08/08 02:01:03 carl
* bugfix of getdir() with root
Revision 1.1.2.9 2001/08/03 02:00:26 carl
+ hack :(... for heap management.
+ correct I/O bug (to test) should be also updated in linux
Revision 1.1.2.8 2001/07/21 19:20:52 carl
+ getdir() implemented
+ MAX_ARGS define now used
Revision 1.1.2.7 2001/07/14 04:18:39 carl
+ started debugging getdir()
Revision 1.1.2.6 2001/07/08 04:46:43 carl
* correct parameter calls to sigaction
Revision 1.1.2.5 2001/07/08 00:38:04 carl
+ updates
Revision 1.1.2.3 2001/07/06 11:59:58 carl
* renamed some defines
* correct includes
Revision 1.1.2.2 2001/07/06 11:42:28 carl
* modified for more compliance
Revision 1.1.2.1 2001/07/06 11:22:18 carl
+ add files for POSIX
}

555
rtl/posix/sysutils.pp Normal file
View File

@ -0,0 +1,555 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2001 by Florian Klaempfl
member of the Free Pascal development team
Sysutils unit for POSIX compliant systems
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit sysutils;
interface
{$MODE objfpc}
{ force ansistrings }
{$H+}
{ Include platform independent interface part }
{$i sysutilh.inc}
{ Platform dependent calls }
Procedure AddDisk(const path:string);
implementation
uses dos,posix;
{ Include platform independent implementation part }
{$i sysutils.inc}
{****************************************************************************
File Functions
****************************************************************************}
{$I-}
const
{ read/write permission for everyone }
MODE_OPEN = S_IWUSR OR S_IRUSR OR
S_IWGRP OR S_IRGRP OR
S_IWOTH OR S_IROTH;
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
Var Flags : cint;
FileHandle : cint;
{ lock: flock;}
BEGIN
Flags:=0;
Case (Mode and 3) of
fmOpenRead : Flags:=Flags or O_RDONLY;
fmOpenWrite : Flags:=Flags or O_WRONLY;
fmOpenReadWrite : Flags:=Flags or O_RDWR;
end;
FileHandle:=sys_Open (pchar(FileName),Flags,MODE_OPEN);
if (ErrNo=Sys_EROFS) and ((Flags and O_RDWR)<>0) then
begin
Flags:=Flags and not(O_RDWR);
FileHandle:=sys_open(pchar(FileName),Flags,MODE_OPEN);
end;
FileOpen := longint(FileHandle);
(*
{ if there was an error, then don't do anything }
if FileHandle = -1 then
exit;
{ now check if the file can actually be used }
{ by verifying the locks on the file }
lock.l_whence := SEEK_SET;
lock.l_start := 0; { from start of file }
lock.l_len := 0; { to END of file }
if sys_fcntl(FileHandle, F_GETLK, @lock)<>-1 then
begin
{ if another process has created a lock on this file }
{ exclusive lock? }
if (lock.l_type = F_WRLCK) then
begin
{ close and exit }
sys_close(FileHandle);
FileOpen := -1;
exit;
end;
{ shared lock? }
if (lock.l_type = F_RDLK) and
((Flags = O_RDWR) or Flags = O_WRONLY)) then
begin
{ close and exit }
sys_close(FileHandle);
FileOpen := -1;
exit;
end;
end;
{ now actually set the lock: }
{ only the following are simulated with sysutils : }
{ - fmShareDenywrite (get exclusive lock) }
{ - fmShareExclusive (get exclusive lock) }
if ((Mode and fmShareDenyWrite)<>0) or
((Mode and fmShareExclusive)<>0) then
begin
lock.l_whence := SEEK_SET;
lock.l_start := 0; { from stat of file }
lock.l_len := 0; { to END of file }
lock.l_type := F_WRLCK; { exclusive lock }
if sys_fcntl(FileHandle, F_SETLK, @lock)=-1 then
begin
sys_close(FileHandel);
FileOpen := -1;
exit;
end;
end;
*)
end;
Function FileCreate (Const FileName : String) : Longint;
begin
FileCreate:=sys_Open(pchar(FileName),O_RDWR or O_CREAT or O_TRUNC,MODE_OPEN);
end;
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
begin
repeat
FileRead:=sys_read(Handle,pchar(@Buffer),Count);
until ErrNo<>Sys_EINTR;
If FileRead = -1 then
FileRead := 0;
end;
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
begin
repeat
FileWrite:=sys_write(Handle,pchar(@Buffer),Count);
until ErrNo<>Sys_EINTR;
if FileWrite = -1 then
FileWrite := 0;
end;
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
var
whence : cint;
begin
FileSeek := -1;
case Origin of
{ from beginning of file }
0 : whence := SEEK_SET;
{ from current position }
1 : whence := SEEK_CUR;
{ from end of file }
2 : whence := SEEK_END;
else
exit;
end;
FileSeek := sys_lseek(Handle,FOffset,whence);
if errno <> 0 then
FileSeek := -1;
end;
Procedure FileClose (Handle : Longint);
begin
sys_close(Handle);
end;
Function FileTruncate (Handle,Size: Longint) : boolean;
begin
if sys_ftruncate(Handle,Size)=0 then
FileTruncate := true
else
FileTruncate := false;
end;
Function FileAge (Const FileName : String): Longint;
var F: file;
Time: longint;
begin
Assign(F,FileName);
Reset(F,1);
dos.GetFTime(F,Time);
Close(F);
FileAge := Time;
end;
Function FileExists (Const FileName : String) : Boolean;
Var Info : Stat;
begin
if sys_stat(pchar(filename),Info)<>0 then
FileExists := false
else
FileExists := true;
end;
Function UNIXToWinAttr (FN : Pchar; Const Info : Stat) : Longint;
begin
Result:=faArchive;
If S_ISDIR(Info.st_mode) then
Result:=Result or faDirectory ;
If (FN[0]='.') and (not (FN[1] in [#0,'.'])) then
Result:=Result or faHidden;
if (info.st_mode and S_IWUSR)=0 then
Result:=Result or fareadonly;
If S_ISREG(Info.st_Mode) Then
Result:=Result or faSysFile;
end;
type
PDOSSearchRec = ^SearchRec;
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
Const
faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
var
p : pDOSSearchRec;
dosattr: word;
begin
dosattr:=0;
if Attr and faHidden <> 0 then
dosattr := dosattr or Hidden;
if Attr and faSysFile <> 0 then
dosattr := dosattr or SysFile;
if Attr and favolumeID <> 0 then
dosattr := dosattr or VolumeID;
if Attr and faDirectory <> 0 then
dosattr := dosattr or faDirectory;
New(p);
Rslt.FindHandle := THandle(p);
dos.FindFirst(path,dosattr,p^);
if DosError <> 0 then
begin
FindFirst := -1;
end
else
begin
Rslt.Name := p^.Name;
Rslt.Time := p^.Time;
Rslt.Attr := p^.Attr;
Rslt.ExcludeAttr := not p^.Attr;
Rslt.Size := p^.Size;
FindFirst := 0;
end;
end;
Function FindNext (Var Rslt : TSearchRec) : Longint;
var
p : pDOSSearchRec;
begin
p:= PDOsSearchRec(Rslt.FindHandle);
if not assigned(p) then
begin
FindNext := -1;
exit;
end;
Dos.FindNext(p^);
if DosError <> 0 then
begin
FindNext := -1;
end
else
begin
Rslt.Name := p^.Name;
Rslt.Time := p^.Time;
Rslt.Attr := p^.Attr;
Rslt.ExcludeAttr := not p^.Attr;
Rslt.Size := p^.Size;
FindNext := 0;
end;
end;
Procedure FindClose (Var F : TSearchrec);
Var
p : PDOSSearchRec;
begin
p:=PDOSSearchRec(f.FindHandle);
if not assigned(p) then
exit;
Dos.FindClose(p^);
if assigned(p) then
Dispose(p);
f.FindHandle := THandle(nil);
end;
Function FileGetDate (Handle : Longint) : Longint;
Var Info : Stat;
begin
If sys_FStat(Handle,Info)<>0 then
Result:=-1
else
Result:=Info.st_mtime;
end;
Function FileSetDate (Handle,Age : Longint) : Longint;
begin
// Impossible under unix from FileHandle !!
FileSetDate:=-1;
end;
Function FileGetAttr (Const FileName : String) : Longint;
Var Info : Stat;
begin
If sys_stat (pchar(FileName),Info)<>0 then
Result:=-1
Else
Result:=UNIXToWinAttr(Pchar(FileName),Info);
end;
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
begin
Result:=-1;
end;
Function DeleteFile (Const FileName : String) : Boolean;
begin
if sys_unlink(pchar(FileName))=0 then
DeleteFile := true
else
DeleteFile := false;
end;
Function RenameFile (Const OldName, NewName : String) : Boolean;
begin
{ you can directly typecast and ansistring to a pchar }
if sys_rename(pchar(OldName),pchar(NewName))=0 then
RenameFile := TRUE
else
RenameFile := FALSE;
end;
{****************************************************************************
Disk Functions
****************************************************************************}
{
The Diskfree and Disksize functions need a file on the specified drive, since this
is required for the statfs system call.
These filenames are set in drivestr[0..26], and have been preset to :
0 - '.' (default drive - hence current dir is ok.)
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
3 - '/' (C: equivalent of dos is the root partition)
4..26 (can be set by you're own applications)
! Use AddDisk() to Add new drives !
They both return -1 when a failure occurs.
}
Const
FixDriveStr : array[0..3] of pchar=(
'.',
'/fd0/.',
'/fd1/.',
'/.'
);
var
Drives : byte;
DriveStr : array[4..26] of pchar;
Procedure AddDisk(const path:string);
begin
if not (DriveStr[Drives]=nil) then
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
GetMem(DriveStr[Drives],length(Path)+1);
StrPCopy(DriveStr[Drives],path);
inc(Drives);
if Drives>26 then
Drives:=4;
end;
Function DiskFree(Drive: Byte): int64;
Begin
DiskFree := dos.diskFree(Drive);
End;
Function DiskSize(Drive: Byte): int64;
Begin
DiskSize := dos.DiskSize(Drive);
End;
Function GetCurrentDir : String;
begin
GetDir (0,Result);
end;
Function SetCurrentDir (Const NewDir : String) : Boolean;
begin
ChDir(NewDir);
result := (IOResult = 0);
end;
Function CreateDir (Const NewDir : String) : Boolean;
begin
MkDir(NewDir);
result := (IOResult = 0);
end;
Function RemoveDir (Const Dir : String) : Boolean;
begin
RmDir(Dir);
result := (IOResult = 0);
end;
{****************************************************************************
Misc Functions
****************************************************************************}
procedure Beep;
begin
end;
{****************************************************************************
Locale Functions
****************************************************************************}
Procedure GetLocalTime(var SystemTime: TSystemTime);
var
dayOfWeek: word;
begin
dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second,SystemTime.Millisecond);
dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, DayOfWeek);
end ;
Procedure InitAnsi;
Var
i : longint;
begin
{ Fill table entries 0 to 127 }
for i := 0 to 96 do
UpperCaseTable[i] := chr(i);
for i := 97 to 122 do
UpperCaseTable[i] := chr(i - 32);
for i := 123 to 191 do
UpperCaseTable[i] := chr(i);
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
for i := 0 to 64 do
LowerCaseTable[i] := chr(i);
for i := 65 to 90 do
LowerCaseTable[i] := chr(i + 32);
for i := 91 to 191 do
LowerCaseTable[i] := chr(i);
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
end;
Procedure InitInternational;
begin
InitAnsi;
end;
function SysErrorMessage(ErrorCode: Integer): String;
begin
{ Result:=StrError(ErrorCode);}
end;
{****************************************************************************
OS utility functions
****************************************************************************}
Function GetEnvironmentVariable(Const EnvVar : String) : String;
begin
Result:=Dos.Getenv(shortstring(EnvVar));
end;
{****************************************************************************
Initialization code
****************************************************************************}
Initialization
InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings }
Finalization
DoneExceptions;
end.
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.5 2002/04/28 07:28:43 carl
* some cleanup
Revision 1.1.2.4 2002/03/03 08:47:37 carl
+ FindFirst / FindNext implemented
Revision 1.1.2.3 2002/01/22 07:41:11 michael
+ Fixed FileSearch bug in Win32 and made FIleSearch platform independent
Revision 1.1.2.2 2001/09/29 20:16:53 carl
* bugfix of read/write wrong address was passed as parameter
Revision 1.1.2.1 2001/08/15 01:07:07 carl
+ first version of sysutils
}

442
rtl/posix/timezone.inc Normal file
View File

@ -0,0 +1,442 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2002 by the Free Pascal development team.
Timezone extraction routines
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
const
TZ_MAGIC = 'TZif';
type
plongint=^longint;
pbyte=^byte;
ttzhead=packed record
tzh_magic : array[0..3] of char;
tzh_reserved : array[1..16] of byte;
tzh_ttisgmtcnt,
tzh_ttisstdcnt,
tzh_leapcnt,
tzh_timecnt,
tzh_typecnt,
tzh_charcnt : longint;
end;
pttinfo=^tttinfo;
tttinfo=packed record
offset : longint;
isdst : boolean;
idx : byte;
isstd : byte;
isgmt : byte;
end;
pleap=^tleap;
tleap=record
transition : longint;
change : longint;
end;
var
num_transitions,
num_leaps,
num_types : longint;
transitions : plongint;
type_idxs : pbyte;
types : pttinfo;
zone_names : pchar;
leaps : pleap;
function find_transition(timer:time_t):pttinfo;
var
i : longint;
begin
if (num_transitions=0) or (timer<time_t(transitions[0])) then
begin
i:=0;
while (i<num_types) and (types[i].isdst) do
inc(i);
if (i=num_types) then
i:=0;
end
else
begin
for i:=1 to num_transitions do
if (timer<transitions[i]) then
break;
i:=type_idxs[i-1];
end;
find_transition:=@types[i];
end;
procedure GetLocalTimezone(timer:time_t;var leap_correct,leap_hit:longint);
var
info : pttinfo;
i : longint;
begin
{ reset }
TZDaylight:=false;
TZSeconds:=0;
TZName[false]:=nil;
TZName[true]:=nil;
leap_correct:=0;
leap_hit:=0;
{ get info }
info:=find_transition(timer);
if not assigned(info) then
exit;
TZDaylight:=info^.isdst;
TZSeconds:=info^.offset;
i:=0;
while (i<num_types) do
begin
tzname[types[i].isdst]:=@zone_names[types[i].idx];
inc(i);
end;
tzname[info^.isdst]:=@zone_names[info^.idx];
i:=num_leaps;
repeat
if i=0 then
exit;
dec(i);
until (timer>leaps[i].transition);
leap_correct:=leaps[i].change;
if (timer=leaps[i].transition) and
(((i=0) and (leaps[i].change>0)) or
(leaps[i].change>leaps[i-1].change)) then
begin
leap_hit:=1;
while (i>0) and
(leaps[i].transition=leaps[i-1].transition+1) and
(leaps[i].change=leaps[i-1].change+1) do
begin
inc(leap_hit);
dec(i);
end;
end;
end;
procedure GetLocalTimezone(timer:longint);
var
lc,lh : longint;
begin
GetLocalTimezone(timer,lc,lh);
end;
procedure ReadTimezoneFile(fn:string);
procedure decode(var l:longint);
var
k : longint;
p : pbyte;
begin
p:=pbyte(@l);
if (p[0] and (1 shl 7))<>0 then
k:=not 0
else
k:=0;
k:=(k shl 8) or p[0];
k:=(k shl 8) or p[1];
k:=(k shl 8) or p[2];
k:=(k shl 8) or p[3];
l:=k;
end;
var
f : File;
tzdir : string;
tzhead : ttzhead;
i : longint;
chars : longint;
buf : pbyte;
_result : longint;
label lose;
begin
if fn = '' then
exit;
{$IFOPT I+}
{$DEFINE IOCHECK_ON}
{$ENDIF}
{$I-}
Assign(F, fn);
Reset(F,1);
If IOResult <> 0 then
exit;
{$IFDEF IOCHECK_ON}
{$I+}
{$ENDIF}
{$UNDEF IOCHECK_ON}
BlockRead(f,tzhead,sizeof(tzhead),i);
if i<>sizeof(tzhead) then
goto lose;
if tzhead.tzh_magic<>TZ_MAGIC then
begin
goto lose;
end;
decode(tzhead.tzh_timecnt);
decode(tzhead.tzh_typecnt);
decode(tzhead.tzh_charcnt);
decode(tzhead.tzh_leapcnt);
decode(tzhead.tzh_ttisstdcnt);
decode(tzhead.tzh_ttisgmtcnt);
num_transitions:=tzhead.tzh_timecnt;
num_types:=tzhead.tzh_typecnt;
chars:=tzhead.tzh_charcnt;
reallocmem(transitions,num_transitions*sizeof(longint));
reallocmem(type_idxs,num_transitions);
reallocmem(types,num_types*sizeof(tttinfo));
reallocmem(zone_names,chars);
reallocmem(leaps,num_leaps*sizeof(tleap));
BlockRead(f,transitions^,num_transitions*4,_result);
if _result <> num_transitions*4 then
begin
goto lose;
end;
BlockRead(f,type_idxs^,num_transitions,_result);
if _result <> num_transitions then
begin
goto lose;
end;
{* Check for bogus indices in the data file, so we can hereafter
safely use type_idxs[T] as indices into `types' and never crash. *}
for i := 0 to num_transitions-1 do
if (type_idxs[i] >= num_types) then
begin
goto lose;
end;
for i:=0 to num_transitions-1 do
decode(transitions[i]);
for i:=0 to num_types-1 do
begin
blockread(f,types[i].offset,4,_result);
if _result <> 4 then
begin
goto lose;
end;
blockread(f,types[i].isdst,1,_result);
if _result <> 1 then
begin
goto lose;
end;
blockread(f,types[i].idx,1,_result);
if _result <> 1 then
begin
goto lose;
end;
decode(types[i].offset);
types[i].isstd:=0;
types[i].isgmt:=0;
end;
blockread(f,zone_names^,chars,_result);
if _result<>chars then
begin
goto lose;
end;
for i:=0 to num_leaps-1 do
begin
blockread(f,leaps[i].transition,4);
if _result <> 4 then
begin
goto lose;
end;
blockread(f,leaps[i].change,4);
begin
goto lose;
end;
decode(leaps[i].transition);
decode(leaps[i].change);
end;
getmem(buf,tzhead.tzh_ttisstdcnt);
blockread(f,buf^,tzhead.tzh_ttisstdcnt,_result);
if _result<>tzhead.tzh_ttisstdcnt then
begin
goto lose;
end;
for i:=0 to tzhead.tzh_ttisstdcnt-1 do
types[i].isstd:=byte(buf[i]<>0);
freemem(buf);
getmem(buf,tzhead.tzh_ttisgmtcnt);
blockread(f,buf^,tzhead.tzh_ttisgmtcnt);
if _result<>tzhead.tzh_ttisgmtcnt then
begin
goto lose;
end;
for i:=0 to tzhead.tzh_ttisgmtcnt-1 do
types[i].isgmt:=byte(buf[i]<>0);
freemem(buf);
close(f);
exit;
lose:
close(f);
end;
{ help function to extract TZ variable data }
function extractnumberend(tzstr: string; offset : integer): integer;
var
j: integer;
begin
j:=0;
extractnumberend := 0;
repeat
if (offset+j) > length(tzstr) then
begin
exit;
end;
inc(j);
until not (tzstr[offset+j] in ['0'..'9']);
extractnumberend := offset+j;
end;
function getoffsetseconds(tzstr: string): longint;
{ extract GMT timezone information }
{ Returns the number of minutes to }
{ add or subtract to the GMT time }
{ to get the local time. }
{ Format of TZ variable (POSIX) }
{ std offset dst }
{ std = characters of timezone }
{ offset = hh[:mm] to add to GMT }
{ dst = daylight savings time }
{ CURRENTLY DOES NOT TAKE CARE }
{ OF SUMMER TIME DIFFERENCIAL }
var
s: string;
i, j: integer;
code : integer;
hours : longint;
minutes : longint;
negative : boolean;
begin
hours:=0;
minutes:=0;
getoffsetseconds := 0;
negative := FALSE;
i:=-1;
{ get to offset field }
repeat
if i > length(tzstr) then
begin
exit;
end;
inc(i);
until (tzstr[i] = '-') or (tzstr[i] in ['0'..'9']);
if tzstr[i] = '-' then
begin
Inc(i);
negative := TRUE;
end;
j:=extractnumberend(tzstr,i);
s:=copy(tzstr,i,j-i);
val(s,hours,code);
if code <> 0 then
begin
exit;
end;
if tzstr[j] = ':' then
begin
i:=j;
Inc(i);
j:=extractnumberend(tzstr,i);
s:=copy(tzstr,i,j-i);
val(s,minutes,code);
if code <> 0 then
begin
exit;
end;
end;
if negative then
begin
minutes := -minutes;
hours := -hours;
end;
getoffsetseconds := minutes*60 + hours*3600;
end;
procedure InitLocalTime;
var
tloc: time_t;
s : string;
begin
TZSeconds:=0;
{ try to get the POSIX version }
{ of the local time offset }
{ if '', then it does not exist }
{ if ': ..', then non-POSIX }
s:=GetTimezoneString;
if (s<>'') and (s[1]<>':') then
begin
TZSeconds := getoffsetseconds(s);
end
else
begin
s:=GetTimeZoneFile;
{ only read if there is something to read }
if s<>'' then
begin
ReadTimezoneFile(s);
tloc:=sys_time(tloc);
GetLocalTimezone(tloc);
end;
end;
end;
procedure DoneLocalTime;
begin
if assigned(transitions) then
freemem(transitions);
if assigned(type_idxs) then
freemem(type_idxs);
if assigned(types) then
freemem(types);
if assigned(zone_names) then
freemem(zone_names);
if assigned(leaps) then
freemem(leaps);
num_transitions:=0;
num_leaps:=0;
num_types:=0;
end;
{
$Log$
Revision 1.2 2002-08-10 13:42:36 marco
* Fixes Posix dir copied to devel branch
Revision 1.1.2.2 2002/05/01 14:06:13 carl
* bugfix for stricter POSIX checking
+ TZ is now taken from GetTimezoneSitrng instead of getenv
Revision 1.1.2.1 2001/08/12 15:13:50 carl
+ first version of timezone stuff (more checking than the unix version)
}