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

* obsolete files

Browse Source 
git-svn-id: trunk@7440 -
This commit is contained in:
peter 2007-05-24 07:13:15 +00:00
parent c83f5c8546
commit 6a51ea7eac
11 changed files with 0 additions and 3308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.gitattributes vendored
View File

@ -4370,12 +4370,8 @@ rtl/atari/system.pas svneol=native#text/plain
rtl/beos/Makefile svneol=native#text/plain
rtl/beos/Makefile.fpc svneol=native#text/plain
rtl/beos/baseunix.pp svneol=native#text/plain
rtl/beos/beos.inc svneol=native#text/plain
rtl/beos/beos.pp svneol=native#text/plain
rtl/beos/bethreads.pp svneol=native#text/plain
rtl/beos/classes.pp svneol=native#text/plain
rtl/beos/dos.pp svneol=native#text/plain
rtl/beos/dos_beos.inc svneol=native#text/plain
rtl/beos/errno.inc svneol=native#text/plain
rtl/beos/errnostr.inc svneol=native#text/plain
rtl/beos/i386/cprt0.as -text
@ -4383,13 +4379,10 @@ rtl/beos/i386/dllprt.as -text
rtl/beos/i386/dllprt.cpp -text
rtl/beos/i386/func.as -text
rtl/beos/i386/prt0.as -text
rtl/beos/objinc.inc svneol=native#text/plain
rtl/beos/osmacro.inc svneol=native#text/plain
rtl/beos/osposix.inc svneol=native#text/plain
rtl/beos/osposixh.inc svneol=native#text/plain
rtl/beos/ossysc.inc svneol=native#text/plain
rtl/beos/ostypes.inc svneol=native#text/plain
rtl/beos/posix.pp svneol=native#text/plain
rtl/beos/ptypes.inc svneol=native#text/plain
rtl/beos/settimeo.inc svneol=native#text/plain
rtl/beos/signal.inc svneol=native#text/plain
@ -4399,17 +4392,14 @@ rtl/beos/syscallh.inc svneol=native#text/plain
rtl/beos/sysconst.inc svneol=native#text/plain
rtl/beos/sysdir.inc svneol=native#text/plain
rtl/beos/sysfile.inc svneol=native#text/plain
rtl/beos/sysfiles.inc svneol=native#text/plain
rtl/beos/sysheap.inc svneol=native#text/plain
rtl/beos/sysnr.inc svneol=native#text/plain
rtl/beos/sysos.inc svneol=native#text/plain
rtl/beos/sysosh.inc svneol=native#text/plain
rtl/beos/system.pp svneol=native#text/plain
rtl/beos/sysutils.pp svneol=native#text/plain
rtl/beos/termio.pp svneol=native#text/plain
rtl/beos/termios.inc svneol=native#text/plain
rtl/beos/termiosproc.inc svneol=native#text/plain
rtl/beos/timezone.inc svneol=native#text/plain
rtl/beos/tthread.inc svneol=native#text/plain
rtl/beos/unixsock.inc svneol=native#text/plain
rtl/beos/unxconst.inc svneol=native#text/plain

543
rtl/beos/beos.inc
View File

@ -1,543 +0,0 @@
{
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);
}
{*****************************************************************}

384
rtl/beos/beos.pp
View File

@ -1,384 +0,0 @@
unit beos;
interface
type
Stat = packed record
dev:longint; {"device" that this file resides on}
ino:int64; {this file's inode #, unique per device}
mode:dword; {mode bits (rwx for user, group, etc)}
nlink:longint; {number of hard links to this file}
uid:dword; {user id of the owner of this file}
gid:dword; {group id of the owner of this file}
size:int64; {size of this file (in bytes)}
rdev:longint; {device type (not used)}
blksize:longint; {preferref block size for i/o}
atime:longint; {last access time}
mtime:longint; {last modification time}
ctime:longint; {last change time, not creation time}
crtime:longint; {creation time}
end;
PStat=^Stat;
TStat=Stat;
ComStr = String[255];
PathStr = String[255];
DirStr = String[255];
NameStr = String[255];
ExtStr = String[255];
function FStat(Path:String;Var Info:stat):Boolean;
function FStat(var f:File;Var Info:stat):Boolean;
function GetEnv(P: string): pchar;
function FExpand(Const Path: PathStr):PathStr;
function FSearch(const path:pathstr;dirlist:string):pathstr;
procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
function Dirname(Const path:pathstr):pathstr;
function Basename(Const path:pathstr;Const suf:pathstr):pathstr;
function FNMatch(const Pattern,Name:string):Boolean;
{function StringToPPChar(Var S:STring):ppchar;}
function PExists(path:string):boolean;
function FExists(path:string):boolean;
Function Shell(const Command:String):Longint;
implementation
uses strings;
{$i filerec.inc}
{$i textrec.inc}
function sys_stat (a:cardinal;path:pchar;info:pstat;n:longint):longint; cdecl; external name 'sys_stat';
function FStat(Path:String;Var Info:stat):Boolean;
{
Get all information on a file, and return it in Info.
}
var tmp:string;
var p:pchar;
begin
tmp:=path+#0;
p:=@tmp[1];
FStat:=(sys_stat($FF000000,p,@Info,0)=0);
end;
function FStat(var f:File;Var Info:stat):Boolean;
{
Get all information on a file, and return it in Info.
}
begin
FStat:=(sys_stat($FF000000,PChar(@FileRec(f).Name),@Info,0)=0);
end;
Function GetEnv(P:string):Pchar;
{
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;
Begin
p:=p+'='; {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(@p[1],(ep^),length(p))=0 then
found:=true
else
inc(ep);
end;
end;
if found then
getenv:=ep^+length(p)
else
getenv:=nil;
{ writeln ('GETENV (',P,') =',getenv);}
end;
Function StringToPPChar(Var S:String; Var nr: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
}
var
Buf : ^char;
p : ppchar;
begin
s:=s+#0;
buf:=@s[1];
nr:=0;
while(buf^<>#0) do
begin
while (buf^ in [' ',#8,#10]) do
inc(buf);
inc(nr);
while not (buf^ in [' ',#0,#8,#10]) do
inc(buf);
end;
getmem(p,nr*4);
StringToPPChar:=p;
if p=nil then
begin
{ LinuxError:=sys_enomem;}
exit;
end;
buf:=@s[1];
while (buf^<>#0) do
begin
while (buf^ in [' ',#8,#10]) do
begin
buf^:=#0;
inc(buf);
end;
p^:=buf;
inc(p);
p^:=nil;
while not (buf^ in [' ',#0,#8,#10]) do
inc(buf);
end;
end;
{
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
}
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_GETENVPCHAR}
{$UNDEF FPC_FEXPAND_TILDE}
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;
Begin
{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);
if FStat(NewDir,Info) 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 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
DotPos:=i;
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 Dirname(Const path:pathstr):pathstr;
{
This function returns the directory part of a complete path.
Unless the directory is root '/', The last character is not
a slash.
}
var
Dir : PathStr;
Name : NameStr;
Ext : ExtStr;
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 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 (i<LenPat) do
begin
inc(i);
case Pattern[i] of
'*' : ;
'?' : begin
inc(j);
Found:=(j<=LenName);
end;
else
Found:=false;
end;
end;
{Now, find in name the character which i points to, if the * or ?
wasn't the last character in the pattern, else, use up all the
chars in name}
Found:=true;
if (i<=LenPat) then
begin
repeat
{find a letter (not only first !) which maches pattern[i]}
while (j<=LenName) and (name[j]<>pattern[i]) do
inc (j);
if (j<LenName) then
begin
if DoFnMatch(i+1,j+1) then
begin
i:=LenPat;
j:=LenName;{we can stop}
Found:=true;
end
else
inc(j);{We didn't find one, need to look further}
end;
until (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;
function PExists(path:string):boolean;
begin
PExists:=FExists(path);
end;
function FExists(path:string):boolean;
var
info:stat;
begin
FExists:=Fstat(path,info);
end;
function sys_load_image(a:cardinal; argp:ppchar; envp:ppchar):longint; cdecl; external name 'sys_load_image';
function sys_wait_for_thread (th:longint; var exitcode:longint):longint; cdecl; external name 'sys_wait_for_thread';
Function Shell(const Command:String):Longint;
var s:string;
argv:ppchar;
argc:longint;
th:longint;
begin
s:=Command;
argv:=StringToPPChar(s,argc);
th:=0;
{ writeln ('argc = ',argc);
while argv[th]<>Nil do begin
writeln ('argv[',th,'] = ',argv[th]);
th:=th+1;
end;
}
th:=sys_load_image(argc,argv,system.envp);
if th<0 then begin
shell:=0;
exit;
end;
sys_wait_for_thread(th,Shell);
end;
end.

820
rtl/beos/dos.pp
View File

@ -1,820 +0,0 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by members of the Free Pascal
development team
DOS unit template based on POSIX
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 Dos;
Interface
{$goto on}
Const
FileNameLen = 255;
Type
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;
{$DEFINE HAS_FILENAMELEN}
{$I dosh.inc}
Procedure AddDisk(const path:string);
Implementation
Uses
strings,posix;
(* Potentially needed FPC_FEXPAND_* defines should be defined here. *)
{$I dos.inc}
{ Used by AddDisk(), DiskFree() and DiskSize() }
const
Drives : byte = 4;
MAX_DRIVES = 26;
var
DriveStr : array[4..MAX_DRIVES] of pchar;
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
}
var
nr : longint;
Buf : ^char;
p : ppchar;
begin
s:=s+#0;
buf:=@s[1];
nr:=0;
while(buf^<>#0) do
begin
while (buf^ in [' ',#8,#10]) do
inc(buf);
inc(nr);
while not (buf^ in [' ',#0,#8,#10]) do
inc(buf);
end;
getmem(p,nr*4);
StringToPPChar:=p;
if p=nil then
begin
Errno:=sys_enomem;
count := 0;
exit;
end;
buf:=@s[1];
while (buf^<>#0) do
begin
while (buf^ in [' ',#8,#10]) do
begin
buf^:=#0;
inc(buf);
end;
p^:=buf;
inc(p);
p^:=nil;
while not (buf^ in [' ',#0,#8,#10]) do
inc(buf);
end;
count := nr;
end;
{$i dos_beos.inc} { include OS specific stuff }
{******************************************************************************
--- 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;
{
Calculates th day of the week. returns -1 on error
}
var
u,v : longint;
begin
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
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 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 ---
******************************************************************************}
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;
{$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 (i<LenPat) do
begin
inc(i);
case Pattern[i] of
'*' : ;
'?' : begin
inc(j);
Found:=(j<=LenName);
end;
else
Found:=false;
end;
end;
{Now, find in name the character which i points to, if the * or ?
wasn't the last character in the pattern, else, use up all the
chars in name}
Found:=true;
if (i<=LenPat) then
begin
repeat
{find a letter (not only first !) which maches pattern[i]}
while (j<=LenName) and (name[j]<>pattern[i]) do
inc (j);
if (j<LenName) then
begin
if DoFnMatch(i+1,j+1) then
begin
i:=LenPat;
j:=LenName;{we can stop}
Found:=true;
end
else
inc(j);{We didn't find one, need to look further}
end;
until (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
fmode:=0;
if (st.st_mode and S_IWUSR)=0 then
fmode:=fmode or readonly;
FSplit(s,Dir,Name,Ext);
if Name[1]='.' then
fmode:=fmode or hidden;
If ((FMode and Not(f.searchattr))=0) Then
Begin
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;
{We always also search for readonly and archive, regardless of Attr:}
f.SearchAttr := Attr or archive or readonly;
{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 ---
******************************************************************************}
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:=0;
if sys_Access(@textrec(f).name,W_OK)<>0 then
Attr:=Attr or readonly;
if (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: longint): String;
Var
i : longint;
p : ppchar;
Begin
p:=envp; {defined in syslinux}
i:=1;
envstr:='';
if (index < 1) or (index > EnvCount) then
exit;
while (i<Index) and (p^<>nil) 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;
Procedure setftime(var f; time : longint);
Begin
{! No POSIX equivalent !}
End;
Procedure setfattr (var f;attr : word);
Begin
{! No POSIX equivalent !}
End;
{ Include timezone routines }
{$i timezone.inc}
{******************************************************************************
--- Initialization ---
******************************************************************************}
Initialization
InitLocalTime;
finalization
DoneLocalTime;
end.

143
rtl/beos/dos_beos.inc
View File

@ -1,143 +0,0 @@
{
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 ---
******************************************************************************}
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 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;

96
rtl/beos/objinc.inc
View File

@ -1,96 +0,0 @@
{ For linux we 'steal' the following from system unit, this way
we don't need to change the system unit interface. }
Var errno : Longint;
{$i sysnr.inc}
{$i errno.inc}
{$i sysconst.inc}
{$i systypes.inc}
{$i syscalls.inc}
FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle;
Var LinuxMode : longint;
BEGIN
LinuxMode:=0;
if Mode=stCreate then
Begin
LinuxMode:=Open_Creat;
LinuxMode:=LinuxMode or Open_RdWr;
end
else
Begin
Case (Mode and 3) of
0 : LinuxMode:=LinuxMode or Open_RdOnly;
1 : LinuxMode:=LinuxMode or Open_WrOnly;
2 : LinuxMode:=LinuxMode or Open_RdWr;
end;
end;
FileOpen:=SYS_Open (pchar(@FileName[0]),LinuxMode,438 {666 octal});
If FileOpen=-1 then FileOpen:=0;
DosStreamError:=Errno;
END;
FUNCTION FileRead (Handle: THandle; Var BufferArea; BufferLength: Sw_Word;
Var BytesMoved: Sw_Word): Word;
BEGIN
BytesMoved:=Sys_read (Handle,Pchar(@BufferArea),BufferLength);
DosStreamError:=Errno;
FileRead:=Errno;
END;
FUNCTION FileWrite (Handle: THandle; Var BufferArea; BufferLength: Sw_Word;
Var BytesMoved: Sw_Word): Word;
BEGIN
BytesMoved:=Sys_Write (Handle,Pchar(@BufferArea),BufferLength);
FileWrite:=Errno;
DosStreamError:=Errno;
END;
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
VAR NewPos: LongInt): Word;
BEGIN
NewPos:=Sys_LSeek (Handle,Pos,MoveType);
SetFilePos:=Errno;
END;
FUNCTION FileClose (Handle: THandle): Word;
BEGIN
Sys_Close (Handle);
DosStreamError:=Errno;
FileClose := Errno;
END;
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
{$IFNDEF BSD}
Var sr : syscallregs;
{$ENDIF}
{$IFDEF DOSSETFILE1}
Actual, Buf: LongInt;
{$ENDIF}
BEGIN
{$IFDEF BSD}
Do_Syscall(Syscall_Nr_ftruncate,handle,filesize,0); {0 -> offset =64 bit}
{$ELSE}
sr.reg2:=Handle;
sr.reg3:=FileSize;
Syscall(syscall_nr_fTruncate,sr);
{$ENDIF}
If Errno=0 then
SetFileSize:=0
else
SetFileSize:=103;
{$IFDEF DOSSETFILE1}
If (Actual = FileSize) Then Begin { No position error }
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error }
SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error }
{$ENDIF}
END;

463
rtl/beos/osposix.inc
View File

@ -1,463 +0,0 @@
{
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;
{
Revision 1.3 2005/02/14 17:13:21 peter
* truncate log
}

78
rtl/beos/posix.pp
View File

@ -1,78 +0,0 @@
{
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.

18
rtl/beos/sysfiles.inc
View File

@ -1,18 +0,0 @@
const O_RDONLY=0;
const O_WRONLY=1;
const O_RDWR=2;
const O_CREAT = $200;
const O_TRUNC = $400;
const O_APPEND = $800;
{const O_TEXT = $4000;
const O_BINARY = $8000;}
function sys_open (a:cardinal;name:pchar;access:longint;b:longint;c:longint):longint; cdecl; external name 'sys_open';
function sys_close (handle:longint):longint; cdecl; external name 'sys_close';
function sys_read (handle:longint;buffer:pointer;len:longint;var a:longint):longint; cdecl; external name 'sys_read';
function sys_write (handle:longint;buffer:pointer;len:longint;var a:longint):longint; cdecl; external name 'sys_write';
function sys_lseek (handle:longint;pos:int64;whence:longint): int64; cdecl; external name 'sys_lseek';

325
rtl/beos/sysutils.pp
View File

@ -1,325 +0,0 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl
member of the Free Pascal development team
Sysutils unit 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.
**********************************************************************}
unit sysutils;
interface
{$MODE objfpc}
{ force ansistrings }
{$H+}
uses
beos,
dos;
{ Include platform independent interface part }
{$i sysutilh.inc}
implementation
uses
sysconst;
(* Potentially needed FPC_FEXPAND_* defines should be defined here. *)
{ Include platform independent implementation part }
{$i sysutils.inc}
{****************************************************************************
File Functions
****************************************************************************}
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
BEGIN
end;
Function FileCreate (Const FileName : String) : longint;
begin
end;
Function FileCreate (Const FileName : String;Mode:longint) : longint;
begin
end;
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
begin
end;
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
begin
end;
Function FileSeek (Handle,FOffset,Origin : longint) : longint;
begin
end;
Function FileSeek (Handle:longint;FOffset: Int64; Origin: Longint) : int64;
begin
end;
Procedure FileClose (Handle : Longint);
begin
end;
Function FileTruncate (Handle: longint;Size: Int64) : boolean;
begin
end;
Function FileAge (Const FileName : String): Longint;
begin
end;
Function FileExists (Const FileName : String) : Boolean;
begin
end;
Function FindFirst (Const Path : String; Attr : Longint; out Rslt : TSearchRec) : Longint;
begin
end;
Function FindNext (Var Rslt : TSearchRec) : Longint;
begin
end;
Procedure FindClose (Var F : TSearchrec);
begin
end;
Function FileGetDate (Handle : Longint) : Longint;
begin
end;
Function FileSetDate (Handle,Age : Longint) : Longint;
begin
end;
Function FileGetAttr (Const FileName : String) : Longint;
begin
end;
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
begin
end;
Function DeleteFile (Const FileName : String) : Boolean;
begin
end;
Function RenameFile (Const OldName, NewName : String) : Boolean;
begin
end;
{****************************************************************************
Disk Functions
****************************************************************************}
Function DiskFree(Drive: Byte): int64;
Begin
End;
Function DiskSize(Drive: Byte): int64;
Begin
End;
Function GetCurrentDir : String;
begin
GetDir(0,Result);
end;
Function SetCurrentDir (Const NewDir : String) : Boolean;
begin
{$I-}
ChDir(NewDir);
{$I+}
result := (IOResult = 0);
end;
Function CreateDir (Const NewDir : String) : Boolean;
begin
{$I-}
MkDir(NewDir);
{$I+}
result := (IOResult = 0);
end;
Function RemoveDir (Const Dir : String) : Boolean;
begin
{$I-}
RmDir(Dir);
{$I+}
result := (IOResult = 0);
end;
function DirectoryExists (const Directory: string): boolean;
begin
end;
{****************************************************************************
Misc Functions
****************************************************************************}
procedure Beep;
begin
end;
{****************************************************************************
Locale Functions
****************************************************************************}
Procedure GetLocalTime(var SystemTime: TSystemTime);
begin
end ;
Procedure InitAnsi;
Var
i : longint;
begin
{ Fill table entries 0 to 127 }
for i := 0 to 96 do
UpperCaseTable[i] := chr(i);
for i := 97 to 122 do
UpperCaseTable[i] := chr(i - 32);
for i := 123 to 191 do
UpperCaseTable[i] := chr(i);
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
for i := 0 to 64 do
LowerCaseTable[i] := chr(i);
for i := 65 to 90 do
LowerCaseTable[i] := chr(i + 32);
for i := 91 to 191 do
LowerCaseTable[i] := chr(i);
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
end;
Procedure InitInternational;
begin
InitInternationalGeneric;
InitAnsi;
end;
function SysErrorMessage(ErrorCode: Integer): String;
begin
Str(Errorcode,Result);
Result:='Error '+Result;
end;
{****************************************************************************
OS utility functions
****************************************************************************}
Function GetEnvironmentVariable(Const EnvVar : String) : String;
begin
Result:=StrPas(beos.Getenv(PChar(EnvVar)));
end;
Function GetEnvironmentVariableCount : Integer;
begin
// Result:=FPCCountEnvVar(EnvP);
Result:=0;
end;
Function GetEnvironmentString(Index : Integer) : String;
begin
// Result:=FPCGetEnvStrFromP(Envp,Index);
Result:='';
end;
function ExecuteProcess (const Path: AnsiString; const ComLine: AnsiString):
integer;
var
CommandLine: AnsiString;
begin
{ always surround the name of the application by quotes
so that long filenames will always be accepted. But don't
do it if there are already double quotes!
}
if pos('"',path)=0 then
CommandLine:='"'+path+'"'
else
CommandLine:=path;
if ComLine <> '' then
CommandLine := Commandline + ' ' + ComLine;
ExecuteProcess := beos.shell (CommandLine);
end;
function ExecuteProcess (const Path: AnsiString;
const ComLine: array of AnsiString): integer;
{$WARNING Should be probably changed according to the Unix version}
var
CommandLine: AnsiString;
I: integer;
begin
Commandline := '';
for I := 0 to High (ComLine) do
if Pos (' ', ComLine [I]) <> 0 then
CommandLine := CommandLine + ' ' + '"' + ComLine [I] + '"'
else
CommandLine := CommandLine + ' ' + Comline [I];
ExecuteProcess := ExecuteProcess (Path, CommandLine);
end;
{****************************************************************************
Initialization code
****************************************************************************}
Initialization
InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings }
Finalization
DoneExceptions;
end.

428
rtl/beos/timezone.inc
View File

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