{
pascalx.utils — модуль, содержащий классы таблиц «ключ=значение» и работы с датой и временем.
Copyright © 2021 Малик Разработчик
Это свободная программа: вы можете перераспространять её и/или
изменять её на условиях Меньшей Стандартной общественной лицензии GNU в том виде,
в каком она была опубликована Фондом свободного программного обеспечения;
либо версии 3 лицензии, либо (по вашему выбору) любой более поздней версии.
Эта программа распространяется в надежде, что она может быть полезна,
но БЕЗО ВСЯКИХ ГАРАНТИЙ; даже без неявной гарантии ТОВАРНОГО ВИДА
или ПРИГОДНОСТИ ДЛЯ ОПРЕДЕЛЁННЫХ ЦЕЛЕЙ. Подробнее см. в Меньшей Стандартной
общественной лицензии GNU.
Вы должны были получить копию Меньшей Стандартной общественной лицензии GNU
вместе с этой программой. Если это не так, см.
<http://www.gnu.org/licenses/>.
}
unit pascalx.utils;
{$MODE DELPHI}
interface
uses
windows,
pascalx.lang,
osindepended.fileformats;
{$ASMMODE INTEL,CALLING REGISTER,TYPEINFO ON}
{%region public }
const { значения для Calendar }
FLD_YEAR = int(1);
FLD_MONTH = int(2);
FLD_DAY = int(5);
FLD_WEEKDAY = int(7);
FLD_AMPM = int(9);
FLD_HOUR12 = int(10);
FLD_HOUR = int(11);
FLD_MINUTE = int(12);
FLD_SECOND = int(13);
FLD_MILLISECOND = int(14);
MONDAY = int(1);
TUESDAY = int(2);
WEDNESDAY = int(3);
THURSDAY = int(4);
FRIDAY = int(5);
SATURDAY = int(6);
SUNDAY = int(0);
JANUARY = int(1);
FEBRUARY = int(2);
MARCH = int(3);
APRIL = int(4);
MAY = int(5);
JUNE = int(6);
JULY = int(7);
AUGUST = int(8);
SEPTEMBER = int(9);
OCTOBER = int(10);
NOVEMBER = int(11);
DECEMBER = int(12);
AM = int(0);
PM = int(1);
type
Calendar = interface;
Enumeration = interface;
MapEnumeration = interface;
EmptyEnumerator = class;
Hashtable = class;
CustomCalendar = class;
GregorianCalendar = class;
OverflowException = class;
NoSuchElementException = class;
Calendar = interface(_Interface) ['{A3919068-04E5-47B0-A10D-591E2A664129}']
function after(anot: Calendar): boolean;
function before(anot: Calendar): boolean;
function getDaysCount(): int;
function getField(field: int): int;
function getOffset(): int;
function getTime(): long;
function getEpochStart(): long;
procedure setField(field, value: int);
procedure setOffset(offset: int);
procedure setTime(time: long);
property year: int index FLD_YEAR read getField write setField;
property month: int index FLD_MONTH read getField write setField;
property day: int index FLD_DAY read getField write setField;
property weekday: int index FLD_WEEKDAY read getField;
property ampm: int index FLD_AMPM read getField write setField;
property hour12: int index FLD_HOUR12 read getField write setField;
property hour: int index FLD_HOUR read getField write setField;
property minute: int index FLD_MINUTE read getField write setField;
property second: int index FLD_SECOND read getField write setField;
property millisecond: int index FLD_MILLISECOND read getField write setField;
property offset: int read getOffset write setOffset;
property time: long read getTime write setTime;
property epochStart: long read getEpochStart;
end;
Enumeration = interface(_Interface) ['{A3919068-04E5-47B0-A10D-591E2A66412A}']
function hasMoreElements(): boolean;
function nextElement(): Value;
end;
MapEnumeration = interface(Enumeration) ['{A3919068-04E5-47B0-A10D-591E2A66412B}']
function value(): pascalx.lang.Value;
end;
EmptyEnumerator = class(DynamicalyAllocatedObject, Enumeration)
public
function hasMoreElements(): boolean;
function nextElement(): Value;
end;
Hashtable = class(_Object, DataHolder)
private type
Entry = class;
ElementEnumerator = class;
KeyEnumerator = class;
Entry_Array1d = packed array of Entry;
Entry = class(_Object)
public
hash: long;
key: pascalx.lang.Value;
value: pascalx.lang.Value;
next: Entry;
constructor create(hash: long; key, value: pascalx.lang.Value; next: Entry);
end;
ElementEnumerator = class(RefCountInterfacedObject, Enumeration)
private
keys: boolean;
index: int;
table: Entry_Array1d;
next: Entry;
current: Entry;
public
constructor create(keys: boolean; const table: Entry_Array1d);
function hasMoreElements(): boolean;
function nextElement(): Value;
end;
KeyEnumerator = class(ElementEnumerator, MapEnumeration)
public
constructor create(const table: Entry_Array1d);
function value(): pascalx.lang.Value;
end;
private
factor: int;
length: int;
table: Entry_Array1d;
protected
procedure rehash(); virtual;
public
constructor create(); overload;
constructor create(initialCapacity: int); overload;
destructor destroy; override;
function toString(): AnsiString; override;
function isEmpty(): boolean; virtual;
function contains(value: pascalx.lang.Value): boolean; virtual;
function containsKey(key: pascalx.lang.Value): boolean; virtual;
function size(): int; virtual;
function put(key, value: pascalx.lang.Value): pascalx.lang.Value; virtual;
function remove(key: pascalx.lang.Value): pascalx.lang.Value; virtual;
function get(key: pascalx.lang.Value): pascalx.lang.Value; virtual;
function elements(): Enumeration; virtual;
function keys(): Enumeration; virtual;
procedure clear(); virtual;
end;
Vector = class(_Object, DataHolder)
private type
ElementEnumerator = class(RefCountInterfacedObject, Enumeration)
private
index: int;
owner: Vector;
public
constructor create(owner: Vector);
function hasMoreElements(): boolean;
function nextElement(): Value;
end;
private
length: int;
data: Value_Array1d;
public
constructor create(); overload;
constructor create(initialCapacity: int); overload;
function toString(): AnsiString; override;
function isEmpty(): boolean; virtual;
function contains(element: Value): boolean; virtual;
function indexOf(element: Value): int; virtual;
function size(): int; virtual;
function elements(): Enumeration; virtual;
function lastElement(): Value; virtual;
function firstElement(): Value; virtual;
function elementAt(index: int): Value; virtual;
function setElementAt(index: int; element: Value): Value; virtual;
function delete(index: int): Value; virtual;
function remove(element: Value): boolean; virtual;
procedure insert(index: int; element: Value); virtual;
procedure append(element: Value); virtual;
procedure clear(); virtual;
end;
CustomCalendar = class(DynamicalyAllocatedObject, Calendar)
private
procedure updateHour12();
procedure updateHour24();
protected
offsetInMillis: int;
timeInMillis: long;
fields: int_Array1d;
procedure computeFields(); virtual; abstract;
procedure computeTime(); virtual; abstract;
public
constructor create(); override;
function equals(anot: TObject): boolean; override;
function getHashCode(): long; override;
function after(anot: Calendar): boolean;
function before(anot: Calendar): boolean;
function getDaysCount(): int; virtual; abstract;
function getField(field: int): int;
function getOffset(): int;
function getTime(): long;
function getEpochStart(): long; virtual; abstract;
procedure setField(field, value: int);
procedure setOffset(offset: int);
procedure setTime(time: long);
published
property year: int index FLD_YEAR read getField write setField stored false;
property month: int index FLD_MONTH read getField write setField stored false;
property day: int index FLD_DAY read getField write setField stored false;
property weekday: int index FLD_WEEKDAY read getField stored false;
property ampm: int index FLD_AMPM read getField write setField stored false;
property hour12: int index FLD_HOUR12 read getField write setField stored false;
property hour: int index FLD_HOUR read getField write setField stored false;
property minute: int index FLD_MINUTE read getField write setField stored false;
property second: int index FLD_SECOND read getField write setField stored false;
property millisecond: int index FLD_MILLISECOND read getField write setField stored false;
property offset: int read offsetInMillis write setOffset stored true;
property time: long read timeInMillis write setTime stored true;
property epochStart: long read getEpochStart stored false;
end;
GregorianCalendar = class(CustomCalendar)
private
class function getDaysCount(year, month: int): int; static; overload;
protected
procedure computeFields(); override;
procedure computeTime(); override;
public
function getDaysCount(): int; override; overload;
function getEpochStart(): long; override;
end;
OverflowException = class(RuntimeException);
NoSuchElementException = class(RuntimeException);
resourcestring
msgIllegalYearMonth = 'Недопустимые значения года и месяца';
msgHashtableOverflow = 'Таблица значений переполнена';
msgNoSuchElement = 'В перечислении больше не осталось элементов';
{%endregion}
implementation
{%region EmptyEnumerator }
function EmptyEnumerator.hasMoreElements(): boolean;
begin
result := false;
end;
function EmptyEnumerator.nextElement(): Value;
begin
raise NoSuchElementException.create('Enumeration.nextElement: ' + msgNoSuchElement);
end;
{%endregion}
{%region Hashtable.Entry }
constructor Hashtable.Entry.create(hash: long; key, value: pascalx.lang.Value; next: Entry);
begin
inherited create();
self.hash := hash;
self.key := key;
self.value := value;
self.next := next;
end;
{%endregion}
{%region Hashtable.ElementEnumerator }
constructor Hashtable.ElementEnumerator.create(keys: boolean; const table: Entry_Array1d);
begin
inherited create();
self.keys := keys;
self.index := system.length(table);
self.table := table;
end;
function Hashtable.ElementEnumerator.hasMoreElements(): boolean;
var
i: int;
e: Entry;
t: Entry_Array1d;
begin
if next <> nil then begin
result := true;
exit;
end;
t := table;
for i := index - 1 downto 0 do begin
e := t[i];
next := e;
if e <> nil then begin
index := i;
result := true;
exit;
end;
end;
index := -1;
result := false;
end;
function Hashtable.ElementEnumerator.nextElement(): Value;
var
i: int;
e: Entry;
t: Entry_Array1d;
begin
e := next;
if e = nil then begin
t := table;
i := index - 1;
while i >= 0 do begin
e := t[i];
if e <> nil then break;
dec(i);
end;
next := e;
if i < 0 then begin
index := -1;
end else begin
index := i;
end;
end;
if e = nil then begin
current := nil;
raise NoSuchElementException.create('Enumeration.nextElement: ' + msgNoSuchElement);
end;
current := e;
next := e.next;
if keys then begin
result := e.key;
exit;
end;
result := e.value;
end;
{%endregion}
{%region Hashtable.KeyEnumerator }
constructor Hashtable.KeyEnumerator.create(const table: Entry_Array1d);
begin
inherited create(true, table);
end;
function Hashtable.KeyEnumerator.value(): pascalx.lang.Value;
var
e: Entry;
begin
e := current;
if e = nil then begin
raise NoSuchElementException.create('MapEnumeration.value: ' + msgNoSuchElement);
end;
result := e.value;
end;
{%endregion}
{%region Hashtable }
procedure Hashtable.rehash();
var
i: int;
j: int;
nc: int;
oc: int;
e: Entry;
f: Entry;
nt: Entry_Array1d;
ot: Entry_Array1d;
begin
ot := table;
oc := system.length(ot);
if oc >= $40000000 then exit;
nc := (oc shl 1) + 1;
nt := Entry_Array1d(TObject_Array1d_create(nc));
table := nt;
factor := nc - intSar(nc, 2);
for i := oc - 1 downto 0 do begin
f := ot[i];
while f <> nil do begin
e := f;
j := int((e.hash and LONG_MAX_VALUE) mod nc);
f := f.next;
e.next := nt[j];
nt[j] := e;
end;
end;
end;
constructor Hashtable.create();
begin
create($1f);
end;
constructor Hashtable.create(initialCapacity: int);
var
i: int;
begin
inherited create();
if initialCapacity <= $1f then begin
initialCapacity := $1f;
end else begin
i := $20;
while (i > 0) and (i <= initialCapacity) do i := i shl 1;
initialCapacity := i - 1;
end;
self.factor := initialCapacity - intSar(initialCapacity, 2);
self.table := Entry_Array1d(TObject_Array1d_create(initialCapacity));
end;
destructor Hashtable.destroy;
var
i: int;
e: Entry;
f: Entry;
t: Entry_Array1d;
begin
t := table;
for i := system.length(t) - 1 downto 0 do begin
e := t[i];
while e <> nil do begin
f := e.next;
e.free();
e := f;
end;
end;
inherited destroy;
end;
function Hashtable.toString(): AnsiString;
var
i: int;
s: AnsiString;
e: MapEnumeration;
begin
s := '{';
e := KeyEnumerator.create(table);
for i := length - 1 downto 0 do begin
s := s + e.nextElement().toString() + '=' + e.value().toString();
if i > 0 then s := s + ', ';
end;
result := s + '}';
end;
function Hashtable.isEmpty(): boolean;
begin
result := length <= 0;
end;
function Hashtable.contains(value: pascalx.lang.Value): boolean;
var
i: int;
e: Entry;
t: Entry_Array1d;
begin
if value = nil then begin
raise NullPointerException.create('Hashtable.contains: ' + msgNullPointerArgument + 'value');
end;
t := table;
for i := system.length(table) - 1 downto 0 do begin
e := t[i];
while e <> nil do begin
if value.equals(e.value as TObject) then begin
result := true;
exit;
end;
e := e.next;
end;
end;
result := false;
end;
function Hashtable.containsKey(key: pascalx.lang.Value): boolean;
var
h: long;
e: Entry;
t: Entry_Array1d;
begin
if key = nil then begin
raise NullPointerException.create('Hashtable.containsKey: ' + msgNullPointerArgument + 'key');
end;
t := table;
h := key.getHashCode();
e := t[int((h and LONG_MAX_VALUE) mod system.length(t))];
while e <> nil do begin
if (h = e.hash) and key.equals(e.key as TObject) then begin
result := true;
exit;
end;
e := e.next;
end;
result := false;
end;
function Hashtable.size(): int;
begin
result := length;
end;
function Hashtable.put(key, value: pascalx.lang.Value): pascalx.lang.Value;
var
i: int;
len: int;
h: long;
e: Entry;
t: Entry_Array1d;
begin
if key = nil then begin
raise NullPointerException.create('Hashtable.put: ' + msgNullPointerArgument + 'key');
end;
if value = nil then begin
raise NullPointerException.create('Hashtable.put: ' + msgNullPointerArgument + 'value');
end;
if not(key is TObject) then begin
raise IllegalArgumentException.create('Hashtable.put: ' + msgIllegalArgument + 'key');
end;
if not(value is TObject) then begin
raise IllegalArgumentException.create('Hashtable.put: ' + msgIllegalArgument + 'value');
end;
t := table;
h := key.getHashCode();
i := int((h and LONG_MAX_VALUE) mod system.length(t));
e := t[i];
while e <> nil do begin
if (h = e.hash) and key.equals(e.key as TObject) then begin
result := e.value;
e.value := value;
exit;
end;
e := e.next;
end;
len := length;
if len = INT_MAX_VALUE then begin
raise OverflowException.create('Hashtable.put: ' + msgHashtableOverflow);
end;
if len >= factor then begin
rehash();
t := table;
i := int((h and LONG_MAX_VALUE) mod system.length(t));
end;
t[i] := Entry.create(h, key, value, t[i]);
length := len + 1;
result := nil;
end;
function Hashtable.remove(key: pascalx.lang.Value): pascalx.lang.Value;
var
i: int;
h: long;
e: Entry;
f: Entry;
t: Entry_Array1d;
begin
if key = nil then begin
result := nil;
exit;
end;
f := nil;
t := table;
h := key.getHashCode();
i := int((h and LONG_MAX_VALUE) mod system.length(t));
e := t[i];
while e <> nil do begin
if (h <> e.hash) or not key.equals(e.key as TObject) then begin
f := e;
e := e.next;
continue;
end;
if f <> nil then begin
f.next := e.next;
end else begin
t[i] := e.next;
end;
dec(length);
result := e.value;
e.free();
exit;
end;
result := nil;
end;
function Hashtable.get(key: pascalx.lang.Value): pascalx.lang.Value;
var
h: long;
e: Entry;
t: Entry_Array1d;
begin
if key = nil then begin
result := nil;
exit;
end;
t := table;
h := key.getHashCode();
e := t[int((h and LONG_MAX_VALUE) mod system.length(t))];
while e <> nil do begin
if (h = e.hash) and key.equals(e.key as TObject) then begin
result := e.value;
exit;
end;
e := e.next;
end;
result := nil;
end;
function Hashtable.elements(): Enumeration;
begin
result := ElementEnumerator.create(false, table);
end;
function Hashtable.keys(): Enumeration;
begin
result := KeyEnumerator.create(table);
end;
procedure Hashtable.clear();
var
i: int;
e: Entry;
f: Entry;
t: Entry_Array1d;
begin
t := table;
length := 0;
for i := system.length(t) - 1 downto 0 do begin
e := t[i];
t[i] := nil;
while e <> nil do begin
f := e.next;
e.free();
e := f;
end;
end;
end;
{%endregion}
{%region Vector.ElementEnumerator }
constructor Vector.ElementEnumerator.create(owner: Vector);
begin
inherited create();
self.owner := owner;
end;
function Vector.ElementEnumerator.hasMoreElements(): boolean;
var
index: int;
begin
index := self.index;
result := (index >= 0) and (index < owner.length);
end;
function Vector.ElementEnumerator.nextElement(): Value;
var
index: int;
owner: Vector;
current: Value;
begin
index := self.index;
owner := self.owner;
if (index < 0) or (index >= owner.length) then begin
raise NoSuchElementException.create('Enumeration.nextElement: ' + msgNoSuchElement);
end;
current := owner.data[index];
self.index := index + 1;
result := current;
end;
{%endregion}
{%region Vector }
constructor Vector.create();
begin
create($1f);
end;
constructor Vector.create(initialCapacity: int);
var
i: int;
begin
inherited create();
if initialCapacity <= $1f then begin
initialCapacity := $1f;
end else begin
i := $20;
while (i > 0) and (i <= initialCapacity) do i := i shl 1;
initialCapacity := i - 1;
end;
self.data := Value_Array1d(IUnknown_Array1d_create(initialCapacity));
end;
function Vector.toString(): AnsiString;
var
i: int;
lim: int;
s: AnsiString;
e: Enumeration;
begin
s := '(';
e := ElementEnumerator.create(self);
lim := length - 1;
for i := 0 to lim do begin
s := s + e.nextElement().toString();
if i < lim then s := s + ', ';
end;
result := s + ')';
end;
function Vector.isEmpty(): boolean;
begin
result := length <= 0;
end;
function Vector.contains(element: Value): boolean;
var
i: int;
len: int;
elements: Value_Array1d;
begin
if element = nil then begin
result := arrayfindeqfInterface(data, 0, length, nil) >= 0;
exit;
end;
len := length;
elements := data;
for i := 0 to len - 1 do begin
if element.equals(elements[i] as TObject) then begin
result := true;
exit;
end;
end;
result := false;
end;
function Vector.indexOf(element: Value): int;
var
i: int;
len: int;
elements: Value_Array1d;
begin
if element = nil then begin
result := arrayfindeqfInterface(data, 0, length, nil);
exit;
end;
len := length;
elements := data;
for i := 0 to len - 1 do begin
if element.equals(elements[i] as TObject) then begin
result := i;
exit;
end;
end;
result := -1;
end;
function Vector.size(): int;
begin
result := length;
end;
function Vector.elements(): Enumeration;
begin
result := ElementEnumerator.create(self);
end;
function Vector.lastElement(): Value;
var
len: int;
begin
len := length;
if len <= 0 then begin
raise IndexOutOfBoundsException.create('Vector.lastElement: ' + msgIndexOutOfBounds);
end;
result := data[len - 1];
end;
function Vector.firstElement(): Value;
begin
if length <= 0 then begin
raise IndexOutOfBoundsException.create('Vector.firstElement: ' + msgIndexOutOfBounds);
end;
result := data[0];
end;
function Vector.elementAt(index: int): Value;
begin
if (index < 0) or (index >= length) then begin
raise IndexOutOfBoundsException.create('Vector.elementAt: ' + msgIndexOutOfBounds);
end;
result := data[index];
end;
function Vector.setElementAt(index: int; element: Value): Value;
var
prev: Value;
elements: Value_Array1d;
begin
if (index < 0) or (index >= length) then begin
raise IndexOutOfBoundsException.create('Vector.setElementAt: ' + msgIndexOutOfBounds);
end;
if (element <> nil) and not(element is TObject) then begin
raise IllegalArgumentException.create('Vector.setElementAt: ' + msgIllegalArgument + 'element');
end;
elements := data;
prev := elements[index];
elements[index] := element;
result := prev;
end;
function Vector.delete(index: int): Value;
var
len: int;
prev: Value;
elements: Value_Array1d;
begin
len := length - 1;
if (index < 0) or (index > len) then begin
raise IndexOutOfBoundsException.create('Vector.delete: ' + msgIndexOutOfBounds);
end;
elements := data;
prev := elements[index];
arraycopyInterfaces(elements, index + 1, elements, index, len - index);
elements[len] := nil;
length := len;
result := prev;
end;
function Vector.remove(element: Value): boolean;
var
i: int;
len: int;
index: int;
elements: Value_Array1d;
begin
index := -1;
len := length - 1;
elements := data;
if element = nil then begin
for i := 0 to len do begin
if elements[i] = nil then begin
index := i;
break;
end;
end;
end else begin
for i := 0 to len do begin
if element.equals(elements[i] as TObject) then begin
index := i;
break;
end;
end;
end;
if index < 0 then begin
result := false;
exit;
end;
arraycopyInterfaces(elements, index + 1, elements, index, len - index);
elements[len] := nil;
length := len;
result := true;
end;
procedure Vector.insert(index: int; element: Value);
var
len: int;
capa: int;
elements: Value_Array1d;
newelements: Value_Array1d;
begin
len := length;
if (index < 0) or (index > len) or (len = INT_MAX_VALUE) then begin
raise IndexOutOfBoundsException.create('Vector.insert: ' + msgIndexOutOfBounds);
end;
if (element <> nil) and not(element is TObject) then begin
raise IllegalArgumentException.create('Vector.insert: ' + msgIllegalArgument + 'element');
end;
elements := data;
capa := system.length(elements);
if len = capa then begin
newelements := Value_Array1d(IUnknown_Array1d_create((len shl 1) + 1));
arraycopyInterfaces(elements, 0, newelements, 0, len);
elements := newelements;
data := newelements;
end;
arraycopyInterfaces(elements, index, elements, index + 1, len - index);
elements[index] := element;
length := len + 1;
end;
procedure Vector.append(element: Value);
var
len: int;
capa: int;
elements: Value_Array1d;
newelements: Value_Array1d;
begin
len := length;
if len = INT_MAX_VALUE then begin
raise IndexOutOfBoundsException.create('Vector.append: ' + msgIndexOutOfBounds);
end;
if (element <> nil) and not(element is TObject) then begin
raise IllegalArgumentException.create('Vector.append: ' + msgIllegalArgument + 'element');
end;
elements := data;
capa := system.length(elements);
if len = capa then begin
newelements := Value_Array1d(IUnknown_Array1d_create((len shl 1) + 1));
arraycopyInterfaces(elements, 0, newelements, 0, len);
elements := newelements;
data := newelements;
end;
elements[len] := element;
length := len + 1;
end;
procedure Vector.clear();
begin
arrayfillInterfaces(data, 0, length, nil);
length := 0;
end;
{%endregion}
{%region CustomCalendar }
procedure CustomCalendar.updateHour12();
var
hour: int;
fields: int_Array1d;
begin
fields := self.fields;
hour := fields[FLD_HOUR];
if hour >= 12 then begin
dec(hour, 12);
fields[FLD_AMPM] := PM;
end else begin
fields[FLD_AMPM] := AM;
end;
if hour = 0 then hour := 12;
fields[FLD_HOUR12] := hour;
end;
procedure CustomCalendar.updateHour24();
var
hour: int;
fields: int_Array1d;
begin
fields := self.fields;
hour := fields[FLD_HOUR12];
if hour = 12 then hour := 0;
fields[FLD_HOUR] := fields[FLD_AMPM] * 12 + hour;
end;
constructor CustomCalendar.create();
var
offset: int;
fields: int_Array1d;
zone: TTimeZoneInformation;
time: TSystemTime;
begin
inherited create();
initialize(zone);
initialize(time);
getTimeZoneInformation(zone);
getSystemTime(time);
offset := -60000 * zone.bias;
fields := int_Array1d_create(16);
fields[FLD_YEAR] := time.year;
fields[FLD_MONTH] := time.month;
fields[FLD_DAY] := time.day;
fields[FLD_HOUR] := time.hour;
fields[FLD_MINUTE] := time.minute;
fields[FLD_SECOND] := time.second;
fields[FLD_MILLISECOND] := time.millisecond;
self.offsetInMillis := offset;
self.fields := fields;
updateHour12();
computeTime();
end;
function CustomCalendar.equals(anot: TObject): boolean;
begin
result := (anot = self) or (anot is CustomCalendar) and (CustomCalendar(anot).timeInMillis = timeInMillis);
end;
function CustomCalendar.getHashCode(): long;
begin
result := timeInMillis;
end;
function CustomCalendar.after(anot: Calendar): boolean;
begin
if anot = nil then begin
raise NullPointerException.create('CustomCalendar.after: ' + msgNullPointerArgument + 'anot');
end;
result := timeInMillis > anot.time;
end;
function CustomCalendar.before(anot: Calendar): boolean;
begin
if anot = nil then begin
raise NullPointerException.create('CustomCalendar.before: ' + msgNullPointerArgument + 'anot');
end;
result := timeInMillis < anot.time;
end;
function CustomCalendar.getField(field: int): int;
begin
if (field < 0) or (field >= 16) then begin
raise IllegalArgumentException.create('CustomCalendar.getField: ' + msgIllegalArgument + 'field');
end;
result := fields[field];
end;
function CustomCalendar.getOffset(): int;
begin
result := offsetInMillis;
end;
function CustomCalendar.getTime(): long;
begin
result := timeInMillis;
end;
procedure CustomCalendar.setField(field, value: int);
var
fields: int_Array1d;
begin
if (field < 0) or (field >= 16) or (field = FLD_WEEKDAY) then begin
raise IllegalArgumentException.create('CustomCalendar.setField: ' + msgIllegalArgument + 'field');
end;
fields := self.fields;
if fields[field] = value then exit;
fields[field] := value;
case field of
FLD_AMPM,
FLD_HOUR12:
updateHour24();
FLD_HOUR:
updateHour12();
end;
computeTime();
end;
procedure CustomCalendar.setOffset(offset: int);
begin
if self.offsetInMillis = offset then exit;
self.offsetInMillis := offset;
computeFields();
updateHour12();
end;
procedure CustomCalendar.setTime(time: long);
begin
if self.timeInMillis = time then exit;
self.timeInMillis := time;
computeFields();
updateHour12();
end;
{%endregion}
{%region GregorianCalendar }
class function GregorianCalendar.getDaysCount(year, month: int): int;
const
DAYS: array[boolean, 1..12] of byte = (
( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ),
( 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 )
);
var
period: int;
begin
if year <= 0 then begin
raise IllegalStateException.create('GregorianCalendar.getDaysCount: ' + msgIllegalYearMonth);
end;
if (month < 1) or (month > 12) then begin
raise IllegalStateException.create('GregorianCalendar.getDaysCount: ' + msgIllegalYearMonth);
end;
if year mod 100 = 0 then begin
period := 400;
end else begin
period := 4;
end;
result := DAYS[year mod period = 0, month];
end;
procedure GregorianCalendar.computeFields();
var
year: long;
month: long;
day: long;
daysPerMonth: long;
weekday: long;
hour: long;
minute: long;
second: long;
millisecond: long;
millis: long;
days: long;
time: long;
fields: int_Array1d;
begin
time := timeInMillis + offsetInMillis;
days := time div 86400000;
millis := time mod 86400000;
weekday := (days + 1) mod 7;
year := 400 * (days div 146097);
days := days mod 146097;
if days >= 146096 then begin
inc(year, 399);
days := 365;
end else begin
inc(year, 100 * (days div 36524));
days := days mod 36524;
inc(year, 4 * (days div 1461));
days := days mod 1461;
if days >= 1460 then begin
inc(year, 3);
days := 365;
end else begin
inc(year, days div 365);
days := days mod 365;
end;
end;
inc(year);
month := 1;
repeat
daysPerMonth := getDaysCount(int(year), int(month));
if days < daysPerMonth then break;
dec(days, daysPerMonth);
inc(month);
until false;
day := days + 1;
hour := millis div 3600000;
millis := millis mod 3600000;
minute := millis div 60000;
millis := millis mod 60000;
second := millis div 1000;
millisecond := millis mod 1000;
fields := self.fields;
fields[FLD_YEAR] := int(year);
fields[FLD_MONTH] := int(month);
fields[FLD_DAY] := int(day);
fields[FLD_WEEKDAY] := int(weekday);
fields[FLD_HOUR] := int(hour);
fields[FLD_MINUTE] := int(minute);
fields[FLD_SECOND] := int(second);
fields[FLD_MILLISECOND] := int(millisecond);
end;
procedure GregorianCalendar.computeTime();
var
i: int;
srcyear: long;
year: long;
month: long;
day: long;
hour: long;
minute: long;
second: long;
millisecond: long;
days: long;
fields: int_Array1d;
begin
fields := self.fields;
year := fields[FLD_YEAR];
month := fields[FLD_MONTH];
if (year <= 0) or (month < 1) or (month > 12) then begin
raise IllegalStateException.create('GregorianCalendar.setField: ' + msgIllegalYearMonth);
end;
day := fields[FLD_DAY];
hour := fields[FLD_HOUR];
minute := fields[FLD_MINUTE];
second := fields[FLD_SECOND];
millisecond := fields[FLD_MILLISECOND];
srcyear := year;
dec(year);
days := 146097 * (year div 400);
year := year mod 400;
inc(days, 36524 * (year div 100));
year := year mod 100;
inc(days, 1461 * (year div 4) + 365 * (year mod 4) + (day - 1));
for i := 1 to int(month - 1) do begin
inc(days, getDaysCount(int(srcyear), i));
end;
fields[FLD_WEEKDAY] := int((days + 1) mod 7);
timeInMillis := 86400000 * days + 3600000 * hour + 60000 * minute + 1000 * second + millisecond - offsetInMillis;
end;
function GregorianCalendar.getDaysCount(): int;
begin
result := getDaysCount(year, month);
end;
function GregorianCalendar.getEpochStart(): long;
begin
result := -long(offsetInMillis);
end;
{%endregion}
initialization
classInfoAdd([
typeInfo(EmptyEnumerator),
typeInfo(Calendar),
typeInfo(CustomCalendar),
typeInfo(GregorianCalendar)
]);
end.
