From 97533b60f85a451980169ca5b12e58e590355066 Mon Sep 17 00:00:00 2001 From: marco Date: Wed, 8 Jan 2003 22:32:28 +0000 Subject: [PATCH] * Small fixes and quick merge with 1.0.x. At least the compiler builds now, but it could crash hard, since there are lots of unimplemented funcs. --- rtl/beos/Makefile | 2 +- rtl/beos/Makefile.fpc | 2 +- rtl/beos/beos.inc | 571 ++++++++++++++++ rtl/beos/dos.inc | 178 +++++ rtl/beos/dos.pp | 1439 +++++++++++++++++++++++++++-------------- rtl/beos/errno.inc | 219 +++++++ rtl/beos/osposix.inc | 505 +++++++++++++++ rtl/beos/osposixh.inc | 211 ++++++ rtl/beos/posix.pp | 94 +++ rtl/beos/syscall.inc | 99 +++ rtl/beos/system.pp | 7 +- rtl/beos/timezone.inc | 443 +++++++++++++ 12 files changed, 3299 insertions(+), 471 deletions(-) create mode 100644 rtl/beos/beos.inc create mode 100644 rtl/beos/dos.inc create mode 100644 rtl/beos/errno.inc create mode 100644 rtl/beos/osposix.inc create mode 100644 rtl/beos/osposixh.inc create mode 100644 rtl/beos/posix.pp create mode 100644 rtl/beos/syscall.inc create mode 100644 rtl/beos/timezone.inc diff --git a/rtl/beos/Makefile b/rtl/beos/Makefile index e3fb503e7b..744c44b4e6 100644 --- a/rtl/beos/Makefile +++ b/rtl/beos/Makefile @@ -225,7 +225,7 @@ override FPCOPT+=-Ur endif OBJPASDIR=$(RTL)/objpas GRAPHDIR=$(INC)/graph -override TARGET_UNITS+=system objpas strings beos dos sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo variants types +override TARGET_UNITS+=system objpas posix strings beos dos sysutils typinfo math varutils cpu mmx getopts heaptrc lineinfo variants types override TARGET_LOADERS+=prt0 cprt0 func dllprt override TARGET_RSTS+=math varutils typinfo override INSTALL_FPCPACKAGE=y diff --git a/rtl/beos/Makefile.fpc b/rtl/beos/Makefile.fpc index 5ae6814e2b..7a7b7e65ac 100644 --- a/rtl/beos/Makefile.fpc +++ b/rtl/beos/Makefile.fpc @@ -7,7 +7,7 @@ main=rtl [target] loaders=prt0 cprt0 func dllprt -units=system objpas strings \ +units=system posix objpas strings \ beos \ dos \ sysutils typinfo math varutils \ diff --git a/rtl/beos/beos.inc b/rtl/beos/beos.inc new file mode 100644 index 0000000000..801f7bed2f --- /dev/null +++ b/rtl/beos/beos.inc @@ -0,0 +1,571 @@ +{ + $Id$ + Copyright (c) 2001 by Carl Eric Codere + + + Implements BeOS system calls and types + + + 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. + + + **************************************************************************** +} +const + { BeOS specific calls } + syscall_nr_create_area = $14; + syscall_nr_resize_area = $08; + syscall_nr_delete_area = $15; + syscall_nr_load_image = $34; + syscall_nr_wait_thread = $22; + syscall_nr_rstat = $30; + syscall_nr_statfs = $5F; + syscall_nr_get_team_info = $3b; + syscall_nr_kill_team = $3a; + syscall_nr_get_system_info = $56; + syscall_nr_kget_tzfilename = $AF; + syscall_nr_get_next_image_info = $3C; + +const +{ ----- + system-wide constants; +----- *} + MAXPATHLEN = PATH_MAX; + B_FILE_NAME_LENGTH = NAME_MAX; + B_OS_NAME_LENGTH = 32; + B_PAGE_SIZE = 4096; + + + + +(* ----- + types +----- *) + + +type area_id = longint; +type port_id = longint; +type sem_id = longint; +type thread_id = longint; +type team_id = longint; +type bigtime_t = int64; +type status_t = longint; + + +{*************************************************************} +{*********************** KERNEL KIT **************************} +{*************************************************************} +{ ------------------------- Areas --------------------------- } +const + { create_area constant definitions } + { lock type } + B_NO_LOCK = 0; + B_LAZY_LOCK = 1; + B_FULL_LOCK = 2; + B_CONTIGUOUS = 3; + B_LOMEM = 4; + { address type } + B_ANY_ADDRESS = 0; + B_EXACT_ADDRESS = 1; + B_BASE_ADDRESS = 2; + B_CLONE_ADDRESS = 3; + B_ANY_KERNEL_ADDRESS = 4; + { protection bits } + B_READ_AREA = 1; + B_WRITE_AREA = 2; + + +type + area_info = packed record + area: area_id; + name: array[0..B_OS_NAME_LENGTH-1] of char; + size: size_t; + lock: cardinal; + protection: cardinal; + team: team_id; + ram_size: cardinal; + copy_count: cardinal; + in_count: cardinal; + out_count: cardinal; + address: pointer; + end; + + + function create_area(name : pchar; var addr : longint; + addr_typ : longint; size : longint; lock_type: longint; protection : longint): area_id; + var + args : SysCallArgs; + begin + args.param[1] := cint(name); + args.param[2] := cint(@addr); + args.param[3] := cint(addr_typ); + args.param[4] := cint(size); + args.param[5] := cint(lock_type); + args.param[6] := cint(protection); + create_area := SysCall(syscall_nr_create_area, args); + end; + + + function delete_area(area : area_id): status_t; + var + args: SysCallargs; + begin + args.param[1] := cint(area); + delete_area:= SysCall(syscall_nr_delete_area, args); + end; + + + function resize_area(area: area_id; new_size: size_t): status_t; + var + args: SysCallArgs; + begin + args.param[1] := cint(area); + args.param[2] := cint(new_size); + resize_area := SysCall(syscall_nr_resize_area, args); + end; + + { the buffer should at least have MAXPATHLEN+1 bytes in size } + function kget_tzfilename(buffer:pchar): cint; + var + args: SysCallArgs; + begin + args.param[1] := cint(buffer); + kget_tzfilename := SysCall(syscall_nr_kget_tzfilename,args); + end; + +(* +extern _IMPEXP_ROOT area_id clone_area(const char *name, void **dest_addr, + uint32 addr_spec, uint32 protection, + area_id source); + + +extern _IMPEXP_ROOT area_id find_area(const char *name); +extern _IMPEXP_ROOT area_id area_for(void *addr); +extern _IMPEXP_ROOT status_t set_area_protection(area_id id, + uint32 new_protection); + + +extern _IMPEXP_ROOT status_t _get_area_info(area_id id, area_info *ainfo, + size_t size); +extern _IMPEXP_ROOT status_t _get_next_area_info(team_id team, int32 *cookie, + area_info *ainfo, size_t size); +*) +{ ------------------------- Threads --------------------------- } + + + + +const + { thread state } + B_THREAD_RUNNING = 1; + B_THREAD_READY = 2; + B_THREAD_RECEIVING = 3; + B_THREAD_ASLEEP = 4; + B_THREAD_SUSPENDED = 5; + B_THREAD_WAITING = 6; + { thread priorities } + B_LOW_PRIORITY = 5; + B_NORMAL_PRIORITY = 10; + B_DISPLAY_PRIORITY = 15; + B_URGENT_DISPLAY_PRIORITY = 20; + B_REAL_TIME_DISPLAY_PRIORITY= 100; + B_URGENT_PRIORITY = 110; + B_REAL_TIME_PRIORITY = 120; + + +type + thread_info = packed record + thread: thread_id; + team: team_id; + name: array[0..B_OS_NAME_LENGTH-1] of char; + state: longint; { thread_state enum } + priority:longint; + sem:sem_id; + user_time:bigtime_t; + kernel_time:bigtime_t; + stack_base:pointer; + stack_end:pointer; + end; + + +{ + + +extern _IMPEXP_ROOT thread_id spawn_thread ( + thread_func function_name, + const char *thread_name, + int32 priority, + void *arg +); + + +extern _IMPEXP_ROOT thread_id find_thread(const char *name); +extern _IMPEXP_ROOT status_t kill_thread(thread_id thread); +extern _IMPEXP_ROOT status_t resume_thread(thread_id thread); +extern _IMPEXP_ROOT status_t suspend_thread(thread_id thread); +extern _IMPEXP_ROOT status_t rename_thread(thread_id thread, const char *new_name); +extern _IMPEXP_ROOT status_t set_thread_priority (thread_id thread, int32 new_priority); +extern _IMPEXP_ROOT void exit_thread(status_t status); + + +extern _IMPEXP_ROOT status_t _get_thread_info(thread_id thread, thread_info *info, size_t size); +extern _IMPEXP_ROOT status_t _get_next_thread_info(team_id tmid, int32 *cookie, thread_info *info, size_t size); + + + + + + +extern _IMPEXP_ROOT status_t send_data(thread_id thread, + int32 code, + const void *buf, + size_t buffer_size); + + +extern _IMPEXP_ROOT status_t receive_data(thread_id *sender, + void *buf, + size_t buffer_size); + + +extern _IMPEXP_ROOT bool has_data(thread_id thread); + + + + +extern _IMPEXP_ROOT status_t snooze(bigtime_t microseconds); + + +/* + Right now you can only snooze_until() on a single time base, the + system time base given by system_time(). The "time" argument is + the time (in the future) relative to the current system_time() that + you want to snooze until. Eventually there will be multiple time + bases (and a way to find out which ones exist) but for now just pass + the value B_SYSTEM_TIMEBASE. +*/ +extern _IMPEXP_ROOT status_t snooze_until(bigtime_t time, int timebase); +#define B_SYSTEM_TIMEBASE (0) + + +} + + + + + function wait_for_thread(thread: thread_id; var status : status_t): status_t; + var + args: SysCallArgs; + i: longint; + begin + args.param[1] := cint(thread); + args.param[2] := cint(@status); + wait_for_thread := SysCall(syscall_nr_wait_thread, args); + end; + + +{ ------------------------- Teams --------------------------- } + + +const + B_SYSTEM_TEAM = 2; + + +type + team_info = packed record + team: team_id; + image_count: longint; + thread_count: longint; + area_count: longint; + debugger_nub_thread: thread_id; + debugger_nub_port: port_id; + argc:longint; (* number of args on the command line *) + args: array[0..63] of char; {* abbreviated command line args *} + uid: uid_t; + gid: gid_t; + end; +{ +extern _IMPEXP_ROOT status_t _get_next_team_info(int32 *cookie, team_info *info, size_t size); +} + + + function get_team_info(team: team_id; var info : team_info): status_t; + var + args: SysCallArgs; + begin + args.param[1] := cint(team); + args.param[2] := cint(@info); + get_team_info := SysCall(syscall_nr_get_team_info, args); + end; + + + function kill_team(team: team_id): status_t; + var + args: SysCallArgs; + begin + args.param[1] := cint(team); + kill_team := SysCall(syscall_nr_kill_team, args); + end; + + +{ ------------------------- Images --------------------------- } + + +type image_id = longint; + + + { image types } +const + B_APP_IMAGE = 1; + B_LIBRARY_IMAGE = 2; + B_ADD_ON_IMAGE = 3; + B_SYSTEM_IMAGE = 4; +type + image_info = packed record + id : image_id; + _type : longint; + sequence: longint; + init_order: longint; + init_routine: pointer; + term_routine: pointer; + device: dev_t; + node: ino_t; + name: array[0..MAXPATHLEN-1] of char; + text: pointer; + data: pointer; + text_size: longint; + data_size: longint; + end; + + + + function get_next_image_info(team : team_id; var cookie: longint;var info : image_info): status_t; + var + args: SysCallArgs; + begin + args.param[1] := cint(team); + args.param[2] := cint(@cookie); + args.param[3] := cint(@info); + args.param[4] := cint(sizeof(image_info)); + get_next_image_info := SysCall(syscall_nr_get_next_image_info, args); + end; + +{ +extern _IMPEXP_ROOT image_id load_add_on(const char *path); +extern _IMPEXP_ROOT status_t unload_add_on(image_id imid); + + +/* private; use the macros, below */ +extern _IMPEXP_ROOT status_t _get_image_info (image_id image, + image_info *info, size_t size); +extern _IMPEXP_ROOT status_t _get_next_image_info (team_id team, int32 *cookie, + image_info *info, size_t size); + + +} +(*----- symbol types and functions ------------------------*) + + +const B_SYMBOL_TYPE_DATA = $1; +const B_SYMBOL_TYPE_TEXT = $2; +const B_SYMBOL_TYPE_ANY = $5; +{ +extern _IMPEXP_ROOT status_t get_image_symbol(image_id imid, + const char *name, int32 sclass, void **ptr); +extern _IMPEXP_ROOT status_t get_nth_image_symbol(image_id imid, int32 index, + char *buf, int32 *bufsize, int32 *sclass, + void **ptr); +} + + +{*----- cache manipulation --------------------------------*} +const + B_FLUSH_DCACHE =$0001; {* dcache = data cache *} + B_FLUSH_ICACHE =$0004; {* icache = instruction cache *} + B_INVALIDATE_DCACHE =$0002; + B_INVALIDATE_ICACHE =$0008; + + +{ +extern _IMPEXP_ROOT void clear_caches(void *addr, size_t len, uint32 flags); +} + + + function load_image(argc : longint; argv : ppchar; envp : ppchar): thread_id; + var + args: SysCallArgs; + i: longint; + begin + args.param[1] := cint(argc); + args.param[2] := cint(argv); + args.param[3] := cint(envp); + load_image := SysCall(syscall_nr_load_image, args); + end; + + +{ ------------------------ System information --------------------------- } +{ for both intel and ppc platforms } +const B_MAX_CPU_COUNT = 8; + + +type + system_info = packed record + id: array[0..1] of longint; {* unique machine ID *} + boot_time: bigtime_t; {* time of boot (# usec since 1/1/70) *} + cpu_count: longint; {* # of cpus *} + cpu_type: longint; {* type of cpu *} + cpu_revision:longint ; {* revision # of cpu *} + cpu_infos: array [0..B_MAX_CPU_COUNT-1] of bigtime_t; {* info about individual cpus *} + cpu_clock_speed:int64; {* processor clock speed (Hz) *} + bus_clock_speed:int64; {* bus clock speed (Hz) * } + platform_type:longint; {* type of machine we're on *} + max_pages:longint; {* total # physical pages *} + used_pages:longint; {* # physical pages in use *} + page_faults:longint; {* # of page faults *} + max_sems:longint; {* maximum # semaphores *} + used_sems:longint; {* # semaphores in use *} + max_ports:longint; {* maximum # ports *} + used_ports:longint; {* # ports in use *} + max_threads:longint; {* maximum # threads *} + used_threads:longint; {* # threads in use *} + max_teams:longint; {* maximum # teams *} + used_teams:longint; {* # teams in use *} + + kernel_name: array[0..B_FILE_NAME_LENGTH-1] of char; {* name of kernel *} + kernel_build_date: array[0..B_OS_NAME_LENGTH-1] of char; {* date kernel built *} + kernel_build_time: array[0..B_OS_NAME_LENGTH-1] of char; {* time kernel built *} + kernel_version:int64; {* version of this kernel *} + _busy_wait_time:bigtime_t; {* reserved for Be *} + pad:array[1..4] of longint; {* just in case... *} + end; + + + function get_system_info(var info: system_info): status_t; + var + args: SysCallArgs; + i: longint; + begin + args.param[1] := cint(@info); + i := SysCall(syscall_nr_get_system_info, args); + get_system_info := i; + end; + + + + +{*************************************************************} +{*********************** STORAGE KIT *************************} +{*************************************************************} +const + { file system flags } + B_FS_IS_READONLY = $00000001; + B_FS_IS_REMOVABLE = $00000002; + B_FS_IS_PERSISTENT = $00000004; + B_FS_IS_SHARED = $00000008; + B_FS_HAS_MIME = $00010000; + B_FS_HAS_ATTR = $00020000; + B_FS_HAS_QUERY = $00040000; + + +type + fs_info = packed record + dev : dev_t; { fs dev_t } + root : ino_t; { root ino_t } + flags : cardinal; { file system flags } + block_size:off_t; { fundamental block size } + io_size:off_t; { optimal io size } + total_blocks:off_t; { total number of blocks } + free_blocks:off_t; { number of free blocks } + total_nodes:off_t; { total number of nodes } + free_nodes:off_t; { number of free nodes } + device_name: array[0..127] of char; { device holding fs } + volume_name: array[0..B_FILE_NAME_LENGTH-1] of char;{ volume name } + fsh_name : array[0..B_OS_NAME_LENGTH-1] of char;{ name of fs handler } + end; + + + function dev_for_path(const pathname : pchar): dev_t; + var + args: SysCallArgs; + buffer: array[1..15] of longint; + i: cint; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(pathname); + args.param[3] := cint(@buffer); + args.param[4] := $01000000; + if SysCall(syscall_nr_rstat, args)=0 then + i:=buffer[1] + else + i:=-1; + dev_for_path := i; + end; + + + function fs_stat_dev(device: dev_t; var info: fs_info): dev_t; + var + args: SysCallArgs; + begin + args.param[1] := cint(device); + args.param[2] := 0; + args.param[3] := $FFFFFFFF; + args.param[4] := 0; + args.param[5] := cint(@info); + fs_stat_dev := SysCall(syscall_nr_statfs, args); + end; + + +{ +_IMPEXP_ROOT dev_t next_dev(int32 *pos); +} + + +{*****************************************************************} + + + + + + + + +{ + $Log$ + Revision 1.2 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.6 2002/02/15 18:15:00 carl + + added get_next_image_info + + Revision 1.1.2.5 2001/08/13 05:56:35 carl + * renamed routine names (names are same as documented in the Be Book) + + Revision 1.1.2.4 2001/08/12 15:14:24 carl + + added kget_tzfilename() kernel call to get timezone info. + + Revision 1.1.2.3 2001/08/04 06:14:15 carl + - remove crappy tab characters + + Revision 1.1.2.2 2001/08/04 05:25:03 carl + + added much more system headers and system calls + + + Revision 1.1.2.1 2001/08/03 01:57:36 carl + * beos types and system inteface (minimalistic for the moment) + + +} diff --git a/rtl/beos/dos.inc b/rtl/beos/dos.inc new file mode 100644 index 0000000000..da735855c8 --- /dev/null +++ b/rtl/beos/dos.inc @@ -0,0 +1,178 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 2001 by members of the Free Pascal + development team + + Operating system specific calls for DOS unit (part of POSIX interface) + + 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. + + **********************************************************************} +{$i syscall.inc} +{$i beos.inc} + +{$define DOS_HAS_EXEC} + + +{ + 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. + The drive names are OS specific +} +Const + FixDriveStr : array[0..3] of pchar=( + '.', { the current directory } + '/disk 0/.', { mounted floppy 1 } + '/disk 1/.', { mounted floppy 2 } + '/boot/.' { the boot up disk } + ); + + +Function DosVersion:Word; +Begin + DosVersion := 0; +End; + + + +Function DiskFree(Drive: Byte): int64; +var + info: fs_info; + device : dev_t; +Begin + device := 0; + DiskFree := -1; + if (Drive < 4) and (FixDriveStr[Drive]<>nil) then + begin + device:= dev_for_path(FixDriveStr[Drive]); + end + else + if (Drive>4) and (Drive<=MAX_DRIVES) and (drivestr[Drive]<>nil) then + device := dev_for_path(driveStr[drive]) + else + begin + exit; + end; + if fs_Stat_dev(device,info)=0 then + DiskFree := int64(info.block_size)*int64(info.free_blocks); +End; + + + +Function DiskSize(Drive: Byte): int64; +var + info: fs_info; + device : dev_t; +Begin + device := 0; + DiskSize:= -1; + if (Drive < 4) and (FixDriveStr[Drive]<>nil) then + begin + device:= dev_for_path(FixDriveStr[Drive]); + end + else + if (Drive>4) and (Drive<=MAX_DRIVES) and (drivestr[Drive]<>nil) then + device := dev_for_path(driveStr[drive]) + else + begin + exit; + end; + if fs_Stat_dev(device,info)=0 then + DiskSize := int64(info.block_size)*int64(info.total_blocks); +End; + + + +{****************************************************************************** + --- Exec --- +******************************************************************************} +var + LastDosExitCode: word; + +Procedure Exec(const path: pathstr; const comline: comstr); +var p:string; + argv:ppchar; + argc:longint; + th:thread_id; + status : status_t; +begin + LastDosExitCode:=0; + DosError:= 0; + p:=path+' '+comline; + argv:=StringToPPChar(p,argc); + th:=load_image(argc,argv,system.envp); + if th<0 then begin + DosError:=5; { lets emulate an error } + exit; + end; + wait_for_thread(th,status); + LastDosExitCode:=status and $FF; { only keep the lower 8-bits } +end; + +Function DosExitCode: Word; +Begin + DosExitCode:=LastDosExitCode; +End; + + +function GetTimeZoneString : string; +begin + GetTimeZoneString:=getenv('TZ'); +end; + +function GetTimezoneFile:string; +var + f,len : longint; + s : string; + info : stat; + buffer : array[0..MAXPATHLEN+1] of char; +begin + GetTimezoneFile:=''; + + if kget_tzfilename(pchar(@buffer))=0 then + begin + GetTimeZoneFile := strpas(pchar(@buffer)); + end; +end; + + +{ + $Log$ + Revision 1.2 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.6 2002/05/01 14:08:53 carl + + TZ is now taken from GetTimezoneSitrng instead of getenv + + Revision 1.1.2.5 2001/12/17 02:14:50 carl + * bugfix for more than default drives + + Revision 1.1.2.4 2001/08/15 01:01:29 carl + + added missing file include + + Revision 1.1.2.3 2001/08/13 05:57:01 carl + * renamed routine names (names are same as documented in the Be Book) + + Revision 1.1.2.2 2001/08/12 15:14:54 carl + + GetTimeZoneFileName() + + Revision 1.1.2.1 2001/08/04 05:26:08 carl + + Exec() works + + DiskFree() / DiskSize() works + +} diff --git a/rtl/beos/dos.pp b/rtl/beos/dos.pp index 81168f6064..942ef4e257 100644 --- a/rtl/beos/dos.pp +++ b/rtl/beos/dos.pp @@ -1,9 +1,10 @@ { $Id$ This file is part of the Free Pascal run time library. - Copyright (c) 1999-2000 by the Free Pascal development team. + Copyright (c) 2001 by members of the Free Pascal + development team - Dos unit for BP7 compatible RTL + DOS unit template based on POSIX See the file COPYING.FPC, included in this distribution, for details about the copyright. @@ -13,23 +14,14 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} -unit dos; -interface - -uses beos; - -const - FileNameLen=255; - -type - ComStr = String[FileNameLen]; - PathStr = String[FileNameLen]; - DirStr = String[FileNameLen]; - NameStr = String[FileNameLen]; - ExtStr = String[FileNameLen]; +Unit Dos; +Interface +{$goto on} Const + {Max FileName Length for files} + FileNameLen=255; {Bitmasks for CPU Flags} fcarry = $0001; @@ -54,14 +46,27 @@ Const fmoutput = $D7B2; fminout = $D7B3; +Type + ComStr = String[FileNameLen]; + PathStr = String[FileNameLen]; + DirStr = String[FileNameLen]; + NameStr = String[FileNameLen]; + ExtStr = String[FileNameLen]; - S_IFMT = $F000; { type of file } - S_IFLNK = $A000; { symbolic link } - S_IFREG = $8000; { regular } - S_IFBLK = $6000; { block special } - S_IFDIR = $4000; { directory } - S_IFCHR = $2000; { character special } - S_IFIFO = $1000; { fifo } + SearchRec = packed Record + {Fill : array[1..21] of byte; Fill replaced with below} + DirPtr : pointer; {directory pointer for reading directory} + SearchAttr : Byte; {attribute we are searching for} + Fill : Array[1..16] of Byte; {future use} + {End of fill} + Attr : Byte; {attribute of found file} + Time : LongInt; {last modify date of found file} + Size : LongInt; {file size of found file} + Reserved : Word; {future use} + Name : String[FileNameLen]; {name of found file} + SearchSpec : String[FileNameLen]; {search pattern} + SearchDir : String[FileNameLen]; { path we are searching in } + End; { filerec.inc contains the definition of the filerec. @@ -72,6 +77,13 @@ Const {$i filerec.inc} {$i textrec.inc} + Registers = packed record + case i : integer of + 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word); + 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte); + 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint); + End; + DateTime = packed record Year, Month, @@ -81,26 +93,16 @@ Const Sec : word; End; - searchrec = record - fd : longint; - path : string; - fname : string; - attr : byte; - time : longint; - size : longint; - name : string[255]; - end; - - Var DosError : integer; -{Info/Date/Time} -Procedure GetDate(var year, month, mday, wday: word); -procedure GetTime(var hour,min,sec,msec,usec:word); -procedure GetTime(var hour,min,sec,sec100:word); -procedure GetTime(Var Hour,Min,Sec:Word); +{Info/Date/Time} +Function DosVersion: Word; +Procedure GetDate(var year, month, mday, wday: word); +Procedure GetTime(var hour, minute, second, sec100: word); +procedure SetDate(year,month,day: word); +Procedure SetTime(hour,minute,second,sec100: word); Procedure UnpackTime(p: longint; var t: datetime); Procedure PackTime(var t: datetime; var p: longint); @@ -108,408 +110,56 @@ Procedure PackTime(var t: datetime; var p: longint); Procedure Exec(const path: pathstr; const comline: comstr); Function DosExitCode: word; - {Disk} +Procedure AddDisk(const path:string); +Function DiskFree(drive: byte) : int64; +Function DiskSize(drive: byte) : int64; Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec); Procedure FindNext(var f: searchRec); -Procedure FindClose(var f: searchRec); +Procedure FindClose(Var f: SearchRec); {File} -{Procedure GetFAttr(var f:File; var attr: word);} -procedure GetFTime(var f:File; var time: longint); -procedure GetFTime(f:string; var time: longint); -Procedure SetFTime(var f:File; time : longint); -Function FSearch(path: pathstr; dirlist: string): pathstr; +Procedure GetFAttr(var f; var attr: word); +Procedure GetFTime(var f; var time: longint); +Function FSearch(const path: pathstr; dirlist: string): pathstr; Function FExpand(const path: pathstr): pathstr; -Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr); - - - +Procedure FSplit(const path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr); {Environment} -{Function EnvCount: longint; -Function EnvStr(index: integer): string;} +Function EnvCount: longint; +Function EnvStr(index: integer): string; +Function GetEnv (envvar: string): string; -{Misc} -{Procedure SetFAttr(var f; attr: word); -Procedure SetFTime(var f; time: longint); -Procedure GetVerify(var verify: boolean); -Procedure SetVerify(verify: boolean);} - -{Do Nothing Functions} +{Do Nothing Functions, no POSIX version} +Procedure Intr(intno: byte; var regs: registers); +Procedure MSDos(var regs: registers); Procedure SwapVectors; -{Procedure GetIntVec(intno: byte; var vector: pointer); +Procedure GetIntVec(intno: byte; var vector: pointer); Procedure SetIntVec(intno: byte; vector: pointer); -Procedure Keep(exitcode: word);} -function GetEnv(EnvVar: String): String; +Procedure Keep(exitcode: word); +Procedure SetFAttr(var f; attr: word); +Procedure SetFTime(var f; time: longint); +Procedure GetCBreak(var breakvalue: boolean); +Procedure SetCBreak(breakvalue: boolean); +Procedure GetVerify(var verify: boolean); +Procedure SetVerify(verify: boolean); -Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word); +Implementation + +Uses + Strings,posix; -implementation - -uses strings; - - -procedure GetFTime(var f:file; var time: longint); -var info:stat; - t:longint; - dt:DateTime; -begin - if not FStat(F,Info) then begin - t:=0; - doserror:=3; - exit; - end else t:=info.ctime; - EpochToLocal(t,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec); - packtime(dt,time); -end; - -procedure GetFTime(f:string; var time: longint); -var info:stat; - t:longint; - dt:DateTime; -begin - if not FStat(F,Info) then begin - t:=0; - doserror:=3; - exit; - end else t:=info.ctime; - EpochToLocal(t,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec); - packtime(dt,time); -end; - - -type utimbuf=record actime,modtime:longint; end; -{function _utime (path:pchar;var buf:utimbuf):longint; cdecl; external name 'utime';} - -Procedure setftime(var f:file; time : longint); -{var buf:utimbuf;} -begin -{ buf.actime:=time; - buf.modtime:=time;} -{ writeln ('SetFTime ',PChar(@FileRec(f).Name),' := ',time);} -{ if _utime(PChar(@FileRec(f).Name),buf)<>0 then doserror:=3;} -end; - - -{****************************************************************************** - --- Info / Date / Time --- -******************************************************************************} - - -procedure getdate(var year,month,mday,wday : word); -begin -end; - -function sys_time:longint; cdecl; external name 'sys_time'; - - -procedure GetTime(var hour,min,sec,msec,usec:word); -{ - Gets the current time, adjusted to local time -} + { Used by AddDisk(), DiskFree() and DiskSize() } +const + Drives : byte = 4; + MAX_DRIVES = 26; var - year,day,month:Word; - t : longint; -begin - t:=sys_time; - EpochToLocal(t,year,month,day,hour,min,sec); - msec:=0; - usec:=0; -end; + DriveStr : array[4..MAX_DRIVES] of pchar; -procedure GetTime(var hour,min,sec,sec100:word); -{ Gets the current time, adjusted to local time } -var usec : word; -begin - gettime(hour,min,sec,sec100,usec); - sec100:=sec100 div 10; -end; -procedure GetTime(Var Hour,Min,Sec:Word); -{ - Gets the current time, adjusted to local time - } - var - msec,usec : Word; - Begin - gettime(hour,min,sec,msec,usec); -end; - - - -Procedure packtime(var t : datetime;var p : longint); -Begin - p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25); -End; - - -Procedure unpacktime(p : longint;var t : datetime); -Begin - with t do - begin - sec:=(p and 31) shl 1; - min:=(p shr 5) and 63; - hour:=(p shr 11) and 31; - day:=(p shr 16) and 31; - month:=(p shr 21) and 15; - year:=(p shr 25)+1980; - end; -End; - - -{****************************************************************************** - --- Exec --- -******************************************************************************} - - -Procedure Exec(const path: pathstr; const comline: comstr); -var p:string; -begin - p:=path+' '+comline; - doserror:=beos.shell(p); -end; - -Function DosExitCode: word; -begin - dosexitcode:=doserror; -end; - - - - -{****************************************************************************** - --- File --- -******************************************************************************} - -Procedure FSplit(Path: PathStr; Var Dir: DirStr; Var Name: NameStr;Var Ext: ExtStr); - -Begin - beos.FSplit(Path,Dir,Name,Ext); -End; - -Function FExpand(Const Path: PathStr): PathStr; -Begin - FExpand:=beos.FExpand(Path); -End; - -Function FSearch(path : pathstr;dirlist : string) : pathstr; -Var info:stat; -Begin -if (length(Path)>0) and (path[1]='/') and FStat(path,info) then - FSearch:=path - else - FSearch:=beos.FSearch(path,dirlist); -End; - - - -{****************************************************************************** - --- Findfirst FindNext --- -******************************************************************************} - -{procedure dossearchrec2searchrec(var f : searchrec); -var - len : longint; -begin - len:=StrLen(@f.Name); - Move(f.Name[0],f.Name[1],Len); - f.Name[0]:=chr(len); -end;} - -type dirent = packed record - d_dev:longint; - d_pdev:longint; - d_ino:int64; - d_pino:int64; - d_reclen:word; - d_name:array[0..255] of char; -end; - -function sys_opendir (a:dword;path:pchar;b:longint):longint; cdecl; external name 'sys_opendir'; -function sys_readdir (fd:longint;var de:dirent;a:longint;b:byte):longint; cdecl; external name 'sys_readdir'; - -procedure findnext(var f : searchRec); -var len:longint; - ent:dirent; - info:stat; - dt:DateTime; -begin - if sys_readdir(f.fd,ent,$11C,1)=0 then begin - doserror:=3; - exit; - end; -{ writeln ('NAME: ',pchar(@ent.d_name[0]));} - - len:=StrLen(@ent.d_name); - Move(ent.d_name,f.name[1],len); - f.name[0]:=chr(len); -{ writeln ('NAME: "',f.path+f.name,'"');} - - if not FStat(f.path+f.name,info) then begin - writeln ('NOT FOUND'); - doserror:=3; - exit; - end; - writeln ('OK'); - - f.size:=info.size; - - f.attr:=0; - if (info.mode and S_IFMT)=S_IFDIR then f.attr:=directory; - - EpochToLocal(info.mtime,dt.year,dt.month,dt.day,dt.hour,dt.min,dt.sec); - packtime(dt,f.time); - doserror:=0; - -end; - - -procedure findfirst(const path : pathstr;attr : word;var f : searchRec); -var tmp:string; - info:stat; - ext:string; -begin - tmp:=path; - if tmp='' then tmp:='.'; - - if FStat(tmp,info) then begin - if ((info.mode and S_IFMT)=S_IFDIR) and (tmp[length(tmp)]<>'/') then tmp:=tmp+'/'; - end; - - FSplit (tmp,f.path,f.fname,ext); -{ f.path:=FExpand(f.path);} - f.fname:=f.fname+ext; - if length(f.fname)=0 then f.fname:='*'; - - tmp:=tmp+#0; - f.fd:=sys_opendir ($FF000000,@tmp[1],0); - writeln ('F.PATH=',f.path,' ; ',f.fname); - findnext(f); -end; - -Procedure FindClose(Var f: SearchRec); -begin - DosError:=0; -end; - - -procedure swapvectors; -begin -{ no beos equivalent } - DosError:=0; -end; - - - -{****************************************************************************** - --- Environment --- -******************************************************************************} - -function envcount : longint; -var - hp : ppchar; -begin - hp:=envp; - envcount:=0; - while assigned(hp^) do - begin - inc(envcount); - hp:=hp+4; - end; -end; - - -function envstr(index : integer) : string; -begin - if (index<=0) or (index>envcount) then - begin - envstr:=''; - exit; - end; - envstr:=strpas(ppchar(envp+4*(index-1))^); -end; - - -{****************************************************************************** - --- Not Supported --- -******************************************************************************} - -Procedure keep(exitcode : word); -Begin -End; - -Procedure getintvec(intno : byte;var vector : pointer); -Begin -End; - -Procedure setintvec(intno : byte;vector : pointer); -Begin -End; - - - - -{****************************************************************************** - Date and Time related calls -******************************************************************************} - -Const -{Date Translation} - C1970=2440588; - D0 = 1461; - D1 = 146097; - D2 =1721119; - -Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word); -Var - YYear,XYear,Temp,TempMonth : LongInt; -Begin - Temp:=((JulianDN-D2) shl 2)-1; - JulianDN:=Temp Div D1; - XYear:=(Temp Mod D1) or 3; - YYear:=(XYear Div D0); - Temp:=((((XYear mod D0)+4) shr 2)*5)-3; - Day:=((Temp Mod 153)+5) Div 5; - TempMonth:=Temp Div 153; - If TempMonth>=10 Then - Begin - inc(YYear); - dec(TempMonth,12); - End; - inc(TempMonth,3); - Month := TempMonth; - Year:=YYear+(JulianDN*100); -end; - - -Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word); -{ Transforms Epoch time into local time (hour, minute,seconds) } -Var - DateNum: LongInt; -Begin - Datenum:=(Epoch Div 86400) + c1970; - JulianToGregorian(DateNum,Year,Month,day); - Epoch:=Epoch Mod 86400; - Hour:=Epoch Div 3600; - Epoch:=Epoch Mod 3600; - Minute:=Epoch Div 60; - Second:=Epoch Mod 60; -End; - - -{ - $Log$ - Revision 1.3 2002-09-07 16:01:17 peter - * old logs removed and tabs fixed - -} - - - -Function StringToPPChar(Var S:STring):ppchar; +Function StringToPPChar(Var S:STring; var count : longint):ppchar; { Create a PPChar to structure of pchars which are the arguments specified in the string S. Especially usefull for creating an ArgV for Exec-calls @@ -534,7 +184,8 @@ begin StringToPPChar:=p; if p=nil then begin -{ LinuxError:=sys_enomem;} + Errno:=sys_enomem; + count := 0; exit; end; buf:=@s[1]; @@ -551,62 +202,914 @@ begin while not (buf^ in [' ',#0,#8,#10]) do inc(buf); end; + count := nr; end; +{$i dos.inc} { include OS specific stuff } -Function Dirname(Const path:pathstr):pathstr; + + + +{****************************************************************************** + --- Info / Date / Time --- +******************************************************************************} +var + TZSeconds : longint; { offset to add/ subtract from Epoch to get local time } + tzdaylight : boolean; + tzname : array[boolean] of pchar; + + +type + GTRec = packed Record + Year, + Month, + MDay, + WDay, + Hour, + Minute, + Second : Word; + End; +Const +{Date Calculation} + C1970 = 2440588; + D0 = 1461; + D1 = 146097; + D2 = 1721119; + + +function WeekDay (y,m,d:longint):longint; { - This function returns the directory part of a complete path. - Unless the directory is root '/', The last character is not - a slash. + Calculates th day of the week. returns -1 on error } var - Dir : PathStr; - Name : NameStr; - Ext : ExtStr; + u,v : longint; begin - FSplit(Path,Dir,Name,Ext); - if length(Dir)>1 then - Delete(Dir,length(Dir),1); - DirName:=Dir; -end; - - - -Function Basename(Const path:pathstr;Const suf:pathstr):pathstr; -{ - This function returns the filename part of a complete path. If suf is - supplied, it is cut off the filename. -} -var - Dir : PathStr; - Name : NameStr; - Ext : ExtStr; -begin - FSplit(Path,Dir,Name,Ext); - if Suf<>Ext then - Name:=Name+Ext; - BaseName:=Name; -end; - - -function GetEnv(EnvVar: String): String; -var p:pchar; -begin - p:=beos.GetEnv(EnvVar); - if p=nil then - GetEnv:='' + if (m<1) or (m>12) or (y<1600) or (y>4000) or + (d<1) or (d>30+((m+ord(m>7)) and 1)-ord(m=2)) or + ((m*d=58) and (((y mod 4>0) or (y mod 100=0)) and (y mod 400>0))) then + WeekDay:=-1 else - GetEnv:=StrPas(p); + begin + u:=m; + v:=y; + if m<3 then + begin + inc(u,12); + dec(v); + end; + WeekDay:=(d+2*u+((3*(u+1)) div 5)+v+(v div 4)-(v div 100)+(v div 400)+1) mod 7; + end; end; + + +Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word); +Var + YYear,XYear,Temp,TempMonth : LongInt; +Begin + Temp:=((JulianDN-D2) shl 2)-1; + JulianDN:=Temp Div D1; + XYear:=(Temp Mod D1) or 3; + YYear:=(XYear Div D0); + Temp:=((((XYear mod D0)+4) shr 2)*5)-3; + Day:=((Temp Mod 153)+5) Div 5; + TempMonth:=Temp Div 153; + If TempMonth>=10 Then + Begin + inc(YYear); + dec(TempMonth,12); + End; + inc(TempMonth,3); + Month := TempMonth; + Year:=YYear+(JulianDN*100); +end; + + + +Procedure EpochToLocal(epoch:time_t;var year,month,day,hour,minute,second:Word); +{ + Transforms Epoch time into local time (hour, minute,seconds) +} +Var + DateNum: time_t; +Begin + Epoch:=Epoch+TZSeconds; + Datenum:=(Epoch Div 86400) + c1970; + JulianToGregorian(DateNum,Year,Month,day); + Epoch:=Abs(Epoch Mod 86400); + Hour:=Epoch Div 3600; + Epoch:=Epoch Mod 3600; + Minute:=Epoch Div 60; + Second:=Epoch Mod 60; +End; + + + +Procedure GetDate(Var Year, Month, MDay, WDay: Word); +var + hour,minute,second : word; + timeval : time_t; +Begin + timeval := sys_time(timeval); + { convert the GMT time to local time } + EpochToLocal(timeval,year,month,mday,hour,minute,second); + Wday:=weekday(Year,Month,MDay); +end; + + + +Procedure SetDate(Year, Month, Day: Word); +Begin + {!!} +End; + + + + +Procedure GetTime(Var Hour, Minute, Second, Sec100: Word); +var + timeval : time_t; + year,month,day: word; +Begin + timeval := sys_time(timeval); + EpochToLocal(timeval,year,month,day,hour,minute,second); + Sec100 := 0; +end; + + + +Procedure SetTime(Hour, Minute, Second, Sec100: Word); +Begin + {!!} +End; + + + +Procedure packtime(var t : datetime;var p : longint); +Begin + p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25); +End; + + + +Procedure unpacktime(p : longint;var t : datetime); +Begin + t.sec:=(p and 31) shl 1; + t.min:=(p shr 5) and 63; + t.hour:=(p shr 11) and 31; + t.day:=(p shr 16) and 31; + t.month:=(p shr 21) and 15; + t.year:=(p shr 25)+1980; +End; + + +Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime); +Begin + EpochToLocal(SecsPast,dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec); +End; + + +{$ifndef DOS_HAS_EXEC} +{****************************************************************************** + --- Exec --- +******************************************************************************} + +var + LastDosExitCode: word; + + +Function InternalWaitProcess(Pid:pid_t):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated} +var r,s : cint; +begin + repeat + s:=$7F00; + r:=sys_WaitPid(Pid,s,0); + until (r<>-1) or (Errno<>Sys_EINTR); + { When r = -1 or r = 0, no status is available, so there was an error. } + if (r=-1) or (r=0) then + InternalWaitProcess:=-1 { return -1 to indicate an error } + else + begin + { process terminated normally } + if wifexited(s)<>0 then + begin + { get status code } + InternalWaitProcess := wexitstatus(s); + exit; + end; + { process terminated due to a signal } + if wifsignaled(s)<>0 then + begin + { get signal number } + InternalWaitProcess := wstopsig(s); + exit; + end; + InternalWaitProcess:=-1; + end; +end; + + + + +Procedure Exec (Const Path: PathStr; Const ComLine: ComStr); +var + pid : pid_t; + tmp : string; + p : ppchar; + count: longint; + // The Error-Checking in the previous Version failed, since halt($7F) gives an WaitPid-status of $7F00 + F: File; +Begin +{$IFOPT I+} +{$DEFINE IOCHECK} +{$ENDIF} +{$I-} + { verify if the file to execute exists } + Assign(F,Path); + Reset(F,1); + if IOResult <> 0 then + { file not found } + begin + DosError := 2; + exit; + end + else + Close(F); +{$IFDEF IOCHECK} +{$I+} +{$UNDEF IOCHECK} +{$ENDIF} + LastDosExitCode:=0; + { Fork the process } + pid:=sys_Fork; + if pid=0 then + begin + {The child does the actual execution, and then exits} + tmp := Path+' '+ComLine; + p:=StringToPPChar(tmp,count); + if (p<>nil) and (p^<>nil) then + begin + sys_Execve(p^,p,Envp); + end; + {If the execve fails, we return an exitvalue of 127, to let it be known} + sys_exit(127); + end + else + if pid=-1 then {Fork failed - parent only} + begin + DosError:=8; + exit + end; +{We're in the parent, let's wait.} + LastDosExitCode:=InternalWaitProcess(pid); // WaitPid and result-convert + if (LastDosExitCode>=0) and (LastDosExitCode<>127) then DosError:=0 else + DosError:=8; // perhaps one time give an better error +End; + +Function DosExitCode: Word; +Begin + DosExitCode:=LastDosExitCode; +End; +{$ENDIF} + + +{****************************************************************************** + --- Disk --- +******************************************************************************} + + +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; + + +{****************************************************************************** + --- Findfirst FindNext --- +******************************************************************************} + + +Function FNMatch(const Pattern,Name:string):Boolean; +Var + LenPat,LenName : longint; + + Function DoFNMatch(i,j:longint):Boolean; + Var + Found : boolean; + Begin + Found:=true; + While Found and (i<=LenPat) Do + Begin + Case Pattern[i] of + '?' : Found:=(j<=LenName); + '*' : Begin + {find the next character in pattern, different of ? and *} + while Found and (ipattern[i]) do + inc (j); + if (j=LenName); + end + else + j:=LenName;{we can stop} + end; + else {not a wildcard character in pattern} + Found:=(j<=LenName) and (pattern[i]=name[j]); + end; + inc(i); + inc(j); + end; + DoFnMatch:=Found and (j>LenName); + end; + +Begin {start FNMatch} + LenPat:=Length(Pattern); + LenName:=Length(Name); + FNMatch:=DoFNMatch(1,1); +End; + + +Procedure FindClose(Var f: SearchRec); +{ + Closes dirptr if it is open +} +Begin + { could already have been closed } + if assigned(f.dirptr) then + sys_closedir(pdir(f.dirptr)); + f.dirptr := nil; +End; + + +{ Returns a filled in searchRec structure } +{ and TRUE if the specified file in s is } +{ found. } +Function FindGetFileInfo(s:string;var f:SearchRec):boolean; +var + DT : DateTime; + st : stat; + Fmode : byte; + res: string; { overlaid variable } + Dir : DirsTr; + Name : NameStr; + Ext: ExtStr; +begin + FindGetFileInfo:=false; + res := s + #0; + if sys_stat(@res[1],st)<>0 then + exit; + if S_ISDIR(st.st_mode) then + fmode:=directory + else + { contrary to DOS - all normal files have the archive bits set } + { under POSIX. } + fmode:=archive; + if (st.st_mode and S_IWUSR)=0 then + fmode:=fmode or readonly; + If ((FMode and f.searchattr)<>0) or ((Fmode and Archive)<>0) Then + Begin + FSplit(s,Dir,Name,Ext); + if Ext <> '' then + res := Name + Ext + else + res := Name; + f.Name:=res; + f.Attr:=FMode; + f.Size:=longint(st.st_size); + UnixDateToDT(st.st_mtime, DT); + PackTime(DT,f.Time); + FindGetFileInfo:=true; + End; +end; + + +Procedure FindNext(Var f: SearchRec); +{ + re-opens dir if not already in array and calls FindWorkProc +} +Var + FName, + SName : string; + Found, + Finished : boolean; + p : PDirEnt; +Begin +{Main loop} + SName:=f.SearchSpec; + Found:=False; + Finished:=(f.dirptr=nil); + While Not Finished Do + Begin + p:=sys_readdir(pdir(f.dirptr)); + if p=nil then + begin + FName:='' + end + else + FName:=Strpas(@p^.d_name); + If FName='' Then + Finished:=True + Else + Begin + If FNMatch(SName,FName) Then + Begin + Found:=FindGetFileInfo(f.SearchDir+FName,f); + if Found then + begin + Finished:=true; + end; + End; + End; + End; +{Shutdown} + If Found Then + Begin + DosError:=0; + End + Else + Begin + FindClose(f); + { FindClose() might be called thereafter also... } + f.dirptr := nil; + DosError:=18; + End; +End; + + +Procedure FindFirst(Const Path: PathStr; Attr: Word; Var f: SearchRec); +{ + opens dir +} +var + res: string; + Dir : DirsTr; + Name : NameStr; + Ext: ExtStr; +Begin + { initialize f.dirptr because it is used } + { to see if we need to close the dir stream } + f.dirptr := nil; + if Path='' then + begin + DosError:=3; + exit; + end; + f.SearchAttr := Attr; +{Wildcards?} + if (Pos('?',Path)=0) and (Pos('*',Path)=0) then + begin + if FindGetFileInfo(Path,f) then + DosError:=0 + else + begin + if ErrNo=Sys_ENOENT then + DosError:=3 + else + DosError:=18; + end; + f.DirPtr:=nil; + end + else +{Find Entry} + begin + FSplit(Path,Dir,Name,Ext); + if Ext <> '' then + res := Name + Ext + else + res := Name; + f.SearchSpec := res; + { if dir is an empty string } + { then this indicates that } + { use the current working } + { directory. } + if dir = '' then + dir := './'; + f.SearchDir := Dir; + { add terminating null character } + Dir := Dir + #0; + f.dirptr := sys_opendir(@Dir[1]); + if not assigned(f.dirptr) then + begin + DosError := 8; + exit; + end; + FindNext(f); + end; +End; + + +{****************************************************************************** + --- File --- +******************************************************************************} + +Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr); +Var + DotPos,SlashPos,i : longint; +Begin + SlashPos:=0; + DotPos:=256; + i:=Length(Path); + While (i>0) and (SlashPos=0) Do + Begin + If (DotPos=256) and (Path[i]='.') Then + begin + DotPos:=i; + end; + If (Path[i]='/') Then + SlashPos:=i; + Dec(i); + End; + Ext:=Copy(Path,DotPos,255); + Dir:=Copy(Path,1,SlashPos); + Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1); +End; + + + +{ +function FExpand (const Path: PathStr): PathStr; +- declared in fexpand.inc +} +(* +{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home } +*) +const + LFNSupport = true; + FileNameCaseSensitive = true; + +{$I fexpand.inc} + + + +Function FSearch(const path:pathstr;dirlist:string):pathstr; +{ + Searches for a file 'path' in the list of direcories in 'dirlist'. + returns an empty string if not found. Wildcards are NOT allowed. + If dirlist is empty, it is set to '.' +} +Var + NewDir : PathStr; + p1 : Longint; + Info : Stat; + buffer : array[0..FileNameLen+1] of char; +Begin + Move(path[1], Buffer, Length(path)); + Buffer[Length(path)]:=#0; + if (length(Path)>0) and (path[1]='/') and (sys_stat(pchar(@Buffer),info)=0) then + begin + FSearch:=path; + exit; + end; +{Replace ':' with ';'} + for p1:=1to length(dirlist) do + if dirlist[p1]=':' then + dirlist[p1]:=';'; +{Check for WildCards} + If (Pos('?',Path) <> 0) or (Pos('*',Path) <> 0) Then + FSearch:='' {No wildcards allowed in these things.} + Else + Begin + Dirlist:='.;'+dirlist;{Make sure current dir is first to be searched.} + Repeat + p1:=Pos(';',DirList); + If p1=0 Then + p1:=255; + NewDir:=Copy(DirList,1,P1 - 1); + if NewDir[Length(NewDir)]<>'/' then + NewDir:=NewDir+'/'; + NewDir:=NewDir+Path; + Delete(DirList,1,p1); + Move(NewDir[1], Buffer, Length(NewDir)); + Buffer[Length(NewDir)]:=#0; + if sys_stat(pchar(@Buffer),Info)=0 then + Begin + If Pos('./',NewDir)=1 Then + Delete(NewDir,1,2); + {DOS strips off an initial .\} + End + Else + NewDir:=''; + Until (DirList='') or (Length(NewDir) > 0); + FSearch:=NewDir; + End; +End; + + + +Procedure GetFAttr(var f; var attr : word); +Var + info : stat; + LinAttr : mode_t; +Begin + DosError:=0; + if sys_stat(@textrec(f).name,info)<>0 then + begin + Attr:=0; + DosError:=3; + exit; + end + else + LinAttr:=Info.st_Mode; + if S_ISDIR(LinAttr) then + Attr:=directory + else + Attr:=archive; + if sys_Access(@textrec(f).name,W_OK)<>0 then + Attr:=Attr or readonly; + if (not S_ISDIR(LinAttr)) and (filerec(f).name[0]='.') then + Attr:=Attr or hidden; +end; + + + +Procedure getftime (var f; var time : longint); +Var + Info: stat; + DT: DateTime; +Begin + doserror:=0; + if sys_fstat(filerec(f).handle,info)<>0 then + begin + Time:=0; + doserror:=3; + exit + end + else + UnixDateToDT(Info.st_mtime,DT); + PackTime(DT,Time); +End; + + + +{****************************************************************************** + --- Environment --- +******************************************************************************} + +Function EnvCount: Longint; +var + envcnt : longint; + p : ppchar; +Begin + envcnt:=0; + p:=envp; {defined in syslinux} + while (p^<>nil) do + begin + inc(envcnt); + inc(p); + end; + EnvCount := envcnt +End; + + + +Function EnvStr(Index: Integer): String; +Var + i : longint; + p : ppchar; +Begin + p:=envp; {defined in syslinux} + i:=1; + envstr:=''; + if (index < 1) or (index > EnvCount) then + exit; + while (inil) do + begin + inc(i); + inc(p); + end; + if p<>nil then + envstr:=strpas(p^) +End; + + +Function GetEnv(EnvVar:string):string; +{ + Searches the environment for a string with name p and + returns a pchar to it's value. + A pchar is used to accomodate for strings of length > 255 +} +var + ep : ppchar; + found : boolean; + p1 : pchar; +Begin + EnvVar:=EnvVar+'='; {Else HOST will also find HOSTNAME, etc} + ep:=envp; + found:=false; + if ep<>nil then + begin + while (not found) and (ep^<>nil) do + begin + if strlcomp(@EnvVar[1],(ep^),length(EnvVar))=0 then + found:=true + else + inc(ep); + end; + end; + if found then + p1:=ep^+length(EnvVar) + else + p1:=nil; + if p1 = nil then + GetEnv := '' + else + GetEnv := StrPas(p1); +end; + + + +{****************************************************************************** + --- Do Nothing Procedures/Functions --- +******************************************************************************} + +Procedure Intr (intno: byte; var regs: registers); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure msdos(var regs : registers); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure getintvec(intno : byte;var vector : pointer); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure setintvec(intno : byte;vector : pointer); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure SwapVectors; +Begin + {! No POSIX equivalent !} +End; + + + +Procedure keep(exitcode : word); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure setftime(var f; time : longint); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure setfattr (var f;attr : word); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure GetCBreak(Var BreakValue: Boolean); +Begin +{! No POSIX equivalent !} + breakvalue:=true +End; + + + +Procedure SetCBreak(BreakValue: Boolean); +Begin + {! No POSIX equivalent !} +End; + + + +Procedure GetVerify(Var Verify: Boolean); +Begin + {! No POSIX equivalent !} + Verify:=true; +End; + + + +Procedure SetVerify(Verify: Boolean); +Begin + {! No POSIX equivalent !} +End; + +{ Include timezone routines } +{$i timezone.inc} + +{****************************************************************************** + --- Initialization --- +******************************************************************************} + +Initialization + InitLocalTime; + +finalization + DoneLocalTime; end. +{ + $Log$ + Revision 1.4 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.14 2001/12/09 03:31:35 carl + * Exec() fixed (was full of bugs) : No DosError=2 report fixed, status code error fixed. + + MAX_DRIVES constant added + + Revision 1.1.2.13 2001/12/03 03:12:28 carl + * update for new posix prototype (caused problem with other OS) + readdir / closedir + + Revision 1.1.2.12 2001/09/28 01:11:14 carl + * bugfix of pchar move in FSearch() (would give wrong results) + + Revision 1.1.2.11 2001/08/21 10:48:46 carl + + add goto on + + Revision 1.1.2.10 2001/08/15 01:04:38 carl + * instead include posix unit + * corrected bug in DateNum type (should be time_t) + + Revision 1.1.2.9 2001/08/13 09:37:17 carl + * changed prototype of sys_readdir + + Revision 1.1.2.8 2001/08/12 15:12:30 carl + + added timezone information + * bugfix of overflow in conversion of epoch to local + * bugfix of index verification in getenv + + Revision 1.1.2.7 2001/08/08 01:58:18 carl + * bugfix of problem with FindFirst() / FindNext() + + Revision 1.1.2.5 2001/08/04 05:24:21 carl + + implemented FindFirst / FindNext (untested) + + Exec() + + split + + Timezone support reinstated + + Revision 1.1.2.4 2001/07/08 04:46:01 carl + * waitpid is now portable + + fnmatch() + + Revision 1.1.2.3 2001/07/07 15:42:29 carl + * compiler error corrections + + Revision 1.1.2.2 2001/07/07 03:49:53 carl + + more POSIX compliance stuff + + Revision 1.1.2.1 2001/07/06 11:21:49 carl + + add files for POSIX - - - - - +} diff --git a/rtl/beos/errno.inc b/rtl/beos/errno.inc new file mode 100644 index 0000000000..b53472eb8a --- /dev/null +++ b/rtl/beos/errno.inc @@ -0,0 +1,219 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team. + + BeOS POSIX compliant error codes + + 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 +{----- Error baselines ---------------------------------------} + + B_GENERAL_ERROR_BASE = -2147483647-1; + B_OS_ERROR_BASE = B_GENERAL_ERROR_BASE + $1000; + B_APP_ERROR_BASE = B_GENERAL_ERROR_BASE + $2000; + B_INTERFACE_ERROR_BASE = B_GENERAL_ERROR_BASE + $3000; + B_MEDIA_ERROR_BASE = B_GENERAL_ERROR_BASE + $4000; {* - $41ff *} + B_TRANSLATION_ERROR_BASE = B_GENERAL_ERROR_BASE + $4800; {* - $48ff *} + B_MIDI_ERROR_BASE = B_GENERAL_ERROR_BASE + $5000; + B_STORAGE_ERROR_BASE = B_GENERAL_ERROR_BASE + $6000; + B_POSIX_ERROR_BASE = B_GENERAL_ERROR_BASE + $7000; + B_MAIL_ERROR_BASE = B_GENERAL_ERROR_BASE + $8000; + B_PRINT_ERROR_BASE = B_GENERAL_ERROR_BASE + $9000; + B_DEVICE_ERROR_BASE = B_GENERAL_ERROR_BASE + $a000; + +{--- Developer-defined errors start at (B_ERRORS_END+1)----} + + B_ERRORS_END = (B_GENERAL_ERROR_BASE + $ffff); + +type +{----- General Errors ----------------------------------------} +tgeneralerrors= ( + B_NO_MEMORY := B_GENERAL_ERROR_BASE, + B_IO_ERROR, + B_PERMISSION_DENIED, + B_BAD_INDEX, + B_BAD_TYPE, + B_BAD_VALUE, + B_MISMATCHED_VALUES, + B_NAME_NOT_FOUND, + B_NAME_IN_USE, + B_TIMED_OUT, + B_INTERRUPTED, + B_WOULD_BLOCK, + B_CANCELED, + B_NO_INIT, + B_BUSY, + B_NOT_ALLOWED, + + B_ERROR := -1, + B_OK := 0, + B_NO_ERROR := 0 +); + +{----- Kernel Kit Errors -------------------------------------} +tkernelerror = ( + B_BAD_SEM_ID := B_OS_ERROR_BASE, + B_NO_MORE_SEMS, + + B_BAD_THREAD_ID := B_OS_ERROR_BASE + $100, + B_NO_MORE_THREADS, + B_BAD_THREAD_STATE, + B_BAD_TEAM_ID, + B_NO_MORE_TEAMS, + + B_BAD_PORT_ID := B_OS_ERROR_BASE + $200, + B_NO_MORE_PORTS, + + B_BAD_IMAGE_ID := B_OS_ERROR_BASE + $300, + B_BAD_ADDRESS, + B_NOT_AN_EXECUTABLE, + B_MISSING_LIBRARY, + B_MISSING_SYMBOL, + + B_DEBUGGER_ALREADY_INSTALLED := B_OS_ERROR_BASE + $400 +); + + +{----- Application Kit Errors --------------------------------} +tapperrors = +( + B_BAD_REPLY := B_APP_ERROR_BASE, + B_DUPLICATE_REPLY, + B_MESSAGE_TO_SELF, + B_BAD_HANDLER, + B_ALREADY_RUNNING, + B_LAUNCH_FAILED, + B_AMBIGUOUS_APP_LAUNCH, + B_UNKNOWN_MIME_TYPE, + B_BAD_SCRIPT_SYNTAX, + B_LAUNCH_FAILED_NO_RESOLVE_LINK, + B_LAUNCH_FAILED_EXECUTABLE, + B_LAUNCH_FAILED_APP_NOT_FOUND, + B_LAUNCH_FAILED_APP_IN_TRASH, + B_LAUNCH_FAILED_NO_PREFERRED_APP, + B_LAUNCH_FAILED_FILES_APP_NOT_FOUND +); + + +{----- Storage Kit/File System Errors ------------------------} +tfserrors= ( + B_FILE_ERROR :=B_STORAGE_ERROR_BASE, + B_FILE_NOT_FOUND, { discouraged; use B_ENTRY_NOT_FOUND in new code } + B_FILE_EXISTS, + B_ENTRY_NOT_FOUND, + B_NAME_TOO_LONG, + B_NOT_A_DIRECTORY, + B_DIRECTORY_NOT_EMPTY, + B_DEVICE_FULL, + B_READ_ONLY_DEVICE, + B_IS_A_DIRECTORY, + B_NO_MORE_FDS, + B_CROSS_DEVICE_LINK, + B_LINK_LIMIT, + B_BUSTED_PIPE, + B_UNSUPPORTED, + B_PARTITION_TOO_SMALL +); + + +const + +{***********************************************************************} +{ POSIX ERROR DEFINITIONS } +{***********************************************************************} + + { The following constants are system dependent but must all exist } + Sys_E2BIG = (B_POSIX_ERROR_BASE + 1); + Sys_EACCES = ord(B_PERMISSION_DENIED); + Sys_EAGAIN = ord(B_WOULD_BLOCK); + Sys_EBADF = ord(B_FILE_ERROR); + Sys_EBUSY = ord(B_BUSY); + Sys_ECHILD = (B_POSIX_ERROR_BASE + 2); + Sys_EDEADLK = (B_POSIX_ERROR_BASE + 3); + Sys_EDOM = (B_POSIX_ERROR_BASE + 16); + Sys_EEXIST = ord(B_FILE_EXISTS); + Sys_EFAULT = ord(B_BAD_ADDRESS); + Sys_EFBIG = (B_POSIX_ERROR_BASE + 4); + Sys_EINTR = ord(B_INTERRUPTED); + Sys_EINVAL = ord(B_BAD_VALUE); + Sys_EIO = ord(B_IO_ERROR); + Sys_EISDIR = ord(B_IS_A_DIRECTORY); + Sys_EMFILE = ord(B_NO_MORE_FDS); + Sys_EMLINK = (B_POSIX_ERROR_BASE + 5); + Sys_ENAMETOOLONG= ord(B_NAME_TOO_LONG); + Sys_ENFILE = (B_POSIX_ERROR_BASE + 6); + Sys_ENODEV = (B_POSIX_ERROR_BASE + 7); + Sys_ENOENT = ord(B_ENTRY_NOT_FOUND); + Sys_ENOEXEC = ord(B_NOT_AN_EXECUTABLE); + Sys_ENOLCK = (B_POSIX_ERROR_BASE + 8); + Sys_ENOMEM = ord(B_NO_MEMORY); + Sys_ENOSPC = ord(B_DEVICE_FULL); + Sys_ENOSYS = (B_POSIX_ERROR_BASE + 9); + Sys_ENOTDIR = ord(B_NOT_A_DIRECTORY); + Sys_ENOTEMPTY = ord(B_DIRECTORY_NOT_EMPTY); + Sys_ENOTTY = (B_POSIX_ERROR_BASE + 10); + Sys_ENXIO = (B_POSIX_ERROR_BASE + 11); + Sys_EPERM = ord(B_NOT_ALLOWED); + Sys_EPIPE = ord(B_BUSTED_PIPE); + Sys_ERANGE = (B_POSIX_ERROR_BASE + 17); + Sys_EROFS = ord(B_READ_ONLY_DEVICE); + Sys_ESPIPE = (B_POSIX_ERROR_BASE + 12); + Sys_ESRCH = (B_POSIX_ERROR_BASE + 13); + Sys_ETIMEDOUT = ord(B_TIMED_OUT); + Sys_EXDEV = ord(B_CROSS_DEVICE_LINK); + + {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 } + +{***********************************************************************} +{ NON POSIX ERROR DEFINITIONS } +{***********************************************************************} + sys_EFPOS = (B_POSIX_ERROR_BASE + 14); + sys_ESIGPARM = (B_POSIX_ERROR_BASE + 15); + sys_EPROTOTYPE = (B_POSIX_ERROR_BASE + 18); + sys_EPROTONOSUPPORT = (B_POSIX_ERROR_BASE + 19); + sys_EPFNOSUPPORT = (B_POSIX_ERROR_BASE + 20); + sys_EAFNOSUPPORT = (B_POSIX_ERROR_BASE + 21); + sys_EADDRINUSE = (B_POSIX_ERROR_BASE + 22); + sys_EADDRNOTAVAIL = (B_POSIX_ERROR_BASE + 23); + sys_ENETDOWN = (B_POSIX_ERROR_BASE + 24); + sys_ENETUNREACH = (B_POSIX_ERROR_BASE + 25); + sys_ENETRESET = (B_POSIX_ERROR_BASE + 26); + sys_ECONNABORTED = (B_POSIX_ERROR_BASE + 27); + sys_ECONNRESET = (B_POSIX_ERROR_BASE + 28); + + sys_EISCONN = (B_POSIX_ERROR_BASE + 29); + sys_ENOTCONN = (B_POSIX_ERROR_BASE + 30); + sys_ESHUTDOWN = (B_POSIX_ERROR_BASE + 31); + sys_ECONNREFUSED = (B_POSIX_ERROR_BASE + 32); + sys_EHOSTUNREACH = (B_POSIX_ERROR_BASE + 33); + sys_ENOPROTOOPT = (B_POSIX_ERROR_BASE + 34); + sys_ENOBUFS = (B_POSIX_ERROR_BASE + 35); + sys_EINPROGRESS = (B_POSIX_ERROR_BASE + 36); + sys_EALREADY = (B_POSIX_ERROR_BASE + 37); + + sys_EWOULDBLOCK = ord(B_WOULD_BLOCK); {* BSD compatibility *} + sys_ELOOP = ord(B_LINK_LIMIT); + + +{ + $Log$ + Revision 1.2 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.4 2001/07/13 03:15:12 carl + * updated log and header of file + +} \ No newline at end of file diff --git a/rtl/beos/osposix.inc b/rtl/beos/osposix.inc new file mode 100644 index 0000000000..b97dd5d123 --- /dev/null +++ b/rtl/beos/osposix.inc @@ -0,0 +1,505 @@ +{ + $Id$ + Copyright (c) 2001 by Carl Eric Codere + + Implements POSIX 1003.1 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. + + **************************************************************************** +} + + +const + syscall_nr_exit = $3F; + syscall_nr_chdir = $57; + syscall_nr_mkdir = $1E; + syscall_nr_unlink = $27; + syscall_nr_rmdir = $60; + syscall_nr_close = $01; + syscall_nr_read = $02; + syscall_nr_write = $03; + syscall_nr_stat = $30; + syscall_nr_fstat = $30; + syscall_nr_rename = $26; + syscall_nr_access = $58; + syscall_nr_opendir= $0C; + syscall_nr_closedir= $0F; + syscall_nr_sigaction= $70; + syscall_nr_time = $07; + syscall_nr_open = $00; + syscall_nr_readdir = $1C; + syscall_nr_lseek = $05; + syscall_nr_ftruncate = $4b; + + S_IFDIR =$004000; { Directory. } + S_IFCHR =$002000; { Character device. } + S_IFBLK =$006000; { Block device. } + S_IFREG =$008000; { Regular file. } + S_IFIFO =$001000; { FIFO. } + S_IFLNK =$00A000; { Symbolic link. } + +type + { _kwstat_ kernel call structure } + pwstat = ^twstat; + twstat = packed record +{00} filler : array[1..3] of longint; +{12} newmode : mode_t; { chmod mode_t parameter } +{16} unknown1 : longint; +{20} newuser : uid_t; { chown uid_t parameter } +{24} newgroup : gid_t; { chown gid_t parameter } +{28} trunc_offset : off_t; { ftrucnate parameter } +{36} unknown2 : array[1..2] of longint; +{44} utime_param: int64; +{52} unknown3 : array[1..2] of longint; + end; + + + + + + + { These routines are currently not required for BeOS } + function sys_fork : pid_t; + begin + end; + + function sys_execve(const path : pchar; const argv : ppchar; const envp: ppchar): cint; + begin + end; + + function sys_waitpid(pid : pid_t; var stat_loc : cint; options: cint): pid_t; + begin + end; + + + function sys_uname(var name: utsname): cint; + begin + FillChar(name, sizeof(utsname), #0); + name.machine := 'BePC'#0; + + end; + + + + + function S_ISDIR(m : mode_t): boolean; + begin + if (m and S_IFDIR)= S_IFDIR then + S_ISDIR := true + else + S_ISDIR := false; + end; + + function S_ISCHR(m : mode_t): boolean; + begin + if (m and S_IFCHR) = S_IFCHR then + S_ISCHR := true + else + S_ISCHR := false; + end; + + function S_ISBLK(m : mode_t): boolean; + begin + if (m and S_IFBLK) = S_IFBLK then + S_ISBLK := true + else + S_ISBLK := false; + end; + + function S_ISREG(m : mode_t): boolean; + begin + if (m and S_IFREG) = S_IFREG then + S_ISREG := true + else + S_ISREG := false; + end; + + function S_ISFIFO(m : mode_t): boolean; + begin + if (m and S_IFIFO) = S_IFIFO then + S_ISFIFO := true + else + S_ISFIFO := false; + end; + + function wifexited(status : cint): cint; + begin + wifexited := byte(boolean((status and not $FF) = 0)); + end; + + function wexitstatus(status : cint): cint; + begin + wexitstatus := status and $FF; + end; + + function wstopsig(status : cint): cint; + begin + wstopsig:=(status shr 16) and $FF; + end; + + function wifsignaled(status : cint): cint; + begin + if (((status) shr 8) and $ff) <> 0 then + wifsignaled := 1 + else + wifsignaled := 0; + end; + + + {$i syscall.inc} + + procedure sys_exit(status : cint); external name 'sys_exit'; +(* + procedure sys_exit(status : cint); + var + args: SysCallArgs; + begin + args.param[1] := status; + SysCall(syscall_nr_exit,args); + end; +*) + + function sys_close(fd : cint): cint; + var + args : SysCallArgs; + begin + args.param[1] := fd; + sys_close:=SysCall(syscall_nr_close,args); + end; + + + function sys_time(var tloc:time_t): time_t; + var + args : SysCallArgs; + begin + { don't treat errno, since there is never any } + tloc := Do_Syscall(syscall_nr_time,args); + sys_time := tloc; + end; + + + + function sys_sigaction(sig: cint; var act : sigactionrec; var oact : sigactionrec): cint; + var + args : SysCallArgs; + begin + args.param[1] := sig; + args.param[2] := cint(@act); + args.param[3] := cint(@oact); + sys_sigaction := SysCall(syscall_nr_sigaction, args); + end; + + + function sys_closedir(dirp : pdir): cint; + var + args : SysCallArgs; + begin + if assigned(dirp) then + begin + args.param[1] := dirp^.fd; + sys_closedir := SysCall(syscall_nr_closedir,args); + Dispose(dirp); + dirp := nil; + exit; + end; + Errno := Sys_EBADF; + sys_closedir := -1; + end; + + + function sys_opendir(const dirname : pchar): pdir; + var + args : SysCallArgs; + dirp: pdir; + fd : cint; + begin + New(dirp); + { just in case } + FillChar(dirp^,sizeof(dir),#0); + if assigned(dirp) then + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(dirname); + args.param[3] := 0; + fd:=SysCall(syscall_nr_opendir,args); + if fd = -1 then + begin + Dispose(dirp); + sys_opendir := nil; + exit; + end; + dirp^.fd := fd; + sys_opendir := dirp; + exit; + end; + Errno := Sys_EMFILE; + sys_opendir := nil; + end; + + + function sys_access(const pathname : pchar; amode : cint): cint; + var + args : SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(pathname); + args.param[3] := amode; + sys_access := SysCall(syscall_nr_access,args); + end; + + + function sys_rename(const old : pchar; const newpath: pchar): cint; + var + args: SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(old); + args.param[3] := $FFFFFFFF; + args.param[4] := cint(newpath); + sys_rename := SysCall(syscall_nr_rename,args); + end; + + + function sys_rmdir(const path : pchar): cint; + var + args: SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(path); + sys_rmdir := SysCall(syscall_nr_rmdir,args); + end; + + + function sys_unlink(const path: pchar): cint; + var + args :SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(path); + sys_unlink := SysCall(syscall_nr_unlink,args); + end; + + + + function sys_mkdir(const path : pchar; mode: mode_t):cint; + var + args :SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(path); + args.param[3] := cint(mode); + sys_mkdir := SysCall(syscall_nr_mkdir,args); + end; + + + function sys_fstat(fd : cint; var sb : stat): cint; + var + args : SysCallArgs; + begin + args.param[1] := fd; + args.param[2] := $00; + args.param[3] := cint(@sb); + args.param[4] := $00000001; + sys_fstat := SysCall(syscall_nr_fstat, args); + end; + + + function sys_stat(const path: pchar; var buf : stat): cint; + var + args : SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(path); + args.param[3] := cint(@buf); + args.param[4] := $01000000; + sys_stat := SysCall(syscall_nr_stat, args); + end; + + + function sys_read(fd: cint; buf:pchar; nbytes : size_t): ssize_t; + var + args : SysCallArgs; + funcresult: ssize_t; + errorcode : cint; + begin + args.param[1] := fd; + args.param[2] := cint(buf); + args.param[3] := cint(nbytes); + args.param[4] := cint(@errorcode); + funcresult := ssize_t(Do_SysCall(syscall_nr_read,args)); + if funcresult >= 0 then + begin + sys_read := funcresult; + errno := 0; + end + else + begin + sys_read := -1; + errno := errorcode; + end; + end; + + + function sys_write(fd: cint;const buf:pchar; nbytes : size_t): ssize_t; + var + args : SysCallArgs; + funcresult : ssize_t; + errorcode : cint; + begin + args.param[1] := fd; + args.param[2] := cint(buf); + args.param[3] := cint(nbytes); + args.param[4] := cint(@errorcode); + funcresult := Do_SysCall(syscall_nr_write,args); + if funcresult >= 0 then + begin + sys_write := funcresult; + errno := 0; + end + else + begin + sys_write := -1; + errno := errorcode; + end; + end; + + + + function sys_chdir(const path : pchar): cint; + var + args: SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(path); + sys_chdir := SysCall(syscall_nr_chdir, args); + end; + + + function sys_open(const path: pchar; flags : cint; mode: mode_t):cint; + var + args: SysCallArgs; + begin + args.param[1] := $FFFFFFFF; + args.param[2] := cint(path); + args.param[3] := flags; + args.param[4] := cint(mode); + args.param[5] := 0; { close on execute flag } + sys_open:= SysCall(syscall_nr_open, args); + end; + + + function sys_readdir(dirp : pdir) : pdirent; + var + args : SysCallArgs; + funcresult : cint; + begin + args.param[1] := dirp^.fd; + args.param[2] := cint(@(dirp^.ent)); + args.param[3] := $0000011C; + args.param[4] := $00000001; + { the error will be processed here } + funcresult := Do_SysCall(syscall_nr_readdir, args); + if funcresult <> 1 then + begin + if funcresult <> 0 then + errno := funcresult; + sys_readdir := nil; + exit; + end; + errno := 0; + sys_readdir := @dirp^.ent + end; + + + function sys_lseek(fd : cint; offset : off_t; whence : cint): off_t; + var + args: SysCallArgs; + + begin + args.param[1] := fd; + args.param[2] := cint(offset and $FFFFFFFF); + args.param[3] := cint((offset shr 32) and $FFFFFFFF); + args.param[4] := whence; + { we currently only support seeks upto 32-bit in length } + sys_lseek := off_t(SysCall(syscall_nr_lseek,args)); + end; + + + function sys_ftruncate(fd : cint; flength : off_t): cint; + var + args: SysCallArgs; + wstat : pwstat; + begin + New(wstat); + FillChar(wstat^,sizeof(wstat),0); + wstat^.trunc_offset := flength; + args.param[1] := fd; + args.param[2] := $00000000; + args.param[3] := cint(wstat); + args.param[4] := $00000008; + args.param[5] := $00000001; + sys_ftruncate:=SysCall(syscall_nr_ftruncate, args); + Dispose(wstat); + end; + +{ + + $Log$ + Revision 1.2 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.13 2001/12/17 02:14:28 carl + + wifsignaled() added + + Revision 1.1.2.12 2001/12/03 03:11:05 carl + * update for new posix prototype (caused problem with other OS) + + Revision 1.1.2.11 2001/08/22 02:38:12 carl + - sys_exit now written in assembler + + Revision 1.1.2.10 2001/08/15 01:01:51 carl + - moved SysCall to syscall.inc + + Revision 1.1.2.9 2001/08/13 09:40:43 carl + * bugfix of problems of changing signs with errno! + * changed prototype of sys_readdir() to conform to POSIX + + Revision 1.1.2.8 2001/08/13 05:57:53 carl + * corrected written/read value returned for sys_read() and sys_write(). errno now correctly set. + + Revision 1.1.2.7 2001/08/12 15:15:21 carl + * bugfix of call to sys_time (would always return weird results) + + Revision 1.1.2.6 2001/08/09 01:12:46 carl + * fstat() call now correct + + ftruncate() support + + Revision 1.1.2.5 2001/08/08 01:55:43 carl + * bugfix of sys_opendir() + * bugfix of sys_readdir() should be var parameter not const :( + + Revision 1.1.2.4 2001/07/14 04:20:33 carl + + sys_lseek() + + sys_open() + * bugfix of sys_write() + * bugfix of sys_readdir() + + started testing + + Revision 1.1.2.3 2001/07/13 03:14:55 carl + + more syscalls (not all verified) working + +} diff --git a/rtl/beos/osposixh.inc b/rtl/beos/osposixh.inc new file mode 100644 index 0000000000..3ec0ba776e --- /dev/null +++ b/rtl/beos/osposixh.inc @@ -0,0 +1,211 @@ +{ + $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 used in POSIX for BeOS + + 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 = longint; { minimum range is : 32-bit } + cuint = cardinal; { minimum range is : 32-bit } + + + dev_t = cint; { used for device numbers } + gid_t = cuint; { used for group IDs } + ino_t = int64; { used for file serial numbers } + mode_t = cuint; { used for file attributes } + nlink_t = cint; { used for link counts } + off_t = int64; { used for file sizes } + pid_t = cint; { used as process identifier } + size_t = cint; { as definied in the C standard } + ssize_t = cint; { used by function for returning number of bytes } + uid_t = cuint; { used for user ID type } + time_t = cint; { used for returning the time } + sigset_t = cuint; { used for additional signal } + +{***********************************************************************} +{ POSIX STRUCTURES } +{***********************************************************************} +CONST + _UTSNAME_LENGTH = 32; + _UTSNAME_NODENAME_LENGTH = _UTSNAME_LENGTH; + +TYPE + { system information services } + utsname = packed record { don't forget to verify the alignment } + { Name of this implementation of the operating systems (POSIX) } + sysname : array[0.._UTSNAME_LENGTH+1] of char; + { Name of this node (POSIX) } + nodename : array[0.._UTSNAME_NODENAME_LENGTH+1] of char; + { Current release level of this implementation (POSIX) } + release : array[0.._UTSNAME_LENGTH+1] of char; + { Current version level of this release (POSX) } + version : array[0.._UTSNAME_LENGTH+1] of char; + { Name of the hardware type on which the system is running (POSIX) } + machine : array[0.._UTSNAME_LENGTH+1] of char; + end; + + { file characteristics services } + stat = packed record { verify the alignment of the members } + st_dev : dev_t; { Device containing the file (POSIX) } + st_ino : ino_t; { File serial number (POSIX) } + st_mode: mode_t; { File mode (POSIX) } + st_nlink: nlink_t; { Link count (POSIX) } + st_uid: uid_t; { User ID of the file's owner. (POSIX)} + st_gid: gid_t; { Group ID of the file's group.(POSIX)} + st_size : off_t; { Size of file, in bytes. (POSIX)} + st_rdev : dev_t; { Device type (not used). } + st_blksize: cardinal;{ Preferred block size for I/O. } + st_atime: time_t; { Time of last access (POSIX) } + st_mtime: time_t; { Time of last modification (POSIX) } + st_ctime: time_t; { Time of last status change (POSIX) } + st_crtime: time_t; { Time of creation } + end; + + { directory services } + pdirent = ^dirent; + dirent = packed record { directory entry record - verify alignment } + d_dev: dev_t; + d_pdev: dev_t; + d_fileno: ino_t; + d_pino: ino_t; + d_reclen:word; + d_name:array[0..255] of char; { Filename in DIRENT (POSIX) } + end; + + pdir = ^dir; + dir = packed record + fd : cint; { file descriptor } + ent : dirent; { directory entry } + end; + + sighandler_t = procedure (signo: cint); cdecl; + + { signal services } + sigactionrec = packed record + sa_handler : sighandler_t; { pointer to a function (POSIX.1) } + sa_mask : sigset_t; { additional signal masks (POSIX.1) } + sa_flags : cint; { special flags for signals (POSIX.1) } + sa_userdata : pointer; + end; + +{***********************************************************************} +{ POSIX CONSTANT ROUTINE DEFINITIONS } +{***********************************************************************} +CONST + { access routine - these maybe OR'ed together } + F_OK = 0; { test for existence of file } + R_OK = 4; { test for read permission on file } + W_OK = 2; { test for write permission on file } + X_OK = 1; { test for execute or search permission } + { seek routine } + SEEK_SET = 0; { seek from beginning of file } + SEEK_CUR = 1; { seek from current position } + SEEK_END = 2; { seek from end of file } + { open routine } + { File access modes for `open' and `fcntl'. } + O_RDONLY = 0; { Open read-only. } + O_WRONLY = 1; { Open write-only. } + O_RDWR = 2; { Open read/write. } + { Bits OR'd into the second argument to open. } + O_CREAT =$0200; { Create file if it doesn't exist. } + O_EXCL =$0100; { Fail if file already exists. } + O_TRUNC =$0400; { Truncate file to zero length. } + O_NOCTTY =$1000; { Don't assign a controlling terminal. } + { File status flags for `open' and `fcntl'. } + O_APPEND =$0800; { Writes append to the file. } + O_NONBLOCK =$0080; { Non-blocking I/O. } + + { mode_t possible values } + S_IRUSR = $0100; { Read permission for owner } + S_IWUSR = $0080; { Write permission for owner } + S_IXUSR = $0040; { Exec permission for owner } + S_IRGRP = S_IRUSR shr 3; { Read permission for group } + S_IWGRP = S_IWUSR shr 3; { Write permission for group } + S_IXGRP = S_IWUSR shr 3; { Exec permission for group } + S_IROTH = S_IRGRP shr 3; { Read permission for world } + S_IWOTH = S_IWGRP shr 3; { Write permission for world } + S_IXOTH = S_IXGRP shr 3; { Exec permission for world } + + { Used for waitpid } + WNOHANG = 1; { don't block waiting } + WUNTRACED = 2; { report status of stopped children } + + + {************************ signals *****************************} + { more can be provided. Herein are only included the required } + { values. } + {**************************************************************} + SIGABRT = 6; { abnormal termination } + SIGALRM = 14; { alarm clock (used with alarm() } + SIGFPE = 8; { illegal arithmetic operation } + SIGHUP = 1; { Hangup } + SIGILL = 4; { Illegal instruction } + SIGINT = 2; { Interactive attention signal } + SIGKILL = 9; { Kill, cannot be caught } + SIGPIPE = 7; { Broken pipe signal } + SIGQUIT = 3; { Interactive termination signal } + SIGSEGV = 11; { Detection of invalid memory reference } + SIGTERM = 15; { Termination request } + SIGUSR1 = 18; { Application defined signal 1 } + SIGUSR2 = 19; { Application defined signal 2 } + SIGCHLD = 5; { Child process terminated / stopped } + SIGCONT = 12; { Continue if stopped } + SIGSTOP = 10; { Stop signal. cannot be cuaght } + SIGSTP = 13; { Interactive stop signal } + SIGTTIN = 16; { Background read from TTY } + SIGTTOU = 17; { Background write to TTY } + SIGBUS = SIGSEGV; { Access to undefined memory } + + + { POSIX limits } + ARG_MAX = 128*1024; { Maximum number of arguments } + NAME_MAX = 256; { Maximum number of bytes in a filename } + PATH_MAX = 1024; { Maximum number of bytes in a pathname } + + +{ + $Log$ + Revision 1.2 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.7 2001/07/21 19:17:11 carl + + added MAX_ARGS define + + Revision 1.1.2.6 2001/07/08 04:45:28 carl + + updated type definitions + + Revision 1.1.2.5 2001/07/07 15:41:42 carl + + added missing definitions + + Revision 1.1.2.4 2001/07/07 04:38:54 carl + + added missing S_X constants + + Revision 1.1.2.3 2001/07/06 12:07:05 carl + * correct definitions + + Revision 1.1.2.2 2001/07/06 11:59:35 carl + + added missing constants + (still missing mode_t bit definitions) + + Revision 1.1.2.1 2001/07/06 02:59:56 carl + + first revision for BeOS + +} \ No newline at end of file diff --git a/rtl/beos/posix.pp b/rtl/beos/posix.pp new file mode 100644 index 0000000000..2ed5ecbfab --- /dev/null +++ b/rtl/beos/posix.pp @@ -0,0 +1,94 @@ +{ + $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(dirp : pdir) : pdirent; + function sys_closedir(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 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.2 2001/12/17 02:13:52 carl + + wifsignaled() added + + Revision 1.1.2.1 2001/12/05 02:49:14 carl + + posix unit is now OS specific but with same interface + + +} \ No newline at end of file diff --git a/rtl/beos/syscall.inc b/rtl/beos/syscall.inc new file mode 100644 index 0000000000..9b8f353f89 --- /dev/null +++ b/rtl/beos/syscall.inc @@ -0,0 +1,99 @@ +{ + $Id$ + Copyright (c) 1998-2000 by Florian Klaempfl + + This include implements the actual system call for the + intel BeOS 80x86 platform. + + 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. + + **************************************************************************** +} + +type + SysCallArgs = packed record + param: array[1..8] of cint; + End; + + +procedure sys_call; external name 'sys_call'; + + + +function Do_SysCall( callnr:longint;var regs : SysCallArgs ): longint;assembler; +{ + This routine sets up the parameters on the stack, all the parameters + are in reverse order on the stack (like C parameter passing). +} +asm + { load the parameters... } + movl regs,%eax + movl 24(%eax),%ebx + pushl %ebx + movl 20(%eax),%ebx + pushl %ebx + movl 16(%eax),%ebx + pushl %ebx + movl 12(%eax),%ebx + pushl %ebx + movl 8(%eax),%ebx + pushl %ebx + movl 4(%eax),%ebx + pushl %ebx + movl 0(%eax),%ebx + pushl %ebx + { set the call number } + movl callnr,%eax + call sys_call + addl $28,%esp +end; + + +Function SysCall( callnr:longint;var args : SysCallArgs ):longint; +{ + This function serves as an interface to do_SysCall. + If the SysCall returned a negative number, it returns -1, and puts the + SysCall result in errno. Otherwise, it returns the SysCall return value +} +var + funcresult : longint; +begin + funcresult:=do_SysCall(callnr,args); + if funcresult<0 then + begin + ErrNo:=funcresult; + SysCall:=-1; + end + else + begin + SysCall:=funcresult; + errno:=0 + end; +end; + + +{ + $Log$ + Revision 1.1 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.1.2.2 2001/08/15 01:08:25 carl + * added SysCall(0 routine here as well as argument declarations + + Revision 1.1.2.1 2001/07/13 03:16:03 carl + + static kernel call interface (CPU specific) + +} \ No newline at end of file diff --git a/rtl/beos/system.pp b/rtl/beos/system.pp index cfedb55d9f..e0db41d97d 100644 --- a/rtl/beos/system.pp +++ b/rtl/beos/system.pp @@ -50,6 +50,7 @@ var argc : longint; argv : ppchar; envp : ppchar; + errno : longint; // MvdV: yuckie UnusedHandle:longint; StdInputHandle:longint; @@ -534,7 +535,11 @@ begin end. { $Log$ - Revision 1.7 2003-01-05 20:22:24 florian + Revision 1.8 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + Revision 1.7 2003/01/05 20:22:24 florian - removed stack check, it's system independend in 1.1 Revision 1.6 2003/01/05 20:06:30 florian diff --git a/rtl/beos/timezone.inc b/rtl/beos/timezone.inc new file mode 100644 index 0000000000..94c564f307 --- /dev/null +++ b/rtl/beos/timezone.inc @@ -0,0 +1,443 @@ +{ + $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 (timerleaps[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.1 2003-01-08 22:32:28 marco + * Small fixes and quick merge with 1.0.x. At least the compiler builds now, + but it could crash hard, since there are lots of unimplemented funcs. + + 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) + +}