pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

OS/2 support by Tomas Hajny

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@171 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2013-02-05 10:17:42 +00:00
parent 15577c3625
commit 2a96820027
7 changed files with 2638 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
ssl_openssl_lib.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.007.001 | | Project : Ararat Synapse | 003.007.002 |
|==============================================================================| |==============================================================================|
| Content: SSL support by OpenSSL | | Content: SSL support by OpenSSL |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer | | Copyright (c)1999-2013, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,11 +33,12 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2012. | | Portions created by Lukas Gebauer are Copyright (c)2002-2013. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Tomas Hajny (OS2 support) |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
@ -87,10 +88,13 @@ uses
synafpc, synafpc,
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
{$IFDEF FPC} {$IFDEF FPC}
BaseUnix, SysUtils; {$IFDEF UNIX}
BaseUnix,
{$ENDIF UNIX}
{$ELSE} {$ELSE}
Libc, SysUtils; Libc,
{$ENDIF} {$ENDIF}
SysUtils;
{$ELSE} {$ELSE}
Windows; Windows;
{$ENDIF} {$ENDIF}
@ -112,8 +116,18 @@ var
DLLSSLName: string = 'libssl.dylib'; DLLSSLName: string = 'libssl.dylib';
DLLUtilName: string = 'libcrypto.dylib'; DLLUtilName: string = 'libcrypto.dylib';
{$ELSE} {$ELSE}
{$IFDEF OS2}
{$IFDEF OS2GCC}
DLLSSLName: string = 'kssl.dll';
DLLUtilName: string = 'kcrypto.dll';
{$ELSE OS2GCC}
DLLSSLName: string = 'ssl.dll';
DLLUtilName: string = 'crypto.dll';
{$ENDIF OS2GCC}
{$ELSE OS2}
DLLSSLName: string = 'libssl.so'; DLLSSLName: string = 'libssl.so';
DLLUtilName: string = 'libcrypto.so'; DLLUtilName: string = 'libcrypto.so';
{$ENDIF OS2}
{$ENDIF} {$ENDIF}
{$ELSE} {$ELSE}
DLLSSLName: string = 'ssleay32.dll'; DLLSSLName: string = 'ssleay32.dll';
@ -799,7 +813,11 @@ var
implementation implementation
uses SyncObjs; uses
{$IFDEF OS2}
Sockets,
{$ENDIF OS2}
SyncObjs;
{$IFNDEF CIL} {$IFNDEF CIL}
type type
@ -1950,8 +1968,12 @@ begin
if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
InitLocks; InitLocks;
{$ENDIF} {$ENDIF}
Result := True;
SSLloaded := True; SSLloaded := True;
{$IFDEF OS2}
Result := InitEMXHandles;
{$ELSE OS2}
Result := True;
{$ENDIF OS2}
end end
else else
begin begin

1843
ssos2ws1.inc Normal file
View File

File diff suppressed because it is too large Load Diff

11
synafpc.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.003.000 | | Project : Ararat Synapse | 001.003.001 |
|==============================================================================| |==============================================================================|
| Content: Utils for FreePascal compatibility | | Content: Utils for FreePascal compatibility |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer | | Copyright (c)1999-2013, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,10 +33,11 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2012. | | Portions created by Lukas Gebauer are Copyright (c)2003-2013. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Tomas Hajny (OS2 support) |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
@ -115,7 +116,11 @@ end;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
begin begin
{$IFDEF OS2GCC}
Result := dynlibs.GetProcedureAddress(Module, '_' + Proc);
{$ELSE OS2GCC}
Result := dynlibs.GetProcedureAddress(Module, Proc); Result := dynlibs.GetProcedureAddress(Module, Proc);
{$ENDIF OS2GCC}
end; end;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;

13
synaicnv.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.001 | | Project : Ararat Synapse | 001.001.002 |
|==============================================================================| |==============================================================================|
| Content: ICONV support for Win32, Linux and .NET | | Content: ICONV support for Win32, OS/2, Linux and .NET |
|==============================================================================| |==============================================================================|
| Copyright (c)2004-2010, Lukas Gebauer | | Copyright (c)2004-2013, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,10 +33,11 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2004-2010. | | Portions created by Lukas Gebauer are Copyright (c)2004-2013. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Tomas Hajny (OS2 support) |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
@ -81,7 +82,11 @@ uses
const const
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
{$IFDEF OS2}
DLLIconvName = 'iconv.dll';
{$ELSE OS2}
DLLIconvName = 'libiconv.so'; DLLIconvName = 'libiconv.so';
{$ENDIF OS2}
{$ELSE} {$ELSE}
DLLIconvName = 'iconv.dll'; DLLIconvName = 'iconv.dll';
{$ENDIF} {$ENDIF}

52
synautil.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 004.015.002 | | Project : Ararat Synapse | 004.015.003 |
|==============================================================================| |==============================================================================|
| Content: support procedures and functions | | Content: support procedures and functions |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer | | Copyright (c)1999-2013, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,13 +33,14 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2012. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2013. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. | | Portions created by Hernan Sanchez are Copyright (c) 2000. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. | | Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Hernan Sanchez (hernan.sanchez@iname.com) | | Hernan Sanchez (hernan.sanchez@iname.com) |
| Tomas Hajny (OS2 support) |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
@ -66,10 +67,14 @@ interface
uses uses
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
Windows, Windows,
{$ELSE} {$ELSE MSWINDOWS}
{$IFDEF FPC} {$IFDEF FPC}
{$IFDEF OS2}
Dos, TZUtil,
{$ELSE OS2}
UnixUtil, Unix, BaseUnix, UnixUtil, Unix, BaseUnix,
{$ELSE} {$ENDIF OS2}
{$ELSE FPC}
Libc, Libc,
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
@ -763,21 +768,31 @@ begin
st.Millisecond := stw.wMilliseconds; st.Millisecond := stw.wMilliseconds;
result := SystemTimeToDateTime(st); result := SystemTimeToDateTime(st);
{$ENDIF} {$ENDIF}
{$ELSE} {$ELSE MSWINDOWS}
{$IFNDEF FPC} {$IFNDEF FPC}
var var
TV: TTimeVal; TV: TTimeVal;
begin begin
gettimeofday(TV, nil); gettimeofday(TV, nil);
Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
{$ELSE} {$ELSE FPC}
{$IFDEF UNIX}
var var
TV: TimeVal; TV: TimeVal;
begin begin
fpgettimeofday(@TV, nil); fpgettimeofday(@TV, nil);
Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
{$ENDIF} {$ELSE UNIX}
{$ENDIF} {$IFDEF OS2}
var
ST: TSystemTime;
begin
GetLocalTime (ST);
Result := SystemTimeToDateTime (ST);
{$ENDIF OS2}
{$ENDIF UNIX}
{$ENDIF FPC}
{$ENDIF MSWINDOWS}
end; end;
{==============================================================================} {==============================================================================}
@ -805,7 +820,7 @@ begin
stw.wMilliseconds := st.Millisecond; stw.wMilliseconds := st.Millisecond;
Result := SetSystemTime(stw); Result := SetSystemTime(stw);
{$ENDIF} {$ENDIF}
{$ELSE} {$ELSE MSWINDOWS}
{$IFNDEF FPC} {$IFNDEF FPC}
var var
TV: TTimeVal; TV: TTimeVal;
@ -821,7 +836,8 @@ begin
TV.tv_sec := trunc(d); TV.tv_sec := trunc(d);
TV.tv_usec := trunc(frac(d) * 1000000); TV.tv_usec := trunc(frac(d) * 1000000);
Result := settimeofday(TV, TZ) <> -1; Result := settimeofday(TV, TZ) <> -1;
{$ELSE} {$ELSE FPC}
{$IFDEF UNIX}
var var
TV: TimeVal; TV: TimeVal;
d: double; d: double;
@ -830,8 +846,18 @@ begin
TV.tv_sec := trunc(d); TV.tv_sec := trunc(d);
TV.tv_usec := trunc(frac(d) * 1000000); TV.tv_usec := trunc(frac(d) * 1000000);
Result := fpsettimeofday(@TV, nil) <> -1; Result := fpsettimeofday(@TV, nil) <> -1;
{$ENDIF} {$ELSE UNIX}
{$ENDIF} {$IFDEF OS2}
var
ST: TSystemTime;
begin
DateTimeToSystemTime (NewDT, ST);
SetTime (ST.Hour, ST.Minute, ST.Second, ST.Millisecond div 10);
Result := true;
{$ENDIF OS2}
{$ENDIF UNIX}
{$ENDIF FPC}
{$ENDIF MSWINDOWS}
end; end;
{==============================================================================} {==============================================================================}

11
synsock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 005.002.001 | | Project : Ararat Synapse | 005.002.002 |
|==============================================================================| |==============================================================================|
| Content: Socket Independent Platform Layer | | Content: Socket Independent Platform Layer |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer | | Copyright (c)1999-2013, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -33,10 +33,11 @@
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2011. | | Portions created by Lukas Gebauer are Copyright (c)2001-2013. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Tomas Hajny (OS2 support) |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
@ -65,7 +66,11 @@ unit synsock;
{$I sswin32.inc} //not complete yet! {$I sswin32.inc} //not complete yet!
{$ELSE} {$ELSE}
{$IFDEF FPC} {$IFDEF FPC}
{$IFDEF OS2}
{$I ssos2ws1.inc}
{$ELSE OS2}
{$I ssfpc.inc} {$I ssfpc.inc}
{$ENDIF OS2}
{$ELSE} {$ELSE}
{$I sslinux.inc} {$I sslinux.inc}
{$ENDIF} {$ENDIF}

702
tzutil.pas Normal file
View File

@ -0,0 +1,702 @@
//Unit with timezone support for some Freepascal platforms.
//Tomas Hajny
unit tzutil;
interface
type
DSTSpecType = (DSTMonthWeekDay, DSTMonthDay, DSTJulian, DSTJulianX);
(* Initialized to default values *)
const
TZName: string = '';
TZDSTName: string = '';
TZOffset: longint = 0;
DSTOffset: longint = 0;
DSTStartMonth: byte = 4;
DSTStartWeek: shortint = 1;
DSTStartDay: word = 0;
DSTStartSec: cardinal = 7200;
DSTEndMonth: byte = 10;
DSTEndWeek: shortint = -1;
DSTEndDay: word = 0;
DSTEndSec: cardinal = 10800;
DSTStartSpecType: DSTSpecType = DSTMonthWeekDay;
DSTEndSpecType: DSTSpecType = DSTMonthWeekDay;
function TZSeconds: longint;
(* Return current offset from UTC in seconds while respecting DST *)
implementation
uses
Dos;
function TZSeconds: longint;
const
MonthDays: array [1..12] of byte =
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
MonthEnds: array [1..12] of word =
(31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365);
var
Y, Mo, D, WD, H, Mi, S, S100: word;
MS, DS, ME, DE: byte;
L: longint;
Second: cardinal;
AfterDSTStart, BeforeDSTEnd: boolean;
function LeapDay: byte;
begin
if (Y mod 400 = 0) or (Y mod 100 <> 0) and (Y mod 4 = 0) then
LeapDay := 1
else
LeapDay := 0;
end;
function FirstDay (MM: byte): byte;
(* What day of week (0-6) is the first day of month MM? *)
var
DD: longint;
begin
if MM < Mo then
begin
DD := D + MonthEnds [Pred (Mo)];
if MM > 1 then
Dec (DD, MonthEnds [Pred (MM)]);
if (MM <= 2) and (Mo > 2) then
Inc (DD, LeapDay);
end
else
if MM > Mo then
begin
DD := - MonthDays [Mo] + D - MonthEnds [Pred (MM)] + MonthEnds [Mo];
if (Mo <= 2) and (MM > 2) then
Dec (DD, LeapDay);
end
else
(* M = MM *)
DD := D;
DD := WD - DD mod 7 + 1;
if DD < 0 then
FirstDay := DD + 7
else
FirstDay := DD mod 7;
end;
begin
TZSeconds := TZOffset;
if DSTOffset <> TZOffset then
begin
GetDate (Y, Mo, D, WD);
GetTime (H, Mi, S, S100);
Second := cardinal (H) * 3600 + Mi * 60 + S;
if (DSTStartSpecType = DSTMonthWeekDay) or (DSTStartSpecType = DSTMonthDay)
then
begin
MS := DSTStartMonth;
if DSTStartSpecType = DSTMonthDay then
DS := DSTStartDay
else
begin
DS := FirstDay (DSTStartMonth);
if (DSTStartWeek >= 1) and (DSTStartWeek <= 4) then
if DSTStartDay < DS then
DS := DSTStartWeek * 7 + DSTStartDay - DS + 1
else
DS := Pred (DSTStartWeek) * 7 + DSTStartDay - DS + 1
else
(* Last week in month *)
begin
DS := DS + MonthDays [MS] - 1;
if MS = 2 then
Inc (DS, LeapDay);
DS := DS mod 7;
if DS < DSTStartDay then
DS := DS + 7 - DSTStartDay
else
DS := DS - DSTStartDay;
DS := MonthDays [MS] - DS;
end;
end;
end
else
begin
(* Julian day *)
L := DSTStartDay;
if (DSTStartSpecType = DSTJulian) then
(* 0-based *)
if (L + LeapDay <= 59) then
Inc (L)
else
L := L + 1 - LeapDay;
if L <= 31 then
begin
MS := 1;
DS := L;
end
else
if (L <= 59) or
(DSTStartSpecType = DSTJulian) and (L - LeapDay <= 59) then
begin
MS := 2;
DS := DSTStartDay - 31;
end
else
begin
MS := 3;
while (MS < 12) and (MonthEnds [MS] > L) do
Inc (MS);
DS := L - MonthEnds [Pred (MS)];
end;
end;
if (DSTEndSpecType = DSTMonthWeekDay) or (DSTEndSpecType = DSTMonthDay) then
begin
ME := DSTEndMonth;
if DSTEndSpecType = DSTMonthDay then
DE := DSTEndDay
else
begin
DE := FirstDay (DSTEndMonth);
if (DSTEndWeek >= 1) and (DSTEndWeek <= 4) then
if DSTEndDay < DE then
DE := DSTEndWeek * 7 + DSTEndDay - DE + 1
else
DE := Pred (DSTEndWeek) * 7 + DSTEndDay - DE + 1
else
(* Last week in month *)
begin
DE := DE + MonthDays [ME] - 1;
if ME = 2 then
Inc (DE, LeapDay);
DE := DE mod 7;
if DE < DSTEndDay then
DE := DE + 7 - DSTEndDay
else
DE := DE - DSTEndDay;
DE := MonthDays [ME] - DE;
end;
end;
end
else
begin
(* Julian day *)
L := DSTEndDay;
if (DSTEndSpecType = DSTJulian) then
(* 0-based *)
if (L + LeapDay <= 59) then
Inc (L)
else
L := L + 1 - LeapDay;
if L <= 31 then
begin
ME := 1;
DE := L;
end
else
if (L <= 59) or
(DSTEndSpecType = DSTJulian) and (L - LeapDay <= 59) then
begin
ME := 2;
DE := DSTEndDay - 31;
end
else
begin
ME := 3;
while (ME < 12) and (MonthEnds [ME] > L) do
Inc (ME);
DE := L - MonthEnds [Pred (ME)];
end;
end;
if Mo < MS then
AfterDSTStart := false
else
if Mo > MS then
AfterDSTStart := true
else
if D < DS then
AfterDSTStart := false
else
if D > DS then
AfterDSTStart := true
else
AfterDSTStart := Second > DSTStartSec;
if Mo > ME then
BeforeDSTEnd := false
else
if Mo < ME then
BeforeDSTEnd := true
else
if D > DE then
BeforeDSTEnd := false
else
if D < DE then
BeforeDSTEnd := true
else
BeforeDSTEnd := Second < DSTEndSec;
if AfterDSTStart and BeforeDSTEnd then
TZSeconds := DSTOffset;
end;
end;
procedure InitTZ;
const
TZEnvName = 'TZ';
EMXTZEnvName = 'EMXTZ';
var
TZ, S: string;
I, J: byte;
Err: longint;
GnuFmt: boolean;
ADSTStartMonth: byte;
ADSTStartWeek: shortint;
ADSTStartDay: word;
ADSTStartSec: cardinal;
ADSTEndMonth: byte;
ADSTEndWeek: shortint;
ADSTEndDay: word;
ADSTEndSec: cardinal;
ADSTStartSpecType: DSTSpecType;
ADSTEndSpecType: DSTSpecType;
ADSTChangeSec: cardinal;
function ParseOffset (OffStr: string): longint;
(* Parse time offset given as [-|+]HH[:MI[:SS]] and return in seconds *)
var
TZShiftHH, TZShiftDir: shortint;
TZShiftMI, TZShiftSS: byte;
N1, N2: byte;
begin
TZShiftHH := 0;
TZShiftMI := 0;
TZShiftSS := 0;
TZShiftDir := 1;
N1 := 1;
while (N1 <= Length (OffStr)) and (OffStr [N1] <> ':') do
Inc (N1);
Val (Copy (OffStr, 1, Pred (N1)), TZShiftHH, Err);
if (Err = 0) and (TZShiftHH >= -24) and (TZShiftHH <= 23) then
begin
(* Normalize the hour offset to -12..11 if necessary *)
if TZShiftHH > 11 then
Dec (TZShiftHH, 24) else
if TZShiftHH < -12 then
Inc (TZShiftHH, 24);
if TZShiftHH < 0 then
TZShiftDir := -1;
if (N1 <= Length (OffStr)) then
begin
N2 := Succ (N1);
while (N2 <= Length (OffStr)) and (OffStr [N2] <> ':') do
Inc (N2);
Val (Copy (OffStr, Succ (N1), N2 - N1), TZShiftMI, Err);
if (Err = 0) and (TZShiftMI <= 59) then
begin
if (N2 <= Length (OffStr)) then
begin
Val (Copy (OffStr, Succ (N2), Length (OffStr) - N2), TZShiftSS, Err);
if (Err <> 0) or (TZShiftSS > 59) then
TZShiftSS := 0;
end
end
else
TZShiftMI := 0;
end;
end
else
TZShiftHH := 0;
ParseOffset := longint (TZShiftHH) * 3600 +
TZShiftDir * (longint (TZShiftMI) * 60 + TZShiftSS);
end;
begin
TZ := GetEnv (TZEnvName);
if TZ = '' then
TZ := GetEnv (EMXTZEnvName);
if TZ <> '' then
begin
TZ := Upcase (TZ);
(* Timezone name *)
I := 1;
while (I <= Length (TZ)) and (TZ [I] in ['A'..'Z']) do
Inc (I);
TZName := Copy (TZ, 1, Pred (I));
if I <= Length (TZ) then
begin
(* Timezone shift *)
J := Succ (I);
while (J <= Length (TZ)) and not (TZ [J] in ['A'..'Z']) do
Inc (J);
TZOffset := ParseOffset (Copy (TZ, I, J - I));
(* DST timezone name *)
I := J;
while (J <= Length (TZ)) and (TZ [J] in ['A'..'Z']) do
Inc (J);
if J > I then
begin
TZDSTName := Copy (TZ, I, J - I);
(* DST timezone name provided; if equal to the standard timezone *)
(* name then DSTOffset is set to be equal to TZOffset by default, *)
(* otherwise it is set to TZOffset - 3600 seconds. *)
if TZDSTName <> TZName then
DSTOffset := -3600 + TZOffset
else
DSTOffset := TZOffset;
end
else
begin
TZDSTName := TZName;
(* No DST timezone name provided => DSTOffset is equal to TZOffset *)
DSTOffset := TZOffset;
end;
if J <= Length (TZ) then
begin
(* Check if DST offset is specified here; *)
(* if not, default value set above is used. *)
if TZ [J] <> ',' then
begin
I := J;
Inc (J);
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
DSTOffset := ParseOffset (Copy (TZ, I, J - I));
end;
if J < Length (TZ) then
begin
Inc (J);
(* DST switching details *)
case TZ [J] of
'M':
begin
(* Mmonth.week.dayofweek[/StartHour] *)
ADSTStartSpecType := DSTMonthWeekDay;
if J >= Length (TZ) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
Inc (J);
if (J >= Length (TZ)) or (TZ [J] <> '.') then
Exit;
Val (Copy (TZ, I, J - I), ADSTStartMonth, Err);
if (Err > 0) or (ADSTStartMonth > 12) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
Inc (J);
if (J >= Length (TZ)) or (TZ [J] <> '.') then
Exit;
Val (Copy (TZ, I, J - I), ADSTStartWeek, Err);
if (Err > 0) or (ADSTStartWeek < 1) or (ADSTStartWeek > 5) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6)
or (J >= Length (TZ)) then
Exit;
if TZ [J] = '/' then
begin
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ))
then
Exit
else
ADSTStartSec := ADSTStartSec * 3600;
end
else
(* Use the preset default *)
ADSTStartSec := DSTStartSec;
Inc (J);
end;
'J':
begin
(* Jjulianday[/StartHour] *)
ADSTStartSpecType := DSTJulianX;
if J >= Length (TZ) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
if (Err > 0) or (ADSTStartDay = 0) or (ADSTStartDay > 365)
or (J >= Length (TZ)) then
Exit;
if TZ [J] = '/' then
begin
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ))
then
Exit
else
ADSTStartSec := ADSTStartSec * 3600;
end
else
(* Use the preset default *)
ADSTStartSec := DSTStartSec;
Inc (J);
end
else
begin
(* Check the used format first - GNU libc / GCC / EMX expect *)
(* "NameOffsetDstname[Dstoffset],Start[/StartHour],End[/EndHour]"; *)
(* if more than one comma (',') is found, the following format is assumed: *)
(* "NameOffsetDstname[Dstoffset],StartMonth,StartWeek,StartDay,StartSecond, *)
(* EndMonth,EndWeek,EndDay,EndSecond,DSTDifference". *)
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
S := Copy (TZ, I, J - I);
if J < Length (TZ) then
begin
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
GnuFmt := J > Length (TZ);
end
else
Exit;
if GnuFmt then
begin
ADSTStartSpecType := DSTJulian;
J := Pos ('/', S);
if J = 0 then
begin
Val (S, ADSTStartDay, Err);
if (Err > 0) or (ADSTStartDay > 365) then
Exit;
(* Use the preset default *)
ADSTStartSec := DSTStartSec;
end
else
begin
if J = Length (S) then
Exit;
Val (Copy (S, 1, Pred (J)), ADSTStartDay, Err);
if (Err > 0) or (ADSTStartDay > 365) then
Exit;
Val (Copy (S, Succ (J), Length (S) - J), ADSTStartSec, Err);
if (Err > 0) or (ADSTStartSec > 86399) then
Exit
else
ADSTStartSec := ADSTStartSec * 3600;
end;
J := I;
end
else
begin
Val (S, ADSTStartMonth, Err);
if (Err > 0) or (ADSTStartMonth > 12) then
Exit;
Val (Copy (TZ, I, J - I), ADSTStartWeek, Err);
if (Err > 0) or (ADSTStartWeek < -1) or (ADSTStartWeek > 5) or
(J >= Length (TZ)) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTStartDay, Err);
if (DSTStartWeek = 0) then
begin
if (Err > 0) or (ADSTStartDay < 1) or (ADSTStartDay > 31)
or (ADSTStartDay > 30) and (ADSTStartMonth in [4, 6, 9, 11])
or (ADSTStartMonth = 2) and (ADSTStartDay > 29) then
Exit;
ADSTStartSpecType := DSTMonthDay;
end
else
begin
if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) then
Exit;
ADSTStartSpecType := DSTMonthWeekDay;
end;
if J >= Length (TZ) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTStartSec, Err);
if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTEndMonth, Err);
if (Err > 0) or (ADSTEndMonth > 12) or (J >= Length (TZ)) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTEndWeek, Err);
if (Err > 0) or (ADSTEndWeek < -1) or (ADSTEndWeek > 5)
or (J >= Length (TZ)) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
if (DSTEndWeek = 0) then
begin
if (Err > 0) or (ADSTEndDay < 1) or (ADSTEndDay > 31)
or (ADSTEndDay > 30) and (ADSTEndMonth in [4, 6, 9, 11])
or (ADSTEndMonth = 2) and (ADSTEndDay > 29) then
Exit;
ADSTEndSpecType := DSTMonthDay;
end
else
begin
if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then
Exit;
ADSTEndSpecType := DSTMonthWeekDay;
end;
if J >= Length (TZ) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> ',') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTEndSec, Err);
if (Err > 0) or (ADSTEndSec > 86399) or (J >= Length (TZ)) then
Exit;
Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTChangeSec, Err);
if (Err = 0) and (ADSTChangeSec < 86400) then
begin
(* Format complete, all checks successful => accept the parsed values. *)
DSTStartMonth := ADSTStartMonth;
DSTStartWeek := ADSTStartWeek;
DSTStartDay := ADSTStartDay;
DSTStartSec := ADSTStartSec;
DSTEndMonth := ADSTEndMonth;
DSTEndWeek := ADSTEndWeek;
DSTEndDay := ADSTEndDay;
DSTEndSec := ADSTEndSec;
DSTStartSpecType := ADSTStartSpecType;
DSTEndSpecType := ADSTEndSpecType;
DSTOffset := TZOffset - ADSTChangeSec;
end;
(* Parsing finished *)
Exit;
end;
end;
end;
(* GnuFmt - DST end specification *)
if TZ [J] = 'M' then
begin
(* Mmonth.week.dayofweek *)
ADSTEndSpecType := DSTMonthWeekDay;
if J >= Length (TZ) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
Inc (J);
if (J >= Length (TZ)) or (TZ [J] <> '.') then
Exit;
Val (Copy (TZ, I, J - I), ADSTEndMonth, Err);
if (Err > 0) or (ADSTEndMonth > 12) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do
Inc (J);
if (J >= Length (TZ)) or (TZ [J] <> '.') then
Exit;
Val (Copy (TZ, I, J - I), ADSTEndWeek, Err);
if (Err > 0) or (ADSTEndWeek < 1) or (ADSTEndWeek > 5) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> '/') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then
Exit;
end
else
begin
if TZ [J] = 'J' then
begin
(* Jjulianday *)
if J = Length (TZ) then
Exit;
Inc (J);
ADSTEndSpecType := DSTJulianX
end
else
ADSTEndSpecType := DSTJulian;
if J >= Length (TZ) then
Exit;
Inc (J);
I := J;
while (J <= Length (TZ)) and (TZ [J] <> '/') do
Inc (J);
Val (Copy (TZ, I, J - I), ADSTEndDay, Err);
if (Err > 0) or (ADSTEndDay = 0) and (ADSTEndSpecType = DSTJulianX)
or (ADSTEndDay > 365) then
Exit;
end;
if (J <= Length (TZ)) and (TZ [J] = '/') then
begin
if J = Length (TZ) then
Exit;
Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTEndSec, Err);
if (Err > 0) or (ADSTEndSec > 86399) then
Exit
else
ADSTEndSec := ADSTEndSec * 3600;
end
else
(* Use the preset default *)
ADSTEndSec := DSTEndSec;
(* Format complete, all checks successful => accept the parsed values. *)
if ADSTStartSpecType = DSTMonthWeekDay then
begin
DSTStartMonth := ADSTStartMonth;
DSTStartWeek := ADSTStartWeek;
end;
DSTStartDay := ADSTStartDay;
DSTStartSec := ADSTStartSec;
if ADSTStartSpecType = DSTMonthWeekDay then
begin
DSTEndMonth := ADSTEndMonth;
DSTEndWeek := ADSTEndWeek;
end;
DSTEndDay := ADSTEndDay;
DSTEndSec := ADSTEndSec;
DSTStartSpecType := ADSTStartSpecType;
DSTEndSpecType := ADSTEndSpecType;
end;
end
else
DSTOffset := -3600 + TZOffset;
end;
end;
end;
begin
InitTZ;
end.