Compare commits
64
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
6855aaa799 | ||
|
|
a6482d22e2 | ||
|
|
577976dba7 | ||
|
|
68a780a3bf | ||
|
|
9931564ea5 | ||
|
|
26cbce7e81 | ||
|
|
ed80b6476b | ||
|
|
e5fd7b2a2a | ||
|
|
81f2a20b3c | ||
|
|
71f7b946a6 | ||
|
|
83a8197fe9 | ||
|
|
153e32d613 | ||
|
|
1b580435fc | ||
|
|
f185b8c243 | ||
|
|
991ad56e9c | ||
|
|
371c0aec0b | ||
|
|
2f35271c9d | ||
|
|
3cf665c0f5 | ||
|
|
ef90044383 | ||
|
|
5fb141ae40 | ||
|
|
da19723bdc | ||
|
|
d1b1eb61ee | ||
|
|
bacdc67e69 | ||
|
|
fc3ea33681 | ||
|
|
86fa45a2d2 | ||
|
|
e3d338650f | ||
|
|
88f8e603d9 | ||
|
|
2c4913d479 | ||
|
|
3681b8fdb5 | ||
|
|
9b3dad29d7 | ||
|
|
743a4fee3d | ||
|
|
35b9322dc3 | ||
|
|
a194fa9779 | ||
|
|
b8ef30620b | ||
|
|
46c8ea3458 | ||
|
|
10673db0ce | ||
|
|
14c5c590e0 | ||
|
|
533ca10a79 | ||
|
|
916a8e7276 | ||
|
|
baa4ae5c90 | ||
|
|
ae8248cd39 | ||
|
|
2293dabf3f | ||
|
|
90c1f734c0 | ||
|
|
336cf18ae8 | ||
|
|
08d9bb4c7c | ||
|
|
b20173ba38 | ||
|
|
12edf1f533 | ||
|
|
9e607ddb5a | ||
|
|
33602d0a11 | ||
|
|
4b7fc1bb11 | ||
|
|
e72c67b399 | ||
|
|
b81fc4d41d | ||
|
|
bfa8e4f4dc | ||
|
|
ed0399c961 | ||
|
|
68b7104563 | ||
|
|
6c2d2971a2 | ||
|
|
a592eefcbe | ||
|
|
2fce52b2ae | ||
|
|
750bed46fd | ||
|
|
d48588c89c | ||
|
|
d5552e2fbe | ||
|
|
0cdd360369 | ||
|
|
449ce271b1 | ||
|
|
9011c35db1 |
+37
-2
@@ -87,6 +87,15 @@ slowing its clock by a tiny fraction for some minutes until it is
|
||||
back in sync with UTC; its data model does not represent minutes that
|
||||
have 59 or 61 seconds.
|
||||
.TP
|
||||
\fI\-now\fR
|
||||
Instead of \fItimeVal\fR a non-integer option \fI\-now\fR can be used as
|
||||
replacement for today, which is simply interpolated to the runt-time as value
|
||||
of \fBclock seconds\fR. For example:
|
||||
.sp
|
||||
\fBclock format -now -f %a; # current day of the week\fR
|
||||
.sp
|
||||
\fBclock add -now 1 month; # next month\fR
|
||||
.TP
|
||||
\fIunit\fR
|
||||
One of the words, \fBseconds\fR, \fBminutes\fR, \fBhours\fR,
|
||||
\fBdays\fR, \fBweeks\fR, \fBmonths\fR, or \fByears\fR, or
|
||||
@@ -528,6 +537,12 @@ abbreviation appropriate to the current locale, and uses it to fix
|
||||
whether \fB%Y\fR refers to years before or after Year 1 of the
|
||||
Common Era.
|
||||
.TP
|
||||
\fB%Es\fR
|
||||
This affects similar to \fB%s\fR, but in opposition to \fB%s\fR it parses
|
||||
or formats local seconds (not the posix seconds).
|
||||
Because \fB%s\fR has the same precedence as \fB%s\fR (uniquely determines
|
||||
a point in time), it overrides all other input formats.
|
||||
.TP
|
||||
\fB%Ex\fR
|
||||
On output, produces a locale-dependent representation of the date
|
||||
in the locale's alternative calendar. On input, matches
|
||||
@@ -722,13 +737,15 @@ week number \fB%V\fR; programs should use \fB%G\fR for that purpose.
|
||||
On output, produces the current time zone, expressed in hours and
|
||||
minutes east (+hhmm) or west (\-hhmm) of Greenwich. On input, accepts a
|
||||
time zone specifier (see \fBTIME ZONES\fR below) that will be used to
|
||||
determine the time zone.
|
||||
determine the time zone (this token is optionally applicable on input,
|
||||
so the value is not mandatory and can be missing in input).
|
||||
.TP
|
||||
\fB%Z\fR
|
||||
On output, produces the current time zone's name, possibly
|
||||
translated to the given locale. On input, accepts a time zone
|
||||
specifier (see \fBTIME ZONES\fR below) that will be used to determine the
|
||||
time zone. This option should, in general, be used on input only when
|
||||
time zone (token is also like \fB%z\fR optionally applicable on input).
|
||||
This option should, in general, be used on input only when
|
||||
parsing RFC822 dates. Other uses are fraught with ambiguity; for
|
||||
instance, the string \fBBST\fR may represent British Summer Time or
|
||||
Brazilian Standard Time. It is recommended that date/time strings for
|
||||
@@ -927,6 +944,24 @@ used. Finally, a correction is applied so that the correct hour of
|
||||
the day is produced after allowing for daylight savings time
|
||||
differences and the correct date is given when going from the end
|
||||
of a long month to a short month.
|
||||
.PP
|
||||
The precedence of the applying of single tokens resp. which sequence will be
|
||||
used by calculating of the time is complex, e. g. heavily dependent on the
|
||||
precision of type of the token.
|
||||
.sp
|
||||
In example below the second date-string contains "next January", therefore
|
||||
it results in next year but in January. And third date-string besides "January"
|
||||
contains also additionally "Fri", so it results in the nearest Friday.
|
||||
Thus both win before "385 days" resp. make it more precise, because of higher
|
||||
precision of this token types.
|
||||
.CS
|
||||
% clock format [clock scan "5 years 18 months 385 days" -base 0 -gmt 1] -gmt 1
|
||||
Thu Jul 21 00:00:00 GMT 1977
|
||||
% clock format [clock scan "5 years 18 months 385 days next January" -base 0 -gmt 1] -gmt 1
|
||||
Sat Jan 21 00:00:00 GMT 1978
|
||||
% clock format [clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1] -gmt 1
|
||||
Fri Jan 27 00:00:00 GMT 1978
|
||||
.CE
|
||||
.SH "SEE ALSO"
|
||||
msgcat(n)
|
||||
.SH KEYWORDS
|
||||
|
||||
+114
@@ -0,0 +1,114 @@
|
||||
'\"
|
||||
'\" Copyright (c) 2005 Sergey Brester aka sebres.
|
||||
'\"
|
||||
'\" See the file "license.terms" for information on usage and redistribution
|
||||
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
'\"
|
||||
.TH timerate n "" Tcl "Tcl Built-In Commands"
|
||||
.so man.macros
|
||||
.BS
|
||||
'\" Note: do not modify the .SH NAME line immediately below!
|
||||
.SH NAME
|
||||
timerate \- Time-related execution resp. performance measurement of a script
|
||||
.SH SYNOPSIS
|
||||
\fBtimerate \fIscript\fR \fI?time?\fR
|
||||
.sp
|
||||
\fBtimerate \fI?-direct?\fR \fI?-overhead double?\fR \fIscript\fR \fI?time?\fR
|
||||
.sp
|
||||
\fBtimerate \fI?-calibrate?\fR \fI?-direct?\fR \fIscript\fR \fI?time?\fR
|
||||
.BE
|
||||
.SH DESCRIPTION
|
||||
.PP
|
||||
The first and second form will evaluate \fIscript\fR until the interval
|
||||
\fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second)
|
||||
if \fItime\fR is not specified.
|
||||
.sp
|
||||
It will then return a canonical tcl-list of the form
|
||||
.PP
|
||||
.CS
|
||||
\f0.095977 µs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR
|
||||
.CE
|
||||
.PP
|
||||
which indicates:
|
||||
.IP \(bu
|
||||
the average amount of time required per iteration, in microseconds (lindex $result 0)
|
||||
.IP \(bu
|
||||
the count how many times it was executed (lindex $result 2)
|
||||
.IP \(bu
|
||||
the estimated rate per second (lindex $result 4)
|
||||
.IP \(bu
|
||||
the estimated real execution time without measurement overhead (lindex $result 6)
|
||||
.PP
|
||||
Time is measured in elapsed time using heighest timer resolution as possible, not CPU time.
|
||||
This command may be used to provide information as to how well the script or a tcl-command
|
||||
is performing and can help determine bottlenecks and fine-tune application performance.
|
||||
.PP
|
||||
\fI-calibrate\fR
|
||||
.
|
||||
To measure very fast scripts as exact as posible the calibration process
|
||||
may be required.
|
||||
|
||||
This parameter used to calibrate \fBtimerate\fR calculating the estimated overhead
|
||||
of given \fIscript\fR as default overhead for further execution of \fBtimerate\fR.
|
||||
It can take up to 10 seconds if parameter \fItime\fR is not specified.
|
||||
.PP
|
||||
\fI-overhead double\fR
|
||||
.
|
||||
This parameter used to supply the measurement overhead of single iteration
|
||||
(in microseconds) that should be ignored during whole evaluation process.
|
||||
.PP
|
||||
\fI-direct\fR
|
||||
.
|
||||
Causes direct execution per iteration (not compiled variant of evaluation used).
|
||||
.PP
|
||||
In opposition to \fBtime\fR the execution limited here by fixed time instead of
|
||||
repetition count.
|
||||
Additionally the compiled variant of the script will be used during whole evaluation
|
||||
(as if it were part of a compiled \fBproc\fR), if parameter \fI-direct\fR is not specified.
|
||||
Therefore it provides more precise results and prevents very long execution time
|
||||
by slow scripts resp. scripts with unknown speed.
|
||||
|
||||
.SH EXAMPLE
|
||||
Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including
|
||||
operations on variable \fIi\fR) to count to a ten:
|
||||
.PP
|
||||
.CS
|
||||
# calibrate:
|
||||
timerate -calibrate {}
|
||||
# measure:
|
||||
timerate { for {set i 0} {$i<10} {incr i} {} } 5000
|
||||
.CE
|
||||
.PP
|
||||
Estimate how fast it takes for a simple Tcl \fBfor\fR loop only (ignoring the
|
||||
overhead for operations on variable \fIi\fR) to count to a ten:
|
||||
.PP
|
||||
.CS
|
||||
# calibrate for overhead of variable operations:
|
||||
set i 0; timerate -calibrate {expr {$i<10}; incr i} 1000
|
||||
# measure:
|
||||
timerate { for {set i 0} {$i<10} {incr i} {} } 5000
|
||||
.CE
|
||||
.PP
|
||||
Estimate the rate of calculating the hour using \fBclock format\fR only, ignoring
|
||||
overhead of the rest, without measurement how fast it takes for a whole script:
|
||||
.PP
|
||||
.CS
|
||||
# calibrate:
|
||||
timerate -calibrate {}
|
||||
# estimate overhead:
|
||||
set tm 0
|
||||
set ovh [lindex [timerate { incr tm [expr {24*60*60}] }] 0]
|
||||
# measure using esimated overhead:
|
||||
set tm 0
|
||||
timerate -overhead $ovh {
|
||||
clock format $tm -format %H
|
||||
incr tm [expr {24*60*60}]; # overhead for this is ignored
|
||||
} 5000
|
||||
.CE
|
||||
.SH "SEE ALSO"
|
||||
time(n)
|
||||
.SH KEYWORDS
|
||||
script, timerate, time
|
||||
.\" Local Variables:
|
||||
.\" mode: nroff
|
||||
.\" End:
|
||||
@@ -285,6 +285,9 @@ static const CmdInfo builtInCmds[] = {
|
||||
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
|
||||
{"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
|
||||
{"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
|
||||
#ifdef TCL_TIMERATE
|
||||
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
|
||||
#endif
|
||||
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
|
||||
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
|
||||
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
|
||||
@@ -845,6 +848,10 @@ Tcl_CreateInterp(void)
|
||||
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
|
||||
NRCoroInjectObjCmd, NULL, NULL);
|
||||
|
||||
/* Adding the timerate (unsupported) command */
|
||||
Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate",
|
||||
Tcl_TimeRateObjCmd, NULL, NULL);
|
||||
|
||||
#ifdef USE_DTRACE
|
||||
/*
|
||||
* Register the tcl::dtrace command.
|
||||
|
||||
+2828
-317
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -17,6 +17,7 @@
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclCompile.h"
|
||||
#include "tclRegexp.h"
|
||||
#include "tclStringTrim.h"
|
||||
|
||||
@@ -4247,6 +4248,351 @@ Tcl_TimeObjCmd(
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* Tcl_TimeRateObjCmd --
|
||||
*
|
||||
* This object-based procedure is invoked to process the "timerate" Tcl
|
||||
* command.
|
||||
* This is similar to command "time", except the execution limited by
|
||||
* given time (in milliseconds) instead of repetition count.
|
||||
*
|
||||
* Example:
|
||||
* timerate {after 5} 1000 ; # equivalent for `time {after 5} [expr 1000/5]`
|
||||
*
|
||||
* Results:
|
||||
* A standard Tcl object result.
|
||||
*
|
||||
* Side effects:
|
||||
* See the user documentation.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
int
|
||||
Tcl_TimeRateObjCmd(
|
||||
ClientData dummy, /* Not used. */
|
||||
Tcl_Interp *interp, /* Current interpreter. */
|
||||
int objc, /* Number of arguments. */
|
||||
Tcl_Obj *const objv[]) /* Argument objects. */
|
||||
{
|
||||
static double measureOverhead = 0; /* global measure-overhead */
|
||||
double overhead = -1; /* given measure-overhead */
|
||||
register Tcl_Obj *objPtr;
|
||||
register int result, i;
|
||||
Tcl_Obj *calibrate = NULL, *direct = NULL;
|
||||
Tcl_WideInt count = 0; /* Holds repetition count */
|
||||
Tcl_WideInt maxms = -0x7FFFFFFFFFFFFFFFL;
|
||||
/* Maximal running time (in milliseconds) */
|
||||
Tcl_WideInt threshold = 1; /* Current threshold for check time (faster
|
||||
* repeat count without time check) */
|
||||
Tcl_WideInt maxIterTm = 1; /* Max time of some iteration as max threshold
|
||||
* additionally avoid divide to zero (never < 1) */
|
||||
register Tcl_WideInt start, middle, stop;
|
||||
#ifndef TCL_WIDE_CLICKS
|
||||
Tcl_Time now;
|
||||
#endif
|
||||
|
||||
static const char *const options[] = {
|
||||
"-direct", "-overhead", "-calibrate", "--", NULL
|
||||
};
|
||||
enum options {
|
||||
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
|
||||
};
|
||||
|
||||
NRE_callback *rootPtr;
|
||||
ByteCode *codePtr = NULL;
|
||||
|
||||
for (i = 1; i < objc - 1; i++) {
|
||||
int index;
|
||||
if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
|
||||
&index) != TCL_OK) {
|
||||
break;
|
||||
}
|
||||
if (index == TMRT_LAST) {
|
||||
i++;
|
||||
break;
|
||||
}
|
||||
switch (index) {
|
||||
case TMRT_EV_DIRECT:
|
||||
direct = objv[i];
|
||||
break;
|
||||
case TMRT_OVERHEAD:
|
||||
if (++i >= objc - 1) {
|
||||
goto usage;
|
||||
}
|
||||
if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
break;
|
||||
case TMRT_CALIBRATE:
|
||||
calibrate = objv[i];
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (i >= objc || i < objc-2) {
|
||||
usage:
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "?-direct? ?-calibrate? ?-overhead double? command ?time?");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
objPtr = objv[i++];
|
||||
if (i < objc) {
|
||||
result = TclGetWideIntFromObj(interp, objv[i], &maxms);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
}
|
||||
|
||||
/* if calibrate */
|
||||
if (calibrate) {
|
||||
|
||||
/* if no time specified for the calibration */
|
||||
if (maxms == -0x7FFFFFFFFFFFFFFFL) {
|
||||
Tcl_Obj *clobjv[6];
|
||||
Tcl_WideInt maxCalTime = 5000;
|
||||
double lastMeasureOverhead = measureOverhead;
|
||||
|
||||
clobjv[0] = objv[0];
|
||||
i = 1;
|
||||
if (direct) {
|
||||
clobjv[i++] = direct;
|
||||
}
|
||||
clobjv[i++] = objPtr;
|
||||
|
||||
/* reset last measurement overhead */
|
||||
measureOverhead = (double)0;
|
||||
|
||||
/* self-call with 100 milliseconds to warm-up,
|
||||
* before entering the calibration cycle */
|
||||
TclNewLongObj(clobjv[i], 100);
|
||||
Tcl_IncrRefCount(clobjv[i]);
|
||||
result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
|
||||
Tcl_DecrRefCount(clobjv[i]);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
|
||||
i--;
|
||||
clobjv[i++] = calibrate;
|
||||
clobjv[i++] = objPtr;
|
||||
|
||||
/* set last measurement overhead to max */
|
||||
measureOverhead = (double)0x7FFFFFFFFFFFFFFFL;
|
||||
|
||||
/* calibration cycle until it'll be preciser */
|
||||
maxms = -1000;
|
||||
do {
|
||||
lastMeasureOverhead = measureOverhead;
|
||||
TclNewLongObj(clobjv[i], (int)maxms);
|
||||
Tcl_IncrRefCount(clobjv[i]);
|
||||
result = Tcl_TimeRateObjCmd(dummy, interp, i+1, clobjv);
|
||||
Tcl_DecrRefCount(clobjv[i]);
|
||||
if (result != TCL_OK) {
|
||||
return result;
|
||||
}
|
||||
maxCalTime += maxms;
|
||||
/* increase maxms for preciser calibration */
|
||||
maxms -= (-maxms / 4);
|
||||
/* as long as new value more as 0.05% better */
|
||||
} while ( (measureOverhead >= lastMeasureOverhead
|
||||
|| measureOverhead / lastMeasureOverhead <= 0.9995)
|
||||
&& maxCalTime > 0
|
||||
);
|
||||
|
||||
return result;
|
||||
}
|
||||
if (maxms == 0) {
|
||||
/* reset last measurement overhead */
|
||||
measureOverhead = 0;
|
||||
Tcl_SetObjResult(interp, Tcl_NewLongObj(0));
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
/* if time is negative - make current overhead more precise */
|
||||
if (maxms > 0) {
|
||||
/* set last measurement overhead to max */
|
||||
measureOverhead = (double)0x7FFFFFFFFFFFFFFFL;
|
||||
} else {
|
||||
maxms = -maxms;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if (maxms == -0x7FFFFFFFFFFFFFFFL) {
|
||||
maxms = 1000;
|
||||
}
|
||||
if (overhead == -1) {
|
||||
overhead = measureOverhead;
|
||||
}
|
||||
|
||||
/* be sure that resetting of result will not smudge the further measurement */
|
||||
Tcl_ResetResult(interp);
|
||||
|
||||
/* compile object */
|
||||
if (!direct) {
|
||||
if (TclInterpReady(interp) != TCL_OK) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
codePtr = TclCompileObj(interp, objPtr, NULL, 0);
|
||||
codePtr->refCount++;
|
||||
}
|
||||
|
||||
/* get start and stop time */
|
||||
#ifdef TCL_WIDE_CLICKS
|
||||
start = middle = TclpGetWideClicks();
|
||||
/* time to stop execution (in wide clicks) */
|
||||
stop = start + (maxms * 1000 / TclpWideClickInMicrosec());
|
||||
#else
|
||||
Tcl_GetTime(&now);
|
||||
start = now.sec; start *= 1000000; start += now.usec;
|
||||
middle = start;
|
||||
/* time to stop execution (in microsecs) */
|
||||
stop = start + maxms * 1000;
|
||||
#endif
|
||||
|
||||
/* start measurement */
|
||||
while (1) {
|
||||
/* eval single iteration */
|
||||
count++;
|
||||
|
||||
if (!direct) {
|
||||
/* precompiled */
|
||||
rootPtr = TOP_CB(interp);
|
||||
result = TclNRExecuteByteCode(interp, codePtr);
|
||||
result = TclNRRunCallbacks(interp, result, rootPtr);
|
||||
} else {
|
||||
/* eval */
|
||||
result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
|
||||
}
|
||||
if (result != TCL_OK) {
|
||||
goto done;
|
||||
}
|
||||
|
||||
/* don't check time up to threshold */
|
||||
if (--threshold > 0) continue;
|
||||
|
||||
/* check stop time reached, estimate new threshold */
|
||||
#ifdef TCL_WIDE_CLICKS
|
||||
middle = TclpGetWideClicks();
|
||||
#else
|
||||
Tcl_GetTime(&now);
|
||||
middle = now.sec; middle *= 1000000; middle += now.usec;
|
||||
#endif
|
||||
if (middle >= stop) {
|
||||
break;
|
||||
}
|
||||
|
||||
/* don't calculate threshold by few iterations, because sometimes
|
||||
* first iteration(s) can be too fast (cached, delayed clean up, etc) */
|
||||
if (count < 10) {
|
||||
threshold = 1; continue;
|
||||
}
|
||||
|
||||
/* average iteration time in microsecs */
|
||||
threshold = (middle - start) / count;
|
||||
if (threshold > maxIterTm) {
|
||||
maxIterTm = threshold;
|
||||
}
|
||||
/* as relation between remaining time and time since last check */
|
||||
threshold = ((stop - middle) / maxIterTm) / 4;
|
||||
if (threshold > 100000) { /* fix for too large threshold */
|
||||
threshold = 100000;
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
Tcl_Obj *objarr[8], **objs = objarr;
|
||||
Tcl_WideInt val;
|
||||
const char *fmt;
|
||||
|
||||
middle -= start; /* execution time in microsecs */
|
||||
|
||||
#ifdef TCL_WIDE_CLICKS
|
||||
/* convert execution time in wide clicks to microsecs */
|
||||
middle *= TclpWideClickInMicrosec();
|
||||
#endif
|
||||
|
||||
/* if not calibrate */
|
||||
if (!calibrate) {
|
||||
/* minimize influence of measurement overhead */
|
||||
if (overhead > 0) {
|
||||
/* estimate the time of overhead (microsecs) */
|
||||
Tcl_WideInt curOverhead = overhead * count;
|
||||
if (middle > curOverhead) {
|
||||
middle -= curOverhead;
|
||||
} else {
|
||||
middle = 1;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
/* calibration - obtaining new measurement overhead */
|
||||
if (measureOverhead > (double)middle / count) {
|
||||
measureOverhead = (double)middle / count;
|
||||
}
|
||||
objs[0] = Tcl_NewDoubleObj(measureOverhead);
|
||||
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */
|
||||
objs += 2;
|
||||
}
|
||||
|
||||
val = middle / count; /* microsecs per iteration */
|
||||
if (val >= 1000000) {
|
||||
objs[0] = Tcl_NewWideIntObj(val);
|
||||
} else {
|
||||
if (val < 10) { fmt = "%.6f"; } else
|
||||
if (val < 100) { fmt = "%.4f"; } else
|
||||
if (val < 1000) { fmt = "%.3f"; } else
|
||||
if (val < 10000) { fmt = "%.2f"; } else
|
||||
{ fmt = "%.1f"; };
|
||||
objs[0] = Tcl_ObjPrintf(fmt, ((double)middle)/count);
|
||||
}
|
||||
|
||||
objs[2] = Tcl_NewWideIntObj(count); /* iterations */
|
||||
|
||||
/* calculate speed as rate (count) per sec */
|
||||
if (!middle) middle++; /* +1 ms, just to avoid divide by zero */
|
||||
if (count < (0x7FFFFFFFFFFFFFFFL / 1000000)) {
|
||||
val = (count * 1000000) / middle;
|
||||
if (val < 100000) {
|
||||
if (val < 100) { fmt = "%.3f"; } else
|
||||
if (val < 1000) { fmt = "%.2f"; } else
|
||||
{ fmt = "%.1f"; };
|
||||
objs[4] = Tcl_ObjPrintf(fmt, ((double)(count * 1000000)) / middle);
|
||||
} else {
|
||||
objs[4] = Tcl_NewWideIntObj(val);
|
||||
}
|
||||
} else {
|
||||
objs[4] = Tcl_NewWideIntObj((count / middle) * 1000000);
|
||||
}
|
||||
|
||||
/* estimated net execution time (in millisecs) */
|
||||
if (!calibrate) {
|
||||
objs[6] = Tcl_ObjPrintf("%.3f", (double)middle / 1000);
|
||||
TclNewLiteralStringObj(objs[7], "nett-ms");
|
||||
}
|
||||
|
||||
/*
|
||||
* Construct the result as a list because many programs have always parsed
|
||||
* as such (extracting the first element, typically).
|
||||
*/
|
||||
|
||||
TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */
|
||||
TclNewLiteralStringObj(objs[3], "#");
|
||||
TclNewLiteralStringObj(objs[5], "#/sec");
|
||||
Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
|
||||
}
|
||||
|
||||
done:
|
||||
|
||||
if ((codePtr != NULL) && (codePtr->refCount-- <= 1)) {
|
||||
/* Just dropped to refcount==0. Clean up. */
|
||||
TclCleanupByteCode(codePtr);
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
|
||||
+1292
-1306
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,537 @@
|
||||
/*
|
||||
* tclDate.h --
|
||||
*
|
||||
* This header file handles common usage of clock primitives
|
||||
* between tclDate.c (yacc), tclClock.c and tclClockFmt.c.
|
||||
*
|
||||
* Copyright (c) 2014 Serg G. Brester (aka sebres)
|
||||
*
|
||||
* See the file "license.terms" for information on usage and redistribution
|
||||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#ifndef _TCLCLOCK_H
|
||||
#define _TCLCLOCK_H
|
||||
|
||||
/*
|
||||
* Constants
|
||||
*/
|
||||
|
||||
#define JULIAN_DAY_POSIX_EPOCH 2440588
|
||||
#define GREGORIAN_CHANGE_DATE 2361222
|
||||
#define SECONDS_PER_DAY 86400
|
||||
#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
|
||||
* SECONDS_PER_DAY)
|
||||
#define FOUR_CENTURIES 146097 /* days */
|
||||
#define JDAY_1_JAN_1_CE_JULIAN 1721424
|
||||
#define JDAY_1_JAN_1_CE_GREGORIAN 1721426
|
||||
#define ONE_CENTURY_GREGORIAN 36524 /* days */
|
||||
#define FOUR_YEARS 1461 /* days */
|
||||
#define ONE_YEAR 365 /* days */
|
||||
|
||||
#define RODDENBERRY 1946 /* Another epoch (Hi, Jeff!) */
|
||||
|
||||
|
||||
#define CLF_OPTIONAL (1 << 0) /* token is non mandatory */
|
||||
#define CLF_POSIXSEC (1 << 1)
|
||||
#define CLF_LOCALSEC (1 << 2)
|
||||
#define CLF_JULIANDAY (1 << 3)
|
||||
#define CLF_TIME (1 << 4)
|
||||
#define CLF_CENTURY (1 << 6)
|
||||
#define CLF_DAYOFMONTH (1 << 7)
|
||||
#define CLF_DAYOFYEAR (1 << 8)
|
||||
#define CLF_MONTH (1 << 9)
|
||||
#define CLF_YEAR (1 << 10)
|
||||
#define CLF_DAYOFWEEK (1 << 11)
|
||||
#define CLF_ISO8601YEAR (1 << 12)
|
||||
#define CLF_ISO8601WEAK (1 << 13)
|
||||
#define CLF_ISO8601CENTURY (1 << 14)
|
||||
#define CLF_SIGNED (1 << 15)
|
||||
/* On demand (lazy) assemble flags */
|
||||
#define CLF_ASSEMBLE_DATE (1 << 28) /* assemble year, month, etc. using julianDay */
|
||||
#define CLF_ASSEMBLE_JULIANDAY (1 << 29) /* assemble julianDay using year, month, etc. */
|
||||
#define CLF_ASSEMBLE_SECONDS (1 << 30) /* assemble localSeconds (and seconds at end) */
|
||||
|
||||
#define CLF_DATE (CLF_JULIANDAY | CLF_DAYOFMONTH | CLF_DAYOFYEAR | \
|
||||
CLF_MONTH | CLF_YEAR | CLF_ISO8601YEAR | \
|
||||
CLF_DAYOFWEEK | CLF_ISO8601WEAK)
|
||||
|
||||
#define TCL_MIN_SECONDS -0x00F0000000000000L
|
||||
#define TCL_MAX_SECONDS 0x00F0000000000000L
|
||||
#define TCL_INV_SECONDS (TCL_MIN_SECONDS-1)
|
||||
|
||||
/*
|
||||
* Enumeration of the string literals used in [clock]
|
||||
*/
|
||||
|
||||
typedef enum ClockLiteral {
|
||||
LIT__NIL,
|
||||
LIT__DEFAULT_FORMAT,
|
||||
LIT_SYSTEM, LIT_CURRENT, LIT_C,
|
||||
LIT_BCE, LIT_CE,
|
||||
LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR,
|
||||
LIT_ERA, LIT_GMT, LIT_GREGORIAN,
|
||||
LIT_INTEGER_VALUE_TOO_LARGE,
|
||||
LIT_ISO8601WEEK, LIT_ISO8601YEAR,
|
||||
LIT_JULIANDAY, LIT_LOCALSECONDS,
|
||||
LIT_MONTH,
|
||||
LIT_SECONDS, LIT_TZNAME, LIT_TZOFFSET,
|
||||
LIT_YEAR,
|
||||
LIT_TZDATA,
|
||||
LIT_GETSYSTEMTIMEZONE,
|
||||
LIT_SETUPTIMEZONE,
|
||||
LIT_MCGET,
|
||||
LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE,
|
||||
LIT_LOCALIZE_FORMAT,
|
||||
LIT__END
|
||||
} ClockLiteral;
|
||||
|
||||
#define CLOCK_LITERAL_ARRAY(litarr) static const char *const litarr[] = { \
|
||||
"", \
|
||||
"%a %b %d %H:%M:%S %Z %Y", \
|
||||
"system", "current", "C", \
|
||||
"BCE", "CE", \
|
||||
"dayOfMonth", "dayOfWeek", "dayOfYear", \
|
||||
"era", ":GMT", "gregorian", \
|
||||
"integer value too large to represent", \
|
||||
"iso8601Week", "iso8601Year", \
|
||||
"julianDay", "localSeconds", \
|
||||
"month", \
|
||||
"seconds", "tzName", "tzOffset", \
|
||||
"year", \
|
||||
"::tcl::clock::TZData", \
|
||||
"::tcl::clock::GetSystemTimeZone", \
|
||||
"::tcl::clock::SetupTimeZone", \
|
||||
"::tcl::clock::mcget", \
|
||||
"::tcl::clock::GetSystemLocale", "::tcl::clock::mclocale", \
|
||||
"::tcl::clock::LocalizeFormat" \
|
||||
}
|
||||
|
||||
/*
|
||||
* Enumeration of the msgcat literals used in [clock]
|
||||
*/
|
||||
|
||||
typedef enum ClockMsgCtLiteral {
|
||||
MCLIT__NIL, /* placeholder */
|
||||
MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, MCLIT_MONTHS_COMB,
|
||||
MCLIT_DAYS_OF_WEEK_FULL, MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_COMB,
|
||||
MCLIT_AM, MCLIT_PM,
|
||||
MCLIT_LOCALE_ERAS,
|
||||
MCLIT_BCE, MCLIT_CE,
|
||||
MCLIT_BCE2, MCLIT_CE2,
|
||||
MCLIT_BCE3, MCLIT_CE3,
|
||||
MCLIT_LOCALE_NUMERALS,
|
||||
MCLIT__END
|
||||
} ClockMsgCtLiteral;
|
||||
|
||||
#define CLOCK_LOCALE_LITERAL_ARRAY(litarr, pref) static const char *const litarr[] = { \
|
||||
pref "", \
|
||||
pref "MONTHS_FULL", pref "MONTHS_ABBREV", pref "MONTHS_COMB", \
|
||||
pref "DAYS_OF_WEEK_FULL", pref "DAYS_OF_WEEK_ABBREV", pref "DAYS_OF_WEEK_COMB", \
|
||||
pref "AM", pref "PM", \
|
||||
pref "LOCALE_ERAS", \
|
||||
pref "BCE", pref "CE", \
|
||||
pref "b.c.e.", pref "c.e.", \
|
||||
pref "b.c.", pref "a.d.", \
|
||||
pref "LOCALE_NUMERALS", \
|
||||
}
|
||||
|
||||
/*
|
||||
* Structure containing the fields used in [clock format] and [clock scan]
|
||||
*/
|
||||
|
||||
typedef struct TclDateFields {
|
||||
|
||||
/* Cacheable fields: */
|
||||
|
||||
Tcl_WideInt seconds; /* Time expressed in seconds from the Posix
|
||||
* epoch */
|
||||
Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds
|
||||
* from the Posix epoch */
|
||||
int tzOffset; /* Time zone offset in seconds east of
|
||||
* Greenwich */
|
||||
Tcl_WideInt julianDay; /* Julian Day Number in local time zone */
|
||||
enum {BCE=1, CE=0} era; /* Era */
|
||||
int gregorian; /* Flag == 1 if the date is Gregorian */
|
||||
int year; /* Year of the era */
|
||||
int dayOfYear; /* Day of the year (1 January == 1) */
|
||||
int month; /* Month number */
|
||||
int dayOfMonth; /* Day of the month */
|
||||
int iso8601Year; /* ISO8601 week-based year */
|
||||
int iso8601Week; /* ISO8601 week number */
|
||||
int dayOfWeek; /* Day of the week */
|
||||
int hour; /* Hours of day (in-between time only calculation) */
|
||||
int minutes; /* Minutes of hour (in-between time only calculation) */
|
||||
int secondOfMin; /* Seconds of minute (in-between time only calculation) */
|
||||
int secondOfDay; /* Seconds of day (in-between time only calculation) */
|
||||
|
||||
/* Non cacheable fields: */
|
||||
|
||||
Tcl_Obj *tzName; /* Name (or corresponding DST-abbreviation) of the
|
||||
* time zone, if set the refCount is incremented */
|
||||
} TclDateFields;
|
||||
|
||||
#define ClockCacheableDateFieldsSize \
|
||||
TclOffset(TclDateFields, tzName)
|
||||
|
||||
/*
|
||||
* Structure contains return parsed fields.
|
||||
*/
|
||||
|
||||
typedef struct DateInfo {
|
||||
const char *dateStart;
|
||||
const char *dateInput;
|
||||
const char *dateEnd;
|
||||
|
||||
TclDateFields date;
|
||||
|
||||
int flags;
|
||||
|
||||
int dateHaveDate;
|
||||
|
||||
int dateMeridian;
|
||||
int dateHaveTime;
|
||||
|
||||
int dateTimezone;
|
||||
int dateDSTmode;
|
||||
int dateHaveZone;
|
||||
|
||||
int dateRelMonth;
|
||||
int dateRelDay;
|
||||
int dateRelSeconds;
|
||||
int dateHaveRel;
|
||||
|
||||
int dateMonthOrdinalIncr;
|
||||
int dateMonthOrdinal;
|
||||
int dateHaveOrdinalMonth;
|
||||
|
||||
int dateDayOrdinal;
|
||||
int dateHaveDay;
|
||||
|
||||
int *dateRelPointer;
|
||||
|
||||
int dateSpaceCount;
|
||||
int dateDigitCount;
|
||||
|
||||
int dateCentury;
|
||||
|
||||
Tcl_Obj* messages; /* Error messages */
|
||||
const char* separatrix; /* String separating messages */
|
||||
} DateInfo;
|
||||
|
||||
#define yydate (info->date) /* Date fields used for converting */
|
||||
|
||||
#define yyDay (info->date.dayOfMonth)
|
||||
#define yyMonth (info->date.month)
|
||||
#define yyYear (info->date.year)
|
||||
|
||||
#define yyHour (info->date.hour)
|
||||
#define yyMinutes (info->date.minutes)
|
||||
#define yySeconds (info->date.secondOfMin)
|
||||
#define yySecondOfDay (info->date.secondOfDay)
|
||||
|
||||
#define yyDSTmode (info->dateDSTmode)
|
||||
#define yyDayOrdinal (info->dateDayOrdinal)
|
||||
#define yyDayOfWeek (info->date.dayOfWeek)
|
||||
#define yyMonthOrdinalIncr (info->dateMonthOrdinalIncr)
|
||||
#define yyMonthOrdinal (info->dateMonthOrdinal)
|
||||
#define yyHaveDate (info->dateHaveDate)
|
||||
#define yyHaveDay (info->dateHaveDay)
|
||||
#define yyHaveOrdinalMonth (info->dateHaveOrdinalMonth)
|
||||
#define yyHaveRel (info->dateHaveRel)
|
||||
#define yyHaveTime (info->dateHaveTime)
|
||||
#define yyHaveZone (info->dateHaveZone)
|
||||
#define yyTimezone (info->dateTimezone)
|
||||
#define yyMeridian (info->dateMeridian)
|
||||
#define yyRelMonth (info->dateRelMonth)
|
||||
#define yyRelDay (info->dateRelDay)
|
||||
#define yyRelSeconds (info->dateRelSeconds)
|
||||
#define yyRelPointer (info->dateRelPointer)
|
||||
#define yyInput (info->dateInput)
|
||||
#define yyDigitCount (info->dateDigitCount)
|
||||
#define yySpaceCount (info->dateSpaceCount)
|
||||
|
||||
static inline void
|
||||
ClockInitDateInfo(DateInfo *info) {
|
||||
memset(info, 0, sizeof(DateInfo));
|
||||
}
|
||||
|
||||
/*
|
||||
* Structure containing the command arguments supplied to [clock format] and [clock scan]
|
||||
*/
|
||||
|
||||
#define CLF_VALIDATE (1 << 2)
|
||||
#define CLF_EXTENDED (1 << 4)
|
||||
#define CLF_STRICT (1 << 8)
|
||||
#define CLF_LOCALE_USED (1 << 15)
|
||||
|
||||
typedef struct ClockFmtScnCmdArgs {
|
||||
ClientData clientData; /* Opaque pointer to literal pool, etc. */
|
||||
Tcl_Interp *interp; /* Tcl interpreter */
|
||||
|
||||
Tcl_Obj *formatObj; /* Format */
|
||||
Tcl_Obj *localeObj; /* Name of the locale where the time will be expressed. */
|
||||
Tcl_Obj *timezoneObj; /* Default time zone in which the time will be expressed */
|
||||
Tcl_Obj *baseObj; /* Base (scan and add) or clockValue (format) */
|
||||
int flags; /* Flags control scanning */
|
||||
|
||||
Tcl_Obj *mcDictObj; /* Current dictionary of tcl::clock package for given localeObj*/
|
||||
} ClockFmtScnCmdArgs;
|
||||
|
||||
/* Last-period cache for fast UTC to local and backwards conversion */
|
||||
typedef struct ClockLastTZOffs {
|
||||
/* keys */
|
||||
Tcl_Obj *timezoneObj;
|
||||
int changeover;
|
||||
Tcl_WideInt localSeconds;
|
||||
Tcl_WideInt rangesVal[2]; /* Bounds for cached time zone offset */
|
||||
/* values */
|
||||
int tzOffset;
|
||||
Tcl_Obj *tzName; /* Name (abbreviation) of this area in TZ */
|
||||
} ClockLastTZOffs;
|
||||
|
||||
/*
|
||||
* Structure containing the client data for [clock]
|
||||
*/
|
||||
|
||||
typedef struct ClockClientData {
|
||||
size_t refCount; /* Number of live references. */
|
||||
Tcl_Obj **literals; /* Pool of object literals (common, locale independent). */
|
||||
Tcl_Obj **mcLiterals; /* Msgcat object literals with mc-keys for search with locale. */
|
||||
Tcl_Obj **mcLitIdxs; /* Msgcat object indices prefixed with _IDX_,
|
||||
* used for quick dictionary search */
|
||||
|
||||
Tcl_Obj *mcDicts; /* Msgcat collection, contains weak pointers to locale
|
||||
* catalogs, and owns it references (onetime referenced) */
|
||||
|
||||
/* Cache for current clock parameters, imparted via "configure" */
|
||||
size_t lastTZEpoch;
|
||||
int currentYearCentury;
|
||||
int yearOfCenturySwitch;
|
||||
int validMinYear;
|
||||
int validMaxYear;
|
||||
|
||||
Tcl_Obj *systemTimeZone;
|
||||
Tcl_Obj *systemSetupTZData;
|
||||
Tcl_Obj *gmtSetupTimeZoneUnnorm;
|
||||
Tcl_Obj *gmtSetupTimeZone;
|
||||
Tcl_Obj *gmtSetupTZData;
|
||||
Tcl_Obj *gmtTZName;
|
||||
Tcl_Obj *lastSetupTimeZoneUnnorm;
|
||||
Tcl_Obj *lastSetupTimeZone;
|
||||
Tcl_Obj *lastSetupTZData;
|
||||
Tcl_Obj *prevSetupTimeZoneUnnorm;
|
||||
Tcl_Obj *prevSetupTimeZone;
|
||||
Tcl_Obj *prevSetupTZData;
|
||||
|
||||
Tcl_Obj *defaultLocale;
|
||||
Tcl_Obj *defaultLocaleDict;
|
||||
Tcl_Obj *currentLocale;
|
||||
Tcl_Obj *currentLocaleDict;
|
||||
Tcl_Obj *lastUsedLocaleUnnorm;
|
||||
Tcl_Obj *lastUsedLocale;
|
||||
Tcl_Obj *lastUsedLocaleDict;
|
||||
Tcl_Obj *prevUsedLocaleUnnorm;
|
||||
Tcl_Obj *prevUsedLocale;
|
||||
Tcl_Obj *prevUsedLocaleDict;
|
||||
|
||||
/* Cache for last base (last-second fast convert if base/tz not changed) */
|
||||
struct {
|
||||
Tcl_Obj *timezoneObj;
|
||||
TclDateFields date;
|
||||
} lastBase;
|
||||
|
||||
/* Last-period cache for fast UTC to Local and backwards conversion */
|
||||
ClockLastTZOffs lastTZOffsCache[2];
|
||||
|
||||
int defFlags; /* Default flags (from configure), ATM
|
||||
* only CLF_VALIDATE supported */
|
||||
} ClockClientData;
|
||||
|
||||
#define ClockDefaultYearCentury 2000
|
||||
#define ClockDefaultCenturySwitch 38
|
||||
|
||||
/*
|
||||
* Meridian: am, pm, or 24-hour style.
|
||||
*/
|
||||
|
||||
typedef enum _MERIDIAN {
|
||||
MERam, MERpm, MER24
|
||||
} MERIDIAN;
|
||||
|
||||
/*
|
||||
* Clock scan and format facilities.
|
||||
*/
|
||||
|
||||
#define CLOCK_FMT_SCN_STORAGE_GC_SIZE 32
|
||||
|
||||
#define CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE 2
|
||||
|
||||
typedef struct ClockScanToken ClockScanToken;
|
||||
|
||||
|
||||
typedef int ClockScanTokenProc(
|
||||
ClockFmtScnCmdArgs *opts,
|
||||
DateInfo *info,
|
||||
ClockScanToken *tok);
|
||||
|
||||
|
||||
typedef enum _CLCKTOK_TYPE {
|
||||
CTOKT_INT = 1, CTOKT_WIDE, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR,
|
||||
CFMTT_PROC
|
||||
} CLCKTOK_TYPE;
|
||||
|
||||
typedef struct ClockScanTokenMap {
|
||||
unsigned short int type;
|
||||
unsigned short int flags;
|
||||
unsigned short int clearFlags;
|
||||
unsigned short int minSize;
|
||||
unsigned short int maxSize;
|
||||
unsigned short int offs;
|
||||
ClockScanTokenProc *parser;
|
||||
const void *data;
|
||||
} ClockScanTokenMap;
|
||||
|
||||
struct ClockScanToken {
|
||||
ClockScanTokenMap *map;
|
||||
struct {
|
||||
const char *start;
|
||||
const char *end;
|
||||
} tokWord;
|
||||
unsigned short int endDistance;
|
||||
unsigned short int lookAhMin;
|
||||
unsigned short int lookAhMax;
|
||||
unsigned short int lookAhTok;
|
||||
};
|
||||
|
||||
|
||||
#define MIN_FMT_RESULT_BLOCK_ALLOC 80
|
||||
#define MIN_FMT_RESULT_BLOCK_DELTA 0
|
||||
/* Maximal permitted threshold (buffer size > result size) in percent,
|
||||
* to directly return the buffer without reallocate */
|
||||
#define MAX_FMT_RESULT_THRESHOLD 2
|
||||
|
||||
typedef struct DateFormat {
|
||||
char *resMem;
|
||||
char *resEnd;
|
||||
char *output;
|
||||
|
||||
TclDateFields date;
|
||||
|
||||
Tcl_Obj *localeEra;
|
||||
} DateFormat;
|
||||
|
||||
#define CLFMT_INCR (1 << 3)
|
||||
#define CLFMT_DECR (1 << 4)
|
||||
#define CLFMT_CALC (1 << 5)
|
||||
#define CLFMT_LOCALE_INDX (1 << 8)
|
||||
|
||||
typedef struct ClockFormatToken ClockFormatToken;
|
||||
|
||||
typedef int ClockFormatTokenProc(
|
||||
ClockFmtScnCmdArgs *opts,
|
||||
DateFormat *dateFmt,
|
||||
ClockFormatToken *tok,
|
||||
int *val);
|
||||
|
||||
typedef struct ClockFormatTokenMap {
|
||||
unsigned short int type;
|
||||
const char *tostr;
|
||||
unsigned short int width;
|
||||
unsigned short int flags;
|
||||
unsigned short int divider;
|
||||
unsigned short int divmod;
|
||||
unsigned short int offs;
|
||||
ClockFormatTokenProc *fmtproc;
|
||||
void *data;
|
||||
} ClockFormatTokenMap;
|
||||
|
||||
struct ClockFormatToken {
|
||||
ClockFormatTokenMap *map;
|
||||
struct {
|
||||
const char *start;
|
||||
const char *end;
|
||||
} tokWord;
|
||||
};
|
||||
|
||||
|
||||
typedef struct ClockFmtScnStorage ClockFmtScnStorage;
|
||||
|
||||
struct ClockFmtScnStorage {
|
||||
int objRefCount; /* Reference count shared across threads */
|
||||
ClockScanToken *scnTok;
|
||||
unsigned int scnTokC;
|
||||
unsigned int scnSpaceCount; /* Count of mandatory spaces used in format */
|
||||
ClockFormatToken *fmtTok;
|
||||
unsigned int fmtTokC;
|
||||
#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
|
||||
ClockFmtScnStorage *nextPtr;
|
||||
ClockFmtScnStorage *prevPtr;
|
||||
#endif
|
||||
size_t fmtMinAlloc;
|
||||
#if 0
|
||||
+Tcl_HashEntry hashEntry /* ClockFmtScnStorage is a derivate of Tcl_HashEntry,
|
||||
* stored by offset +sizeof(self) */
|
||||
#endif
|
||||
};
|
||||
|
||||
/*
|
||||
* Prototypes of module functions.
|
||||
*/
|
||||
|
||||
MODULE_SCOPE int ToSeconds(int Hours, int Minutes,
|
||||
int Seconds, MERIDIAN Meridian);
|
||||
MODULE_SCOPE int IsGregorianLeapYear(TclDateFields *);
|
||||
MODULE_SCOPE void
|
||||
GetJulianDayFromEraYearWeekDay(
|
||||
TclDateFields *fields, int changeover);
|
||||
MODULE_SCOPE void
|
||||
GetJulianDayFromEraYearMonthDay(
|
||||
TclDateFields *fields, int changeover);
|
||||
MODULE_SCOPE void
|
||||
GetJulianDayFromEraYearDay(
|
||||
TclDateFields *fields, int changeover);
|
||||
MODULE_SCOPE int ConvertUTCToLocal(ClientData clientData, Tcl_Interp *,
|
||||
TclDateFields *, Tcl_Obj *timezoneObj, int);
|
||||
MODULE_SCOPE Tcl_Obj *
|
||||
LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
|
||||
int, Tcl_Obj *const *, Tcl_WideInt *rangesVal);
|
||||
|
||||
MODULE_SCOPE int TclClockFreeScan(Tcl_Interp *interp, DateInfo *info);
|
||||
|
||||
/* tclClock.c module declarations */
|
||||
|
||||
MODULE_SCOPE Tcl_Obj *
|
||||
ClockSetupTimeZone(ClientData clientData,
|
||||
Tcl_Interp *interp, Tcl_Obj *timezoneObj);
|
||||
|
||||
MODULE_SCOPE Tcl_Obj *
|
||||
ClockMCDict(ClockFmtScnCmdArgs *opts);
|
||||
MODULE_SCOPE Tcl_Obj *
|
||||
ClockMCGet(ClockFmtScnCmdArgs *opts, int mcKey);
|
||||
MODULE_SCOPE Tcl_Obj *
|
||||
ClockMCGetIdx(ClockFmtScnCmdArgs *opts, int mcKey);
|
||||
MODULE_SCOPE int ClockMCSetIdx(ClockFmtScnCmdArgs *opts, int mcKey,
|
||||
Tcl_Obj *valObj);
|
||||
|
||||
/* tclClockFmt.c module declarations */
|
||||
|
||||
MODULE_SCOPE Tcl_Obj*
|
||||
ClockFrmObjGetLocFmtKey(Tcl_Interp *interp,
|
||||
Tcl_Obj *objPtr);
|
||||
|
||||
MODULE_SCOPE ClockFmtScnStorage *
|
||||
Tcl_GetClockFrmScnFromObj(Tcl_Interp *interp,
|
||||
Tcl_Obj *objPtr);
|
||||
MODULE_SCOPE Tcl_Obj *
|
||||
ClockLocalizeFormat(ClockFmtScnCmdArgs *opts);
|
||||
|
||||
MODULE_SCOPE int ClockScan(register DateInfo *info,
|
||||
Tcl_Obj *strObj, ClockFmtScnCmdArgs *opts);
|
||||
|
||||
MODULE_SCOPE int ClockFormat(register DateFormat *dateFmt,
|
||||
ClockFmtScnCmdArgs *opts);
|
||||
|
||||
MODULE_SCOPE void ClockFrmScnClearCaches(void);
|
||||
|
||||
#endif /* _TCLCLOCK_H */
|
||||
@@ -1952,6 +1952,60 @@ DictSizeCmd(
|
||||
return result;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* Tcl_DictObjSmartRef --
|
||||
*
|
||||
* This function returns new tcl-object with the smart reference to
|
||||
* dictionary object.
|
||||
*
|
||||
* Object returned with this function is a smart reference (pointer),
|
||||
* so new object of type tclDictType, that directly references given
|
||||
* dictionary object (with internally increased refCount).
|
||||
*
|
||||
* The usage of such pointer objects allows to hold more as one
|
||||
* reference to the same real dictionary object, allows to make a pointer
|
||||
* to part of another dictionary, allows to change the dictionary without
|
||||
* regarding of the "shared" state of the dictionary object.
|
||||
*
|
||||
* Prevents "called with shared object" exception if object is multiple
|
||||
* referenced.
|
||||
*
|
||||
* Results:
|
||||
* The newly create object (contains smart reference) is returned.
|
||||
* The returned object has a ref count of 0.
|
||||
*
|
||||
* Side effects:
|
||||
* Increases ref count of the referenced dictionary.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_Obj *
|
||||
Tcl_DictObjSmartRef(
|
||||
Tcl_Interp *interp,
|
||||
Tcl_Obj *dictPtr)
|
||||
{
|
||||
Tcl_Obj *result;
|
||||
Dict *dict;
|
||||
|
||||
if (dictPtr->typePtr != &tclDictType
|
||||
&& SetDictFromAny(interp, dictPtr) != TCL_OK) {
|
||||
return NULL;
|
||||
}
|
||||
|
||||
dict = DICT(dictPtr);
|
||||
|
||||
result = Tcl_NewObj();
|
||||
DICT(result) = dict;
|
||||
dict->refCount++;
|
||||
result->internalRep.twoPtrValue.ptr2 = NULL;
|
||||
result->typePtr = &tclDictType;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
|
||||
@@ -353,6 +353,14 @@ TclNamespaceEnsembleCmd(
|
||||
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
|
||||
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
|
||||
Tcl_SetEnsembleParameterList(interp, token, paramObj);
|
||||
/*
|
||||
* Ensemble should be compiled if it has map (performance purposes)
|
||||
* Currently only for internal using namespace (like ::tcl::clock).
|
||||
* (An enhancement for completelly compile-feature is in work.)
|
||||
*/
|
||||
if (mapObj != NULL && strncmp("::tcl::", nsPtr->fullName, 7) == 0) {
|
||||
Tcl_SetEnsembleFlags(interp, token, ENSEMBLE_COMPILE);
|
||||
}
|
||||
|
||||
/*
|
||||
* Tricky! Must ensure that the result is not shared (command delete
|
||||
|
||||
@@ -17,6 +17,11 @@
|
||||
|
||||
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
|
||||
|
||||
|
||||
/* MODULE_SCOPE */
|
||||
size_t TclEnvEpoch = 0; /* Epoch of the tcl environment
|
||||
* (if changed with tcl-env). */
|
||||
|
||||
static struct {
|
||||
int cacheSize; /* Number of env strings in cache. */
|
||||
char **cache; /* Array containing all of the environment
|
||||
@@ -372,6 +377,7 @@ Tcl_PutEnv(
|
||||
value[0] = '\0';
|
||||
TclSetEnv(name, value+1);
|
||||
}
|
||||
TclEnvEpoch++;
|
||||
|
||||
Tcl_DStringFree(&nameString);
|
||||
return 0;
|
||||
@@ -580,6 +586,7 @@ EnvTraceProc(
|
||||
|
||||
if (flags & TCL_TRACE_ARRAY) {
|
||||
TclSetupEnv(interp);
|
||||
TclEnvEpoch++;
|
||||
return NULL;
|
||||
}
|
||||
|
||||
@@ -600,6 +607,7 @@ EnvTraceProc(
|
||||
|
||||
value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
|
||||
TclSetEnv(name2, value);
|
||||
TclEnvEpoch++;
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -623,6 +631,7 @@ EnvTraceProc(
|
||||
|
||||
if (flags & TCL_TRACE_UNSETS) {
|
||||
TclUnsetEnv(name2);
|
||||
TclEnvEpoch++;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
+184
-240
@@ -9,6 +9,7 @@
|
||||
*
|
||||
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
|
||||
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
|
||||
* Copyright (c) 2015 Sergey G. Brester aka sebres.
|
||||
*
|
||||
* See the file "license.terms" for information on usage and redistribution of
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
@@ -45,78 +46,20 @@
|
||||
#pragma warning( disable : 4102 )
|
||||
#endif /* _MSC_VER */
|
||||
|
||||
#if 0
|
||||
#define YYDEBUG 1
|
||||
#endif
|
||||
|
||||
/*
|
||||
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
|
||||
* parsed fields will be returned.
|
||||
*/
|
||||
|
||||
typedef struct DateInfo {
|
||||
|
||||
Tcl_Obj* messages; /* Error messages */
|
||||
const char* separatrix; /* String separating messages */
|
||||
|
||||
time_t dateYear;
|
||||
time_t dateMonth;
|
||||
time_t dateDay;
|
||||
int dateHaveDate;
|
||||
|
||||
time_t dateHour;
|
||||
time_t dateMinutes;
|
||||
time_t dateSeconds;
|
||||
int dateMeridian;
|
||||
int dateHaveTime;
|
||||
|
||||
time_t dateTimezone;
|
||||
int dateDSTmode;
|
||||
int dateHaveZone;
|
||||
|
||||
time_t dateRelMonth;
|
||||
time_t dateRelDay;
|
||||
time_t dateRelSeconds;
|
||||
int dateHaveRel;
|
||||
|
||||
time_t dateMonthOrdinal;
|
||||
int dateHaveOrdinalMonth;
|
||||
|
||||
time_t dateDayOrdinal;
|
||||
time_t dateDayNumber;
|
||||
int dateHaveDay;
|
||||
|
||||
const char *dateStart;
|
||||
const char *dateInput;
|
||||
time_t *dateRelPointer;
|
||||
|
||||
int dateDigitCount;
|
||||
} DateInfo;
|
||||
#include "tclDate.h"
|
||||
|
||||
#define YYMALLOC ckalloc
|
||||
#define YYFREE(x) (ckfree((void*) (x)))
|
||||
|
||||
#define yyDSTmode (info->dateDSTmode)
|
||||
#define yyDayOrdinal (info->dateDayOrdinal)
|
||||
#define yyDayNumber (info->dateDayNumber)
|
||||
#define yyMonthOrdinal (info->dateMonthOrdinal)
|
||||
#define yyHaveDate (info->dateHaveDate)
|
||||
#define yyHaveDay (info->dateHaveDay)
|
||||
#define yyHaveOrdinalMonth (info->dateHaveOrdinalMonth)
|
||||
#define yyHaveRel (info->dateHaveRel)
|
||||
#define yyHaveTime (info->dateHaveTime)
|
||||
#define yyHaveZone (info->dateHaveZone)
|
||||
#define yyTimezone (info->dateTimezone)
|
||||
#define yyDay (info->dateDay)
|
||||
#define yyMonth (info->dateMonth)
|
||||
#define yyYear (info->dateYear)
|
||||
#define yyHour (info->dateHour)
|
||||
#define yyMinutes (info->dateMinutes)
|
||||
#define yySeconds (info->dateSeconds)
|
||||
#define yyMeridian (info->dateMeridian)
|
||||
#define yyRelMonth (info->dateRelMonth)
|
||||
#define yyRelDay (info->dateRelDay)
|
||||
#define yyRelSeconds (info->dateRelSeconds)
|
||||
#define yyRelPointer (info->dateRelPointer)
|
||||
#define yyInput (info->dateInput)
|
||||
#define yyDigitCount (info->dateDigitCount)
|
||||
|
||||
#define EPOCH 1970
|
||||
#define START_OF_TIME 1902
|
||||
#define END_OF_TIME 2037
|
||||
@@ -150,14 +93,6 @@ typedef enum _DSTMODE {
|
||||
DSTon, DSToff, DSTmaybe
|
||||
} DSTMODE;
|
||||
|
||||
/*
|
||||
* Meridian: am, pm, or 24-hour style.
|
||||
*/
|
||||
|
||||
typedef enum _MERIDIAN {
|
||||
MERam, MERpm, MER24
|
||||
} MERIDIAN;
|
||||
|
||||
%}
|
||||
|
||||
%union {
|
||||
@@ -176,8 +111,6 @@ static int LookupWord(YYSTYPE* yylvalPtr, char *buff);
|
||||
DateInfo* info, const char *s);
|
||||
static int TclDatelex(YYSTYPE* yylvalPtr, YYLTYPE* location,
|
||||
DateInfo* info);
|
||||
static time_t ToSeconds(time_t Hours, time_t Minutes,
|
||||
time_t Seconds, MERIDIAN Meridian);
|
||||
MODULE_SCOPE int yyparse(DateInfo*);
|
||||
|
||||
%}
|
||||
@@ -191,14 +124,16 @@ MODULE_SCOPE int yyparse(DateInfo*);
|
||||
%token tMONTH_UNIT
|
||||
%token tSTARDATE
|
||||
%token tSEC_UNIT
|
||||
%token tSNUMBER
|
||||
%token tUNUMBER
|
||||
%token tZONE
|
||||
%token tZONEwO4
|
||||
%token tZONEwO2
|
||||
%token tEPOCH
|
||||
%token tDST
|
||||
%token tISOBASE
|
||||
%token tDAY_UNIT
|
||||
%token tNEXT
|
||||
%token SP
|
||||
|
||||
%type <Number> tDAY
|
||||
%type <Number> tDAYZONE
|
||||
@@ -206,9 +141,11 @@ MODULE_SCOPE int yyparse(DateInfo*);
|
||||
%type <Number> tMONTH_UNIT
|
||||
%type <Number> tDST
|
||||
%type <Number> tSEC_UNIT
|
||||
%type <Number> tSNUMBER
|
||||
%type <Number> tUNUMBER
|
||||
%type <Number> INTNUM
|
||||
%type <Number> tZONE
|
||||
%type <Number> tZONEwO4
|
||||
%type <Number> tZONEwO2
|
||||
%type <Number> tISOBASE
|
||||
%type <Number> tDAY_UNIT
|
||||
%type <Number> unit
|
||||
@@ -222,6 +159,7 @@ MODULE_SCOPE int yyparse(DateInfo*);
|
||||
|
||||
spec : /* NULL */
|
||||
| spec item
|
||||
| spec SP item
|
||||
;
|
||||
|
||||
item : time {
|
||||
@@ -266,29 +204,12 @@ time : tUNUMBER tMERIDIAN {
|
||||
yySeconds = 0;
|
||||
yyMeridian = $4;
|
||||
}
|
||||
| tUNUMBER ':' tUNUMBER '-' tUNUMBER {
|
||||
yyHour = $1;
|
||||
yyMinutes = $3;
|
||||
yyMeridian = MER24;
|
||||
yyDSTmode = DSToff;
|
||||
yyTimezone = ($5 % 100 + ($5 / 100) * 60);
|
||||
++yyHaveZone;
|
||||
}
|
||||
| tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid {
|
||||
yyHour = $1;
|
||||
yyMinutes = $3;
|
||||
yySeconds = $5;
|
||||
yyMeridian = $6;
|
||||
}
|
||||
| tUNUMBER ':' tUNUMBER ':' tUNUMBER '-' tUNUMBER {
|
||||
yyHour = $1;
|
||||
yyMinutes = $3;
|
||||
yySeconds = $5;
|
||||
yyMeridian = MER24;
|
||||
yyDSTmode = DSToff;
|
||||
yyTimezone = ($7 % 100 + ($7 / 100) * 60);
|
||||
++yyHaveZone;
|
||||
}
|
||||
;
|
||||
|
||||
zone : tZONE tDST {
|
||||
@@ -303,27 +224,53 @@ zone : tZONE tDST {
|
||||
yyTimezone = $1;
|
||||
yyDSTmode = DSTon;
|
||||
}
|
||||
| tZONEwO4 sign INTNUM { /* GMT+0100, GMT-1000, etc. */
|
||||
yyTimezone = $1 - $2*($3 % 100 + ($3 / 100) * 60);
|
||||
yyDSTmode = DSToff;
|
||||
}
|
||||
| tZONEwO2 sign INTNUM { /* GMT+1, GMT-10, etc. */
|
||||
yyTimezone = $1 - $2*($3 * 60);
|
||||
yyDSTmode = DSToff;
|
||||
}
|
||||
| sign INTNUM { /* +0100, -0100 */
|
||||
yyTimezone = -$1*($2 % 100 + ($2 / 100) * 60);
|
||||
yyDSTmode = DSToff;
|
||||
}
|
||||
;
|
||||
|
||||
comma : ','
|
||||
| ',' SP
|
||||
;
|
||||
|
||||
day : tDAY {
|
||||
yyDayOrdinal = 1;
|
||||
yyDayNumber = $1;
|
||||
yyDayOfWeek = $1;
|
||||
info->flags |= CLF_DAYOFWEEK;
|
||||
}
|
||||
| tDAY ',' {
|
||||
| tDAY comma {
|
||||
yyDayOrdinal = 1;
|
||||
yyDayNumber = $1;
|
||||
yyDayOfWeek = $1;
|
||||
info->flags |= CLF_DAYOFWEEK;
|
||||
}
|
||||
| tUNUMBER tDAY {
|
||||
yyDayOrdinal = $1;
|
||||
yyDayNumber = $2;
|
||||
yyDayOfWeek = $2;
|
||||
info->flags |= CLF_DAYOFWEEK;
|
||||
}
|
||||
| sign SP tUNUMBER tDAY {
|
||||
yyDayOrdinal = $1 * $3;
|
||||
yyDayOfWeek = $4;
|
||||
info->flags |= CLF_DAYOFWEEK;
|
||||
}
|
||||
| sign tUNUMBER tDAY {
|
||||
yyDayOrdinal = $1 * $2;
|
||||
yyDayNumber = $3;
|
||||
yyDayOfWeek = $3;
|
||||
info->flags |= CLF_DAYOFWEEK;
|
||||
}
|
||||
| tNEXT tDAY {
|
||||
yyDayOrdinal = 2;
|
||||
yyDayNumber = $2;
|
||||
yyDayOfWeek = $2;
|
||||
info->flags |= CLF_DAYOFWEEK;
|
||||
}
|
||||
;
|
||||
|
||||
@@ -355,7 +302,7 @@ date : tUNUMBER '/' tUNUMBER {
|
||||
yyMonth = $1;
|
||||
yyDay = $2;
|
||||
}
|
||||
| tMONTH tUNUMBER ',' tUNUMBER {
|
||||
| tMONTH tUNUMBER comma tUNUMBER {
|
||||
yyMonth = $1;
|
||||
yyDay = $2;
|
||||
yyYear = $4;
|
||||
@@ -377,17 +324,17 @@ date : tUNUMBER '/' tUNUMBER {
|
||||
;
|
||||
|
||||
ordMonth: tNEXT tMONTH {
|
||||
yyMonthOrdinal = 1;
|
||||
yyMonth = $2;
|
||||
yyMonthOrdinalIncr = 1;
|
||||
yyMonthOrdinal = $2;
|
||||
}
|
||||
| tNEXT tUNUMBER tMONTH {
|
||||
yyMonthOrdinal = $2;
|
||||
yyMonth = $3;
|
||||
yyMonthOrdinalIncr = $2;
|
||||
yyMonthOrdinal = $3;
|
||||
}
|
||||
;
|
||||
|
||||
iso : tISOBASE tZONE tISOBASE {
|
||||
if ($2 != HOUR( 7)) YYABORT;
|
||||
if ($2 != HOUR( 7)) YYABORT; /* T */
|
||||
yyYear = $1 / 10000;
|
||||
yyMonth = ($1 % 10000)/100;
|
||||
yyDay = $1 % 100;
|
||||
@@ -395,15 +342,6 @@ iso : tISOBASE tZONE tISOBASE {
|
||||
yyMinutes = ($3 % 10000)/100;
|
||||
yySeconds = $3 % 100;
|
||||
}
|
||||
| tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER {
|
||||
if ($2 != HOUR( 7)) YYABORT;
|
||||
yyYear = $1 / 10000;
|
||||
yyMonth = ($1 % 10000)/100;
|
||||
yyDay = $1 % 100;
|
||||
yyHour = $3;
|
||||
yyMinutes = $5;
|
||||
yySeconds = $7;
|
||||
}
|
||||
| tISOBASE tISOBASE {
|
||||
yyYear = $1 / 10000;
|
||||
yyMonth = ($1 % 10000)/100;
|
||||
@@ -412,9 +350,34 @@ iso : tISOBASE tZONE tISOBASE {
|
||||
yyMinutes = ($2 % 10000)/100;
|
||||
yySeconds = $2 % 100;
|
||||
}
|
||||
| tISOBASE SP tUNUMBER ':' tUNUMBER ':' tUNUMBER {
|
||||
yyYear = $1 / 10000;
|
||||
yyMonth = ($1 % 10000)/100;
|
||||
yyDay = $1 % 100;
|
||||
yyHour = $3;
|
||||
yyMinutes = $5;
|
||||
yySeconds = $7;
|
||||
}
|
||||
| tISOBASE tZONE tUNUMBER ':' tUNUMBER ':' tUNUMBER {
|
||||
if ($2 != HOUR( 7)) YYABORT; /* T */
|
||||
yyYear = $1 / 10000;
|
||||
yyMonth = ($1 % 10000)/100;
|
||||
yyDay = $1 % 100;
|
||||
yyHour = $3;
|
||||
yyMinutes = $5;
|
||||
yySeconds = $7;
|
||||
}
|
||||
| tISOBASE SP tISOBASE {
|
||||
yyYear = $1 / 10000;
|
||||
yyMonth = ($1 % 10000)/100;
|
||||
yyDay = $1 % 100;
|
||||
yyHour = $3 / 10000;
|
||||
yyMinutes = ($3 % 10000)/100;
|
||||
yySeconds = $3 % 100;
|
||||
}
|
||||
;
|
||||
|
||||
trek : tSTARDATE tUNUMBER '.' tUNUMBER {
|
||||
trek : tSTARDATE INTNUM '.' tUNUMBER {
|
||||
/*
|
||||
* Offset computed year by -377 so that the returned years will be
|
||||
* in a range accessible with a 32 bit clock seconds value.
|
||||
@@ -436,16 +399,19 @@ relspec : relunits tAGO {
|
||||
| relunits
|
||||
;
|
||||
|
||||
relunits : sign tUNUMBER unit {
|
||||
relunits : sign SP INTNUM unit {
|
||||
*yyRelPointer += $1 * $3 * $4;
|
||||
}
|
||||
| sign INTNUM unit {
|
||||
*yyRelPointer += $1 * $2 * $3;
|
||||
}
|
||||
| tUNUMBER unit {
|
||||
| INTNUM unit {
|
||||
*yyRelPointer += $1 * $2;
|
||||
}
|
||||
| tNEXT unit {
|
||||
*yyRelPointer += $2;
|
||||
}
|
||||
| tNEXT tUNUMBER unit {
|
||||
| tNEXT INTNUM unit {
|
||||
*yyRelPointer += $2 * $3;
|
||||
}
|
||||
| unit {
|
||||
@@ -475,7 +441,15 @@ unit : tSEC_UNIT {
|
||||
}
|
||||
;
|
||||
|
||||
number : tUNUMBER {
|
||||
INTNUM : tUNUMBER {
|
||||
$$ = $1;
|
||||
}
|
||||
| tISOBASE {
|
||||
$$ = $1;
|
||||
}
|
||||
;
|
||||
|
||||
number : INTNUM {
|
||||
if (yyHaveTime && yyHaveDate && !yyHaveRel) {
|
||||
yyYear = $1;
|
||||
} else {
|
||||
@@ -619,6 +593,8 @@ static const TABLE TimezoneTable[] = {
|
||||
{ "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
|
||||
{ "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
|
||||
{ "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
|
||||
{ "akst", tZONE, HOUR( 9) }, /* Alaska Standard */
|
||||
{ "akdt", tDAYZONE, HOUR( 9) }, /* Alaska Daylight */
|
||||
{ "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
|
||||
{ "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
|
||||
{ "cat", tZONE, HOUR(10) }, /* Central Alaska */
|
||||
@@ -703,6 +679,18 @@ static const TABLE MilitaryTable[] = {
|
||||
{ NULL, 0, 0 }
|
||||
};
|
||||
|
||||
static inline const char *
|
||||
bypassSpaces(
|
||||
register const char *s)
|
||||
{
|
||||
if (isspace(UCHAR(*s))) {
|
||||
do {
|
||||
s++;
|
||||
} while (isspace(UCHAR(*s)));
|
||||
}
|
||||
return s;
|
||||
}
|
||||
|
||||
/*
|
||||
* Dump error messages in the bit bucket.
|
||||
*/
|
||||
@@ -730,11 +718,11 @@ TclDateerror(
|
||||
infoPtr->separatrix = "\n";
|
||||
}
|
||||
|
||||
static time_t
|
||||
int
|
||||
ToSeconds(
|
||||
time_t Hours,
|
||||
time_t Minutes,
|
||||
time_t Seconds,
|
||||
int Hours,
|
||||
int Minutes,
|
||||
int Seconds,
|
||||
MERIDIAN Meridian)
|
||||
{
|
||||
if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59) {
|
||||
@@ -776,11 +764,11 @@ LookupWord(
|
||||
|
||||
Tcl_UtfToLower(buff);
|
||||
|
||||
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
|
||||
if (*buff == 'a' && (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0)) {
|
||||
yylvalPtr->Meridian = MERam;
|
||||
return tMERIDIAN;
|
||||
}
|
||||
if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
|
||||
if (*buff == 'p' && (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0)) {
|
||||
yylvalPtr->Meridian = MERpm;
|
||||
return tMERIDIAN;
|
||||
}
|
||||
@@ -897,29 +885,38 @@ TclDatelex(
|
||||
|
||||
location->first_column = yyInput - info->dateStart;
|
||||
for ( ; ; ) {
|
||||
while (isspace(UCHAR(*yyInput))) {
|
||||
yyInput++;
|
||||
|
||||
if (isspace(UCHAR(*yyInput))) {
|
||||
yyInput = bypassSpaces(yyInput);
|
||||
/* ignore space at end of text and before some words */
|
||||
c = *yyInput;
|
||||
if (c != '\0' && !isalpha(UCHAR(c))) {
|
||||
return SP;
|
||||
}
|
||||
}
|
||||
|
||||
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
|
||||
|
||||
/*
|
||||
* Convert the string into a number; count the number of digits.
|
||||
*/
|
||||
register int num = c - '0';
|
||||
p = (char *)yyInput;
|
||||
while (isdigit(UCHAR(c = *(++p)))) {
|
||||
num *= 10;
|
||||
num += c - '0';
|
||||
};
|
||||
yylvalPtr->Number = num;
|
||||
yyDigitCount = p - yyInput;
|
||||
yyInput = p;
|
||||
|
||||
Count = 0;
|
||||
for (yylvalPtr->Number = 0;
|
||||
isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */
|
||||
yylvalPtr->Number = 10 * yylvalPtr->Number + c - '0';
|
||||
Count++;
|
||||
}
|
||||
yyInput--;
|
||||
yyDigitCount = Count;
|
||||
|
||||
/* ignore spaces after digits (optional) */
|
||||
yyInput = bypassSpaces(yyInput);
|
||||
/*
|
||||
* A number with 6 or more digits is considered an ISO 8601 base.
|
||||
*/
|
||||
|
||||
if (Count >= 6) {
|
||||
if (yyDigitCount >= 6) {
|
||||
location->last_column = yyInput - info->dateStart - 1;
|
||||
return tISOBASE;
|
||||
} else {
|
||||
@@ -928,6 +925,7 @@ TclDatelex(
|
||||
}
|
||||
}
|
||||
if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
|
||||
int ret;
|
||||
for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */
|
||||
|| c == '.'; ) {
|
||||
if (p < &buff[sizeof buff - 1]) {
|
||||
@@ -937,7 +935,30 @@ TclDatelex(
|
||||
*p = '\0';
|
||||
yyInput--;
|
||||
location->last_column = yyInput - info->dateStart - 1;
|
||||
return LookupWord(yylvalPtr, buff);
|
||||
ret = LookupWord(yylvalPtr, buff);
|
||||
/*
|
||||
* lookahead for +/- digit, to differentiate between "GMT+1000 day" and "GMT +1000 day",
|
||||
* bypass spaces after token (but ignore by TZ+OFFS), because should
|
||||
* recognize next SP token, if TZ only.
|
||||
*/
|
||||
if (ret == tZONE || ret == tDAYZONE) {
|
||||
c = *yyInput;
|
||||
if ((c == '+' || c == '-') && isdigit(UCHAR(*(yyInput+1)))) {
|
||||
if ( !isdigit(UCHAR(*(yyInput+2)))
|
||||
|| !isdigit(UCHAR(*(yyInput+3)))) {
|
||||
/* GMT+1, GMT-10, etc. */
|
||||
return tZONEwO2;
|
||||
}
|
||||
if ( isdigit(UCHAR(*(yyInput+4)))
|
||||
&& !isdigit(UCHAR(*(yyInput+5)))) {
|
||||
/* GMT+1000, etc. */
|
||||
return tZONEwO4;
|
||||
}
|
||||
}
|
||||
}
|
||||
yyInput = bypassSpaces(yyInput);
|
||||
return ret;
|
||||
|
||||
}
|
||||
if (c != '(') {
|
||||
location->last_column = yyInput - info->dateStart;
|
||||
@@ -957,65 +978,46 @@ TclDatelex(
|
||||
} while (Count > 0);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
TclClockOldscanObjCmd(
|
||||
ClientData clientData, /* Unused */
|
||||
TclClockFreeScan(
|
||||
Tcl_Interp *interp, /* Tcl interpreter */
|
||||
int objc, /* Count of paraneters */
|
||||
Tcl_Obj *const *objv) /* Parameters */
|
||||
DateInfo *info) /* Input and result parameters */
|
||||
{
|
||||
Tcl_Obj *result, *resultElement;
|
||||
int yr, mo, da;
|
||||
DateInfo dateInfo;
|
||||
DateInfo* info = &dateInfo;
|
||||
int status;
|
||||
|
||||
if (objc != 5) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv,
|
||||
"stringToParse baseYear baseMonth baseDay" );
|
||||
return TCL_ERROR;
|
||||
}
|
||||
#if YYDEBUG
|
||||
/* enable debugging if compiled with YYDEBUG */
|
||||
yydebug = 1;
|
||||
#endif
|
||||
|
||||
yyInput = Tcl_GetString( objv[1] );
|
||||
dateInfo.dateStart = yyInput;
|
||||
/*
|
||||
* yyInput = stringToParse;
|
||||
*
|
||||
* ClockInitDateInfo(info) should be executed to pre-init info;
|
||||
*/
|
||||
|
||||
yyHaveDate = 0;
|
||||
if (Tcl_GetIntFromObj(interp, objv[2], &yr) != TCL_OK
|
||||
|| Tcl_GetIntFromObj(interp, objv[3], &mo) != TCL_OK
|
||||
|| Tcl_GetIntFromObj(interp, objv[4], &da) != TCL_OK) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
yyYear = yr; yyMonth = mo; yyDay = da;
|
||||
yyDSTmode = DSTmaybe;
|
||||
|
||||
yyHaveTime = 0;
|
||||
yyHour = 0; yyMinutes = 0; yySeconds = 0; yyMeridian = MER24;
|
||||
info->messages = Tcl_NewObj();
|
||||
info->separatrix = "";
|
||||
Tcl_IncrRefCount(info->messages);
|
||||
|
||||
yyHaveZone = 0;
|
||||
yyTimezone = 0; yyDSTmode = DSTmaybe;
|
||||
info->dateStart = yyInput;
|
||||
|
||||
yyHaveOrdinalMonth = 0;
|
||||
yyMonthOrdinal = 0;
|
||||
/* ignore spaces at begin */
|
||||
yyInput = bypassSpaces(yyInput);
|
||||
|
||||
yyHaveDay = 0;
|
||||
yyDayOrdinal = 0; yyDayNumber = 0;
|
||||
|
||||
yyHaveRel = 0;
|
||||
yyRelMonth = 0; yyRelDay = 0; yyRelSeconds = 0; yyRelPointer = NULL;
|
||||
|
||||
dateInfo.messages = Tcl_NewObj();
|
||||
dateInfo.separatrix = "";
|
||||
Tcl_IncrRefCount(dateInfo.messages);
|
||||
|
||||
status = yyparse(&dateInfo);
|
||||
/* parse */
|
||||
status = yyparse(info);
|
||||
if (status == 1) {
|
||||
Tcl_SetObjResult(interp, dateInfo.messages);
|
||||
Tcl_DecrRefCount(dateInfo.messages);
|
||||
Tcl_SetObjResult(interp, info->messages);
|
||||
Tcl_DecrRefCount(info->messages);
|
||||
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL);
|
||||
return TCL_ERROR;
|
||||
} else if (status == 2) {
|
||||
Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
|
||||
Tcl_DecrRefCount(dateInfo.messages);
|
||||
Tcl_DecrRefCount(info->messages);
|
||||
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
|
||||
return TCL_ERROR;
|
||||
} else if (status != 0) {
|
||||
@@ -1023,11 +1025,11 @@ TclClockOldscanObjCmd(
|
||||
"from date parser. Please "
|
||||
"report this error as a "
|
||||
"bug in Tcl.", -1));
|
||||
Tcl_DecrRefCount(dateInfo.messages);
|
||||
Tcl_DecrRefCount(info->messages);
|
||||
Tcl_SetErrorCode(interp, "TCL", "BUG", NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
Tcl_DecrRefCount(dateInfo.messages);
|
||||
Tcl_DecrRefCount(info->messages);
|
||||
|
||||
if (yyHaveDate > 1) {
|
||||
Tcl_SetObjResult(interp,
|
||||
@@ -1060,64 +1062,6 @@ TclClockOldscanObjCmd(
|
||||
return TCL_ERROR;
|
||||
}
|
||||
|
||||
result = Tcl_NewObj();
|
||||
resultElement = Tcl_NewObj();
|
||||
if (yyHaveDate) {
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyYear));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyMonth));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyDay));
|
||||
}
|
||||
Tcl_ListObjAppendElement(interp, result, resultElement);
|
||||
|
||||
if (yyHaveTime) {
|
||||
Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int)
|
||||
ToSeconds(yyHour, yyMinutes, yySeconds, yyMeridian)));
|
||||
} else {
|
||||
Tcl_ListObjAppendElement(interp, result, Tcl_NewObj());
|
||||
}
|
||||
|
||||
resultElement = Tcl_NewObj();
|
||||
if (yyHaveZone) {
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) -yyTimezone));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj(1 - yyDSTmode));
|
||||
}
|
||||
Tcl_ListObjAppendElement(interp, result, resultElement);
|
||||
|
||||
resultElement = Tcl_NewObj();
|
||||
if (yyHaveRel) {
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyRelMonth));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyRelDay));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyRelSeconds));
|
||||
}
|
||||
Tcl_ListObjAppendElement(interp, result, resultElement);
|
||||
|
||||
resultElement = Tcl_NewObj();
|
||||
if (yyHaveDay && !yyHaveDate) {
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyDayOrdinal));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyDayNumber));
|
||||
}
|
||||
Tcl_ListObjAppendElement(interp, result, resultElement);
|
||||
|
||||
resultElement = Tcl_NewObj();
|
||||
if (yyHaveOrdinalMonth) {
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyMonthOrdinal));
|
||||
Tcl_ListObjAppendElement(interp, resultElement,
|
||||
Tcl_NewIntObj((int) yyMonth));
|
||||
}
|
||||
Tcl_ListObjAppendElement(interp, result, resultElement);
|
||||
|
||||
Tcl_SetObjResult(interp, result);
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
|
||||
@@ -2911,6 +2911,7 @@ MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
|
||||
const char *dict, int dictLength,
|
||||
const char **elementPtr, const char **nextPtr,
|
||||
int *sizePtr, int *literalPtr);
|
||||
MODULE_SCOPE Tcl_Obj * Tcl_DictObjSmartRef(Tcl_Interp *interp, Tcl_Obj *);
|
||||
/* TIP #280 - Modified token based evulation, with line information. */
|
||||
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
|
||||
int numBytes, int flags, int line,
|
||||
@@ -3199,10 +3200,22 @@ MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer,
|
||||
MODULE_SCOPE void TclInitThreadStorage(void);
|
||||
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
|
||||
MODULE_SCOPE void TclFinalizeThreadStorage(void);
|
||||
|
||||
#ifdef TCL_WIDE_CLICKS
|
||||
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
|
||||
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
|
||||
MODULE_SCOPE double TclpWideClickInMicrosec(void);
|
||||
#else
|
||||
# ifdef _WIN32
|
||||
# define TCL_WIDE_CLICKS 1
|
||||
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
|
||||
MODULE_SCOPE double TclpWideClickInMicrosec(void);
|
||||
# define TclpWideClicksToNanoseconds(clicks) \
|
||||
((double)(clicks) * TclpWideClickInMicrosec() * 1000)
|
||||
# endif
|
||||
#endif
|
||||
MODULE_SCOPE Tcl_WideInt TclpGetMicroseconds(void);
|
||||
|
||||
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
|
||||
MODULE_SCOPE void * TclpThreadCreateKey(void);
|
||||
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
|
||||
@@ -3472,6 +3485,9 @@ MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
|
||||
MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData,
|
||||
Tcl_Interp *interp, int objc,
|
||||
Tcl_Obj *const objv[]);
|
||||
@@ -4927,6 +4943,13 @@ typedef struct NRE_callback {
|
||||
#define Tcl_Free(ptr) TclpFree(ptr)
|
||||
#endif
|
||||
|
||||
/*
|
||||
* Other externals.
|
||||
*/
|
||||
|
||||
MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment
|
||||
* (if changed with tcl-env). */
|
||||
|
||||
#endif /* _TCLINT */
|
||||
|
||||
/*
|
||||
|
||||
@@ -0,0 +1,528 @@
|
||||
/*
|
||||
* tclStrIdxTree.c --
|
||||
*
|
||||
* Contains the routines for managing string index tries in Tcl.
|
||||
*
|
||||
* This code is back-ported from the tclSE engine, by Serg G. Brester.
|
||||
*
|
||||
* Copyright (c) 2016 by Sergey G. Brester aka sebres. All rights reserved.
|
||||
*
|
||||
* See the file "license.terms" for information on usage and redistribution of
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*
|
||||
* -----------------------------------------------------------------------
|
||||
*
|
||||
* String index tries are prepaired structures used for fast greedy search of the string
|
||||
* (index) by unique string prefix as key.
|
||||
*
|
||||
* Index tree build for two lists together can be explained in the following datagram
|
||||
*
|
||||
* Lists:
|
||||
*
|
||||
* {Januar Februar Maerz April Mai Juni Juli August September Oktober November Dezember}
|
||||
* {Jnr Fbr Mrz Apr Mai Jni Jli Agt Spt Okt Nvb Dzb}
|
||||
*
|
||||
* Index-Tree:
|
||||
*
|
||||
* j 0 * ...
|
||||
* anuar 1 *
|
||||
* u 0 * a 0
|
||||
* ni 6 * pril 4
|
||||
* li 7 * ugust 8
|
||||
* n 0 * gt 8
|
||||
* r 1 * s 9
|
||||
* i 6 * eptember 9
|
||||
* li 7 * pt 9
|
||||
* f 2 * oktober 10
|
||||
* ebruar 2 * n 11
|
||||
* br 2 * ovember 11
|
||||
* m 0 * vb 11
|
||||
* a 0 * d 12
|
||||
* erz 3 * ezember 12
|
||||
* i 5 * zb 12
|
||||
* rz 3 *
|
||||
* ...
|
||||
*
|
||||
* Thereby value 0 shows pure group items (corresponding ambigous matches).
|
||||
* But the group may have a value if it contains only same values
|
||||
* (see for example group "f" above).
|
||||
*
|
||||
* StrIdxTree's are very fast, so:
|
||||
* build of above-mentioned tree takes about 10 microseconds.
|
||||
* search of string index in this tree takes fewer as 0.1 microseconds.
|
||||
*
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tclStrIdxTree.h"
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclStrIdxTreeSearch --
|
||||
*
|
||||
* Find largest part of string "start" in indexed tree (case sensitive).
|
||||
*
|
||||
* Also used for building of string index tree.
|
||||
*
|
||||
* Results:
|
||||
* Return position of UTF character in start after last equal character
|
||||
* and found item (with parent).
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
const char*
|
||||
TclStrIdxTreeSearch(
|
||||
TclStrIdxTree **foundParent, /* Return value of found sub tree (used for tree build) */
|
||||
TclStrIdx **foundItem, /* Return value of found item */
|
||||
TclStrIdxTree *tree, /* Index tree will be browsed */
|
||||
const char *start, /* UTF string to find in tree */
|
||||
const char *end) /* End of string */
|
||||
{
|
||||
TclStrIdxTree *parent = tree, *prevParent = tree;
|
||||
TclStrIdx *item = tree->firstPtr, *prevItem = NULL;
|
||||
const char *s = start, *f, *cin, *cinf, *prevf = NULL;
|
||||
int offs = 0;
|
||||
|
||||
if (item == NULL) {
|
||||
goto done;
|
||||
}
|
||||
|
||||
/* search in tree */
|
||||
do {
|
||||
cinf = cin = TclGetString(item->key) + offs;
|
||||
f = TclUtfFindEqualNCInLwr(s, end, cin, cin + item->length, &cinf);
|
||||
/* if something was found */
|
||||
if (f > s) {
|
||||
/* if whole string was found */
|
||||
if (f >= end) {
|
||||
start = f;
|
||||
goto done;
|
||||
};
|
||||
/* set new offset and shift start string */
|
||||
offs += cinf - cin;
|
||||
s = f;
|
||||
/* if match item, go deeper as long as possible */
|
||||
if (offs >= item->length && item->childTree.firstPtr) {
|
||||
/* save previuosly found item (if not ambigous) for
|
||||
* possible fallback (few greedy match) */
|
||||
if (item->value != NULL) {
|
||||
prevf = f;
|
||||
prevItem = item;
|
||||
prevParent = parent;
|
||||
}
|
||||
parent = &item->childTree;
|
||||
item = item->childTree.firstPtr;
|
||||
continue;
|
||||
}
|
||||
/* no children - return this item and current chars found */
|
||||
start = f;
|
||||
goto done;
|
||||
}
|
||||
|
||||
item = item->nextPtr;
|
||||
|
||||
} while (item != NULL);
|
||||
|
||||
/* fallback (few greedy match) not ambigous (has a value) */
|
||||
if (prevItem != NULL) {
|
||||
item = prevItem;
|
||||
parent = prevParent;
|
||||
start = prevf;
|
||||
}
|
||||
|
||||
done:
|
||||
|
||||
if (foundParent)
|
||||
*foundParent = parent;
|
||||
if (foundItem)
|
||||
*foundItem = item;
|
||||
return start;
|
||||
}
|
||||
|
||||
void
|
||||
TclStrIdxTreeFree(
|
||||
TclStrIdx *tree)
|
||||
{
|
||||
while (tree != NULL) {
|
||||
TclStrIdx *t;
|
||||
Tcl_DecrRefCount(tree->key);
|
||||
if (tree->childTree.firstPtr != NULL) {
|
||||
TclStrIdxTreeFree(tree->childTree.firstPtr);
|
||||
}
|
||||
t = tree, tree = tree->nextPtr;
|
||||
ckfree(t);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Several bidirectional list primitives
|
||||
*/
|
||||
static inline void
|
||||
TclStrIdxTreeInsertBranch(
|
||||
TclStrIdxTree *parent,
|
||||
register TclStrIdx *item,
|
||||
register TclStrIdx *child)
|
||||
{
|
||||
if (parent->firstPtr == child)
|
||||
parent->firstPtr = item;
|
||||
if (parent->lastPtr == child)
|
||||
parent->lastPtr = item;
|
||||
if ( (item->nextPtr = child->nextPtr) ) {
|
||||
item->nextPtr->prevPtr = item;
|
||||
child->nextPtr = NULL;
|
||||
}
|
||||
if ( (item->prevPtr = child->prevPtr) ) {
|
||||
item->prevPtr->nextPtr = item;
|
||||
child->prevPtr = NULL;
|
||||
}
|
||||
item->childTree.firstPtr = child;
|
||||
item->childTree.lastPtr = child;
|
||||
}
|
||||
|
||||
static inline void
|
||||
TclStrIdxTreeAppend(
|
||||
register TclStrIdxTree *parent,
|
||||
register TclStrIdx *item)
|
||||
{
|
||||
if (parent->lastPtr != NULL) {
|
||||
parent->lastPtr->nextPtr = item;
|
||||
}
|
||||
item->prevPtr = parent->lastPtr;
|
||||
item->nextPtr = NULL;
|
||||
parent->lastPtr = item;
|
||||
if (parent->firstPtr == NULL) {
|
||||
parent->firstPtr = item;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclStrIdxTreeBuildFromList --
|
||||
*
|
||||
* Build or extend string indexed tree from tcl list.
|
||||
* If the values not given the values of built list are indices starts with 1.
|
||||
* Value of 0 is thereby reserved to the ambigous values.
|
||||
*
|
||||
* Important: by multiple lists, optimal tree can be created only if list with
|
||||
* larger strings used firstly.
|
||||
*
|
||||
* Results:
|
||||
* Returns a standard Tcl result.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
int
|
||||
TclStrIdxTreeBuildFromList(
|
||||
TclStrIdxTree *idxTree,
|
||||
int lstc,
|
||||
Tcl_Obj **lstv,
|
||||
ClientData *values)
|
||||
{
|
||||
Tcl_Obj **lwrv;
|
||||
int i, ret = TCL_ERROR;
|
||||
ClientData val;
|
||||
const char *s, *e, *f;
|
||||
TclStrIdx *item;
|
||||
|
||||
/* create lowercase reflection of the list keys */
|
||||
|
||||
lwrv = ckalloc(sizeof(Tcl_Obj*) * lstc);
|
||||
if (lwrv == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
for (i = 0; i < lstc; i++) {
|
||||
lwrv[i] = Tcl_DuplicateObj(lstv[i]);
|
||||
if (lwrv[i] == NULL) {
|
||||
return TCL_ERROR;
|
||||
}
|
||||
Tcl_IncrRefCount(lwrv[i]);
|
||||
lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i]));
|
||||
}
|
||||
|
||||
/* build index tree of the list keys */
|
||||
for (i = 0; i < lstc; i++) {
|
||||
TclStrIdxTree *foundParent = idxTree;
|
||||
e = s = TclGetString(lwrv[i]);
|
||||
e += lwrv[i]->length;
|
||||
val = values ? values[i] : INT2PTR(i+1);
|
||||
|
||||
/* ignore empty keys (impossible to index it) */
|
||||
if (lwrv[i]->length == 0) continue;
|
||||
|
||||
item = NULL;
|
||||
if (idxTree->firstPtr != NULL) {
|
||||
TclStrIdx *foundItem;
|
||||
f = TclStrIdxTreeSearch(&foundParent, &foundItem,
|
||||
idxTree, s, e);
|
||||
/* if common prefix was found */
|
||||
if (f > s) {
|
||||
/* ignore element if fulfilled or ambigous */
|
||||
if (f == e) {
|
||||
continue;
|
||||
}
|
||||
/* if shortest key was found with the same value,
|
||||
* just replace its current key with longest key */
|
||||
if ( foundItem->value == val
|
||||
&& foundItem->length <= lwrv[i]->length
|
||||
&& foundItem->length <= (f - s) /* only if found item is covered in full */
|
||||
&& foundItem->childTree.firstPtr == NULL
|
||||
) {
|
||||
Tcl_SetObjRef(foundItem->key, lwrv[i]);
|
||||
foundItem->length = lwrv[i]->length;
|
||||
continue;
|
||||
}
|
||||
/* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) )
|
||||
* but don't split by fulfilled child of found item ( ii->iii->iiii ) */
|
||||
if (foundItem->length != (f - s)) {
|
||||
/* first split found item (insert one between parent and found + new one) */
|
||||
item = ckalloc(sizeof(*item));
|
||||
if (item == NULL) {
|
||||
goto done;
|
||||
}
|
||||
Tcl_InitObjRef(item->key, foundItem->key);
|
||||
item->length = f - s;
|
||||
/* set value or mark as ambigous if not the same value of both */
|
||||
item->value = (foundItem->value == val) ? val : NULL;
|
||||
/* insert group item between foundParent and foundItem */
|
||||
TclStrIdxTreeInsertBranch(foundParent, item, foundItem);
|
||||
foundParent = &item->childTree;
|
||||
} else {
|
||||
/* the new item should be added as child of found item */
|
||||
foundParent = &foundItem->childTree;
|
||||
}
|
||||
}
|
||||
}
|
||||
/* append item at end of found parent */
|
||||
item = ckalloc(sizeof(*item));
|
||||
if (item == NULL) {
|
||||
goto done;
|
||||
}
|
||||
item->childTree.lastPtr = item->childTree.firstPtr = NULL;
|
||||
Tcl_InitObjRef(item->key, lwrv[i]);
|
||||
item->length = lwrv[i]->length;
|
||||
item->value = val;
|
||||
TclStrIdxTreeAppend(foundParent, item);
|
||||
};
|
||||
|
||||
ret = TCL_OK;
|
||||
|
||||
done:
|
||||
|
||||
if (lwrv != NULL) {
|
||||
for (i = 0; i < lstc; i++) {
|
||||
Tcl_DecrRefCount(lwrv[i]);
|
||||
}
|
||||
ckfree(lwrv);
|
||||
}
|
||||
|
||||
if (ret != TCL_OK) {
|
||||
if (idxTree->firstPtr != NULL) {
|
||||
TclStrIdxTreeFree(idxTree->firstPtr);
|
||||
}
|
||||
}
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
|
||||
static void
|
||||
StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr);
|
||||
static void
|
||||
StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr);
|
||||
|
||||
Tcl_ObjType StrIdxTreeObjType = {
|
||||
"str-idx-tree", /* name */
|
||||
StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */
|
||||
StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */
|
||||
StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
|
||||
NULL /* setFromAnyProc */
|
||||
};
|
||||
|
||||
Tcl_Obj*
|
||||
TclStrIdxTreeNewObj()
|
||||
{
|
||||
Tcl_Obj *objPtr = Tcl_NewObj();
|
||||
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
|
||||
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
|
||||
objPtr->typePtr = &StrIdxTreeObjType;
|
||||
/* return tree root in internal representation */
|
||||
return objPtr;
|
||||
}
|
||||
|
||||
static void
|
||||
StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
|
||||
{
|
||||
/* follow links (smart pointers) */
|
||||
if ( srcPtr->internalRep.twoPtrValue.ptr1 != NULL
|
||||
&& srcPtr->internalRep.twoPtrValue.ptr2 == NULL
|
||||
) {
|
||||
srcPtr = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr1;
|
||||
}
|
||||
/* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */
|
||||
Tcl_InitObjRef(*((Tcl_Obj **)©Ptr->internalRep.twoPtrValue.ptr1),
|
||||
srcPtr);
|
||||
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
|
||||
copyPtr->typePtr = &StrIdxTreeObjType;
|
||||
}
|
||||
|
||||
static void
|
||||
StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr)
|
||||
{
|
||||
/* follow links (smart pointers) */
|
||||
if ( objPtr->internalRep.twoPtrValue.ptr1 != NULL
|
||||
&& objPtr->internalRep.twoPtrValue.ptr2 == NULL
|
||||
) {
|
||||
/* is a link */
|
||||
Tcl_UnsetObjRef(*((Tcl_Obj **)&objPtr->internalRep.twoPtrValue.ptr1));
|
||||
} else {
|
||||
/* is a tree */
|
||||
TclStrIdxTree *tree = (TclStrIdxTree*)&objPtr->internalRep.twoPtrValue.ptr1;
|
||||
if (tree->firstPtr != NULL) {
|
||||
TclStrIdxTreeFree(tree->firstPtr);
|
||||
}
|
||||
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
|
||||
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
|
||||
}
|
||||
objPtr->typePtr = NULL;
|
||||
};
|
||||
|
||||
static void
|
||||
StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr)
|
||||
{
|
||||
/* currently only dummy empty string possible */
|
||||
objPtr->length = 0;
|
||||
objPtr->bytes = &tclEmptyString;
|
||||
};
|
||||
|
||||
TclStrIdxTree *
|
||||
TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr) {
|
||||
/* follow links (smart pointers) */
|
||||
if (objPtr->typePtr != &StrIdxTreeObjType) {
|
||||
return NULL;
|
||||
}
|
||||
if ( objPtr->internalRep.twoPtrValue.ptr1 != NULL
|
||||
&& objPtr->internalRep.twoPtrValue.ptr2 == NULL
|
||||
) {
|
||||
objPtr = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr1;
|
||||
}
|
||||
/* return tree root in internal representation */
|
||||
return (TclStrIdxTree*)&objPtr->internalRep.twoPtrValue.ptr1;
|
||||
}
|
||||
|
||||
/*
|
||||
* Several debug primitives
|
||||
*/
|
||||
#if 0
|
||||
/* currently unused, debug resp. test purposes only */
|
||||
|
||||
void
|
||||
TclStrIdxTreePrint(
|
||||
Tcl_Interp *interp,
|
||||
TclStrIdx *tree,
|
||||
int offs)
|
||||
{
|
||||
Tcl_Obj *obj[2];
|
||||
const char *s;
|
||||
Tcl_InitObjRef(obj[0], Tcl_NewStringObj("::puts", -1));
|
||||
while (tree != NULL) {
|
||||
s = TclGetString(tree->key) + offs;
|
||||
Tcl_InitObjRef(obj[1], Tcl_ObjPrintf("%*s%.*s\t:%d",
|
||||
offs, "", tree->length - offs, s, tree->value));
|
||||
Tcl_PutsObjCmd(NULL, interp, 2, obj);
|
||||
Tcl_UnsetObjRef(obj[1]);
|
||||
if (tree->childTree.firstPtr != NULL) {
|
||||
TclStrIdxTreePrint(interp, tree->childTree.firstPtr, tree->length);
|
||||
}
|
||||
tree = tree->nextPtr;
|
||||
}
|
||||
Tcl_UnsetObjRef(obj[0]);
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
TclStrIdxTreeTestObjCmd(
|
||||
ClientData clientData, Tcl_Interp *interp,
|
||||
int objc, Tcl_Obj *const objv[])
|
||||
{
|
||||
const char *cs, *cin, *ret;
|
||||
|
||||
static const char *const options[] = {
|
||||
"index", "puts-index", "findequal",
|
||||
NULL
|
||||
};
|
||||
enum optionInd {
|
||||
O_INDEX, O_PUTS_INDEX, O_FINDEQUAL
|
||||
};
|
||||
int optionIndex;
|
||||
|
||||
if (objc < 2) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
if (Tcl_GetIndexFromObj(interp, objv[1], options,
|
||||
"option", 0, &optionIndex) != TCL_OK) {
|
||||
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
|
||||
Tcl_GetString(objv[1]), NULL);
|
||||
return TCL_ERROR;
|
||||
}
|
||||
switch (optionIndex) {
|
||||
case O_FINDEQUAL:
|
||||
if (objc < 4) {
|
||||
Tcl_WrongNumArgs(interp, 1, objv, "");
|
||||
return TCL_ERROR;
|
||||
}
|
||||
cs = TclGetString(objv[2]);
|
||||
cin = TclGetString(objv[3]);
|
||||
ret = TclUtfFindEqual(
|
||||
cs, cs + objv[1]->length, cin, cin + objv[2]->length);
|
||||
Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs));
|
||||
break;
|
||||
case O_INDEX:
|
||||
case O_PUTS_INDEX:
|
||||
|
||||
if (1) {
|
||||
Tcl_Obj **lstv;
|
||||
int i, lstc;
|
||||
TclStrIdxTree idxTree = {NULL, NULL};
|
||||
i = 1;
|
||||
while (++i < objc) {
|
||||
if (TclListObjGetElements(interp, objv[i],
|
||||
&lstc, &lstv) != TCL_OK) {
|
||||
return TCL_ERROR;
|
||||
};
|
||||
TclStrIdxTreeBuildFromList(&idxTree, lstc, lstv, NULL);
|
||||
}
|
||||
if (optionIndex == O_PUTS_INDEX) {
|
||||
TclStrIdxTreePrint(interp, idxTree.firstPtr, 0);
|
||||
}
|
||||
TclStrIdxTreeFree(idxTree.firstPtr);
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
return TCL_OK;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
/*
|
||||
* Local Variables:
|
||||
* mode: c
|
||||
* c-basic-offset: 4
|
||||
* fill-column: 78
|
||||
* End:
|
||||
*/
|
||||
@@ -0,0 +1,169 @@
|
||||
/*
|
||||
* tclStrIdxTree.h --
|
||||
*
|
||||
* Declarations of string index tries and other primitives currently
|
||||
* back-ported from tclSE.
|
||||
*
|
||||
* Copyright (c) 2016 Serg G. Brester (aka sebres)
|
||||
*
|
||||
* See the file "license.terms" for information on usage and redistribution
|
||||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#ifndef _TCLSTRIDXTREE_H
|
||||
#define _TCLSTRIDXTREE_H
|
||||
|
||||
|
||||
/*
|
||||
* Main structures declarations of index tree and entry
|
||||
*/
|
||||
|
||||
typedef struct TclStrIdxTree {
|
||||
struct TclStrIdx *firstPtr;
|
||||
struct TclStrIdx *lastPtr;
|
||||
} TclStrIdxTree;
|
||||
|
||||
typedef struct TclStrIdx {
|
||||
struct TclStrIdxTree childTree;
|
||||
struct TclStrIdx *nextPtr;
|
||||
struct TclStrIdx *prevPtr;
|
||||
Tcl_Obj *key;
|
||||
int length;
|
||||
ClientData value;
|
||||
} TclStrIdx;
|
||||
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclUtfFindEqual, TclUtfFindEqualNC --
|
||||
*
|
||||
* Find largest part of string cs in string cin (case sensitive and not).
|
||||
*
|
||||
* Results:
|
||||
* Return position of UTF character in cs after last equal character.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static inline const char *
|
||||
TclUtfFindEqual(
|
||||
register const char *cs, /* UTF string to find in cin. */
|
||||
register const char *cse, /* End of cs */
|
||||
register const char *cin, /* UTF string will be browsed. */
|
||||
register const char *cine) /* End of cin */
|
||||
{
|
||||
register const char *ret = cs;
|
||||
Tcl_UniChar ch1, ch2;
|
||||
do {
|
||||
cs += TclUtfToUniChar(cs, &ch1);
|
||||
cin += TclUtfToUniChar(cin, &ch2);
|
||||
if (ch1 != ch2) break;
|
||||
} while ((ret = cs) < cse && cin < cine);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static inline const char *
|
||||
TclUtfFindEqualNC(
|
||||
register const char *cs, /* UTF string to find in cin. */
|
||||
register const char *cse, /* End of cs */
|
||||
register const char *cin, /* UTF string will be browsed. */
|
||||
register const char *cine, /* End of cin */
|
||||
const char **cinfnd) /* Return position in cin */
|
||||
{
|
||||
register const char *ret = cs;
|
||||
Tcl_UniChar ch1, ch2;
|
||||
do {
|
||||
cs += TclUtfToUniChar(cs, &ch1);
|
||||
cin += TclUtfToUniChar(cin, &ch2);
|
||||
if (ch1 != ch2) {
|
||||
ch1 = Tcl_UniCharToLower(ch1);
|
||||
ch2 = Tcl_UniCharToLower(ch2);
|
||||
if (ch1 != ch2) break;
|
||||
}
|
||||
*cinfnd = cin;
|
||||
} while ((ret = cs) < cse && cin < cine);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static inline const char *
|
||||
TclUtfFindEqualNCInLwr(
|
||||
register const char *cs, /* UTF string (in anycase) to find in cin. */
|
||||
register const char *cse, /* End of cs */
|
||||
register const char *cin, /* UTF string (in lowercase) will be browsed. */
|
||||
register const char *cine, /* End of cin */
|
||||
const char **cinfnd) /* Return position in cin */
|
||||
{
|
||||
register const char *ret = cs;
|
||||
Tcl_UniChar ch1, ch2;
|
||||
do {
|
||||
cs += TclUtfToUniChar(cs, &ch1);
|
||||
cin += TclUtfToUniChar(cin, &ch2);
|
||||
if (ch1 != ch2) {
|
||||
ch1 = Tcl_UniCharToLower(ch1);
|
||||
if (ch1 != ch2) break;
|
||||
}
|
||||
*cinfnd = cin;
|
||||
} while ((ret = cs) < cse && cin < cine);
|
||||
return ret;
|
||||
}
|
||||
|
||||
static inline const char *
|
||||
TclUtfNext(
|
||||
register const char *src) /* The current location in the string. */
|
||||
{
|
||||
if (((unsigned char) *(src)) < 0xC0) {
|
||||
return ++src;
|
||||
} else {
|
||||
Tcl_UniChar ch;
|
||||
return src + TclUtfToUniChar(src, &ch);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Primitives to safe set, reset and free references.
|
||||
*/
|
||||
|
||||
#define Tcl_UnsetObjRef(obj) \
|
||||
if (obj != NULL) { Tcl_DecrRefCount(obj); obj = NULL; }
|
||||
#define Tcl_InitObjRef(obj, val) \
|
||||
obj = val; if (obj) { Tcl_IncrRefCount(obj); }
|
||||
#define Tcl_SetObjRef(obj, val) \
|
||||
if (1) { \
|
||||
Tcl_Obj *nval = val; \
|
||||
if (obj != nval) { \
|
||||
Tcl_Obj *prev = obj; \
|
||||
Tcl_InitObjRef(obj, nval); \
|
||||
if (prev != NULL) { Tcl_DecrRefCount(prev); }; \
|
||||
} \
|
||||
}
|
||||
|
||||
/*
|
||||
* Prototypes of module functions.
|
||||
*/
|
||||
|
||||
MODULE_SCOPE const char*
|
||||
TclStrIdxTreeSearch(TclStrIdxTree **foundParent,
|
||||
TclStrIdx **foundItem, TclStrIdxTree *tree,
|
||||
const char *start, const char *end);
|
||||
|
||||
MODULE_SCOPE int TclStrIdxTreeBuildFromList(TclStrIdxTree *idxTree,
|
||||
int lstc, Tcl_Obj **lstv, ClientData *values);
|
||||
|
||||
MODULE_SCOPE Tcl_Obj*
|
||||
TclStrIdxTreeNewObj();
|
||||
|
||||
MODULE_SCOPE TclStrIdxTree*
|
||||
TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr);
|
||||
|
||||
#if 1
|
||||
|
||||
MODULE_SCOPE int TclStrIdxTreeTestObjCmd(ClientData, Tcl_Interp *,
|
||||
int, Tcl_Obj *const objv[]);
|
||||
#endif
|
||||
|
||||
#endif /* _TCLSTRIDXTREE_H */
|
||||
+227
-2691
File diff suppressed because it is too large
Load Diff
+61
-37
@@ -45,6 +45,7 @@ if {![info exists auto_path]} {
|
||||
set auto_path ""
|
||||
}
|
||||
}
|
||||
|
||||
namespace eval tcl {
|
||||
variable Dir
|
||||
foreach Dir [list $::tcl_library [file dirname $::tcl_library]] {
|
||||
@@ -66,12 +67,12 @@ namespace eval tcl {
|
||||
}
|
||||
|
||||
if {![interp issafe]} {
|
||||
variable Path [encoding dirs]
|
||||
set Dir [file join $::tcl_library encoding]
|
||||
if {$Dir ni $Path} {
|
||||
variable Path [encoding dirs]
|
||||
set Dir [file join $::tcl_library encoding]
|
||||
if {$Dir ni $Path} {
|
||||
lappend Path $Dir
|
||||
encoding dirs $Path
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# TIP #255 min and max functions
|
||||
@@ -155,6 +156,17 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
|
||||
if {[interp issafe]} {
|
||||
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
|
||||
} else {
|
||||
# Default known auto_index (avoid loading auto index implicit after interp create):
|
||||
|
||||
array set ::auto_index {
|
||||
::tcl::tm::UnknownHandler {source [info library]/tm.tcl}
|
||||
::tclPkgUnknown {source [info library]/package.tcl}
|
||||
::history {source [info library]/history.tcl}
|
||||
}
|
||||
|
||||
# The newest possibility to load whole namespace:
|
||||
array set ::auto_index_ns {}
|
||||
|
||||
# Set up search for Tcl Modules (TIP #189).
|
||||
# and setup platform specific unknown package handlers
|
||||
if {$tcl_platform(os) eq "Darwin"
|
||||
@@ -167,22 +179,21 @@ if {[interp issafe]} {
|
||||
|
||||
# Set up the 'clock' ensemble
|
||||
|
||||
namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]
|
||||
|
||||
proc ::tcl::initClock {} {
|
||||
# Auto-loading stubs for 'clock.tcl'
|
||||
|
||||
foreach cmd {add format scan} {
|
||||
proc ::tcl::clock::$cmd args {
|
||||
variable TclLibDir
|
||||
source -encoding utf-8 [file join $TclLibDir clock.tcl]
|
||||
return [uplevel 1 [info level 0]]
|
||||
}
|
||||
proc clock args {
|
||||
set cmdmap [dict create]
|
||||
foreach cmd {add clicks format microseconds milliseconds scan seconds configure} {
|
||||
dict set cmdmap $cmd ::tcl::clock::$cmd
|
||||
}
|
||||
namespace inscope ::tcl::clock [list namespace ensemble create -command \
|
||||
[uplevel 1 [list ::namespace origin [::lindex [info level 0] 0]]] \
|
||||
-map $cmdmap]
|
||||
|
||||
rename ::tcl::initClock {}
|
||||
uplevel 1 [info level 0]
|
||||
}
|
||||
::tcl::initClock
|
||||
# Auto-loading stubs for 'clock.tcl'
|
||||
set ::auto_index_ns(::tcl::clock) {::namespace inscope ::tcl::clock {
|
||||
::source -encoding utf-8 [::file join [info library] clock.tcl]
|
||||
}}
|
||||
}
|
||||
|
||||
# Conditionalize for presence of exec.
|
||||
@@ -416,18 +427,22 @@ proc unknown args {
|
||||
# for instance. If not given, namespace current is used.
|
||||
|
||||
proc auto_load {cmd {namespace {}}} {
|
||||
global auto_index auto_path
|
||||
global auto_index auto_index_ns auto_path
|
||||
|
||||
# qualify names:
|
||||
if {$namespace eq ""} {
|
||||
set namespace [uplevel 1 [list ::namespace current]]
|
||||
}
|
||||
set nameList [auto_qualify $cmd $namespace]
|
||||
# workaround non canonical auto_index entries that might be around
|
||||
# from older auto_mkindex versions
|
||||
lappend nameList $cmd
|
||||
foreach name $nameList {
|
||||
if {$cmd ni $nameList} {lappend nameList $cmd}
|
||||
|
||||
# try to load (and create sub-cmd handler "_sub_load_cmd" for further usage):
|
||||
foreach name $nameList [set _sub_load_cmd {
|
||||
# via auto_index:
|
||||
if {[info exists auto_index($name)]} {
|
||||
namespace eval :: $auto_index($name)
|
||||
namespace inscope :: $auto_index($name)
|
||||
# There's a couple of ways to look for a command of a given
|
||||
# name. One is to use
|
||||
# info commands $name
|
||||
@@ -439,22 +454,31 @@ proc auto_load {cmd {namespace {}}} {
|
||||
return 1
|
||||
}
|
||||
}
|
||||
}
|
||||
if {![info exists auto_path]} {
|
||||
return 0
|
||||
}
|
||||
|
||||
if {![auto_load_index]} {
|
||||
return 0
|
||||
}
|
||||
foreach name $nameList {
|
||||
if {[info exists auto_index($name)]} {
|
||||
namespace eval :: $auto_index($name)
|
||||
# via auto_index_ns - resolver for the whole namespace loaders
|
||||
if {[set ns [::namespace qualifiers $name]] ni {"" "::"} &&
|
||||
[info exists auto_index_ns($ns)]
|
||||
} {
|
||||
# remove handler before loading (prevents several self-recursion cases):
|
||||
set ldr $auto_index_ns($ns); unset auto_index_ns($ns)
|
||||
namespace inscope :: $ldr
|
||||
# if got it:
|
||||
if {[namespace which -command $name] ne ""} {
|
||||
return 1
|
||||
}
|
||||
}
|
||||
}]
|
||||
|
||||
# load auto_index if possible:
|
||||
if {![info exists auto_path]} {
|
||||
return 0
|
||||
}
|
||||
if {![auto_load_index]} {
|
||||
return 0
|
||||
}
|
||||
|
||||
# try again (something new could be loaded):
|
||||
foreach name $nameList $_sub_load_cmd
|
||||
|
||||
return 0
|
||||
}
|
||||
|
||||
@@ -601,12 +625,12 @@ proc auto_import {pattern} {
|
||||
auto_load_index
|
||||
|
||||
foreach pattern $patternList {
|
||||
foreach name [array names auto_index $pattern] {
|
||||
if {([namespace which -command $name] eq "")
|
||||
foreach name [array names auto_index $pattern] {
|
||||
if {([namespace which -command $name] eq "")
|
||||
&& ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
|
||||
namespace eval :: $auto_index($name)
|
||||
}
|
||||
}
|
||||
namespace inscope :: $auto_index($name)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@@ -2595,6 +2595,18 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
|
||||
return
|
||||
}
|
||||
|
||||
proc tcltest::__SortFiles {lst} {
|
||||
set slst {}
|
||||
foreach f $lst {
|
||||
lappend slst [list [file rootname $f] $f]
|
||||
}
|
||||
set lst {}
|
||||
foreach f [lsort -dictionary -index 0 $slst] {
|
||||
lappend lst [lindex $f 1]
|
||||
}
|
||||
return $lst
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
|
||||
# Procs that determine which tests/test files to run
|
||||
@@ -2659,6 +2671,7 @@ proc tcltest::GetMatchingFiles { args } {
|
||||
PrintError "No test files remain after applying your match and\
|
||||
skip patterns!"
|
||||
}
|
||||
|
||||
return $matchingFiles
|
||||
}
|
||||
|
||||
@@ -2782,7 +2795,7 @@ proc tcltest::runAllTests { {shell ""} } {
|
||||
puts [outputChannel] "Tests began at [eval $timeCmd]"
|
||||
|
||||
# Run each of the specified tests
|
||||
foreach file [lsort [GetMatchingFiles]] {
|
||||
foreach file [__SortFiles [GetMatchingFiles]] {
|
||||
set tail [file tail $file]
|
||||
puts [outputChannel] $tail
|
||||
flush [outputChannel]
|
||||
|
||||
@@ -0,0 +1,411 @@
|
||||
#!/usr/bin/tclsh
|
||||
# ------------------------------------------------------------------------
|
||||
#
|
||||
# test-performance.tcl --
|
||||
#
|
||||
# This file provides common performance tests for comparison of tcl-speed
|
||||
# degradation by switching between branches.
|
||||
# (currently for clock ensemble only)
|
||||
#
|
||||
# ------------------------------------------------------------------------
|
||||
#
|
||||
# Copyright (c) 2014 Serg G. Brester (aka sebres)
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file.
|
||||
#
|
||||
|
||||
array set in {-time 500}
|
||||
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
|
||||
array set in $argv
|
||||
}
|
||||
|
||||
## common test performance framework:
|
||||
if {![namespace exists ::tclTestPerf]} {
|
||||
source [file join [file dirname [info script]] test-performance.tcl]
|
||||
}
|
||||
|
||||
namespace eval ::tclTestPerf-TclClock {
|
||||
|
||||
namespace path {::tclTestPerf}
|
||||
|
||||
## set testing defaults:
|
||||
set ::env(TCL_TZ) :CET
|
||||
|
||||
# warm-up interpeter compiler env, clock platform-related features:
|
||||
|
||||
## warm-up test-related features (load clock.tcl, system zones, locales, etc.):
|
||||
clock scan "" -gmt 1
|
||||
clock scan ""
|
||||
clock scan "" -timezone :CET
|
||||
clock scan "" -format "" -locale en
|
||||
clock scan "" -format "" -locale de
|
||||
|
||||
## ------------------------------------------
|
||||
|
||||
proc test-format {{reptime 1000}} {
|
||||
_test_run $reptime {
|
||||
# Format : short, week only (in gmt)
|
||||
{clock format 1482525936 -format "%u" -gmt 1}
|
||||
# Format : short, week only (system zone)
|
||||
{clock format 1482525936 -format "%u"}
|
||||
# Format : short, week only (CEST)
|
||||
{clock format 1482525936 -format "%u" -timezone :CET}
|
||||
# Format : date only (in gmt)
|
||||
{clock format 1482525936 -format "%Y-%m-%d" -gmt 1}
|
||||
# Format : date only (system zone)
|
||||
{clock format 1482525936 -format "%Y-%m-%d"}
|
||||
# Format : date only (CEST)
|
||||
{clock format 1482525936 -format "%Y-%m-%d" -timezone :CET}
|
||||
# Format : time only (in gmt)
|
||||
{clock format 1482525936 -format "%H:%M" -gmt 1}
|
||||
# Format : time only (system zone)
|
||||
{clock format 1482525936 -format "%H:%M"}
|
||||
# Format : time only (CEST)
|
||||
{clock format 1482525936 -format "%H:%M" -timezone :CET}
|
||||
# Format : time only (in gmt)
|
||||
{clock format 1482525936 -format "%H:%M:%S" -gmt 1}
|
||||
# Format : time only (system zone)
|
||||
{clock format 1482525936 -format "%H:%M:%S"}
|
||||
# Format : time only (CEST)
|
||||
{clock format 1482525936 -format "%H:%M:%S" -timezone :CET}
|
||||
# Format : default (in gmt)
|
||||
{clock format 1482525936 -gmt 1 -locale en}
|
||||
# Format : default (system zone)
|
||||
{clock format 1482525936 -locale en}
|
||||
# Format : default (CEST)
|
||||
{clock format 1482525936 -timezone :CET -locale en}
|
||||
# Format : ISO date-time (in gmt, numeric zone)
|
||||
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -gmt 1}
|
||||
# Format : ISO date-time (system zone, CEST, numeric zone)
|
||||
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z"}
|
||||
# Format : ISO date-time (CEST, numeric zone)
|
||||
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -timezone :CET}
|
||||
# Format : ISO date-time (system zone, CEST)
|
||||
{clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %Z"}
|
||||
# Format : julian day with time (in gmt):
|
||||
{clock format 1246379415 -format "%J %H:%M:%S" -gmt 1}
|
||||
# Format : julian day with time (system zone):
|
||||
{clock format 1246379415 -format "%J %H:%M:%S"}
|
||||
|
||||
# Format : locale date-time (en):
|
||||
{clock format 1246379415 -format "%x %X" -locale en}
|
||||
# Format : locale date-time (de):
|
||||
{clock format 1246379415 -format "%x %X" -locale de}
|
||||
|
||||
# Format : locale lookup table month:
|
||||
{clock format 1246379400 -format "%b" -locale en -gmt 1}
|
||||
# Format : locale lookup 2 tables - month and day:
|
||||
{clock format 1246379400 -format "%b %Od" -locale en -gmt 1}
|
||||
# Format : locale lookup 3 tables - week, month and day:
|
||||
{clock format 1246379400 -format "%a %b %Od" -locale en -gmt 1}
|
||||
# Format : locale lookup 4 tables - week, month, day and year:
|
||||
{clock format 1246379400 -format "%a %b %Od %Oy" -locale en -gmt 1}
|
||||
|
||||
# Format : dynamic clock value (without converter caches):
|
||||
setup {set i 0}
|
||||
{clock format [incr i] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET}
|
||||
cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]}
|
||||
# Format : dynamic clock value (without any converter caches, zone range overflow):
|
||||
setup {set i 0}
|
||||
{clock format [incr i 86400] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET}
|
||||
cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]}
|
||||
|
||||
# Format : dynamic format (cacheable)
|
||||
{clock format 1246379415 -format [string trim "%d.%m.%Y %H:%M:%S "] -gmt 1}
|
||||
|
||||
# Format : all (in gmt, locale en)
|
||||
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -gmt 1 -locale en}
|
||||
# Format : all (in CET, locale de)
|
||||
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de}
|
||||
}
|
||||
}
|
||||
|
||||
proc test-scan {{reptime 1000}} {
|
||||
_test_run $reptime {
|
||||
# Scan : date (in gmt)
|
||||
{clock scan "25.11.2015" -format "%d.%m.%Y" -base 0 -gmt 1}
|
||||
# Scan : date (system time zone, with base)
|
||||
{clock scan "25.11.2015" -format "%d.%m.%Y" -base 0}
|
||||
# Scan : date (system time zone, without base)
|
||||
{clock scan "25.11.2015" -format "%d.%m.%Y"}
|
||||
# Scan : greedy match
|
||||
{clock scan "111" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "1111" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "11111" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "111111" -format "%d%m%y" -base 0 -gmt 1}
|
||||
# Scan : greedy match (space separated)
|
||||
{clock scan "1 1 1" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "111 1" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "1 111" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "1 11 1" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "1 11 11" -format "%d%m%y" -base 0 -gmt 1}
|
||||
{clock scan "11 11 11" -format "%d%m%y" -base 0 -gmt 1}
|
||||
|
||||
# Scan : time (in gmt)
|
||||
{clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000 -gmt 1}
|
||||
# Scan : time (system time zone, with base)
|
||||
{clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000}
|
||||
# Scan : time (gmt, without base)
|
||||
{clock scan "10:35:55" -format "%H:%M:%S" -gmt 1}
|
||||
# Scan : time (system time zone, without base)
|
||||
{clock scan "10:35:55" -format "%H:%M:%S"}
|
||||
|
||||
# Scan : date-time (in gmt)
|
||||
{clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0 -gmt 1}
|
||||
# Scan : date-time (system time zone with base)
|
||||
{clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0}
|
||||
# Scan : date-time (system time zone without base)
|
||||
{clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S"}
|
||||
|
||||
# Scan : julian day in gmt
|
||||
{clock scan 2451545 -format %J -gmt 1}
|
||||
# Scan : julian day in system TZ
|
||||
{clock scan 2451545 -format %J}
|
||||
# Scan : julian day in other TZ
|
||||
{clock scan 2451545 -format %J -timezone +0200}
|
||||
# Scan : julian day with time:
|
||||
{clock scan "2451545 10:20:30" -format "%J %H:%M:%S"}
|
||||
# Scan : julian day with time (greedy match):
|
||||
{clock scan "2451545 102030" -format "%J%H%M%S"}
|
||||
|
||||
# Scan : century, lookup table month
|
||||
{clock scan {1970 Jan 2} -format {%C%y %b %d} -locale en -gmt 1}
|
||||
# Scan : century, lookup table month and day (both entries are first)
|
||||
{clock scan {1970 Jan 01} -format {%C%y %b %Od} -locale en -gmt 1}
|
||||
# Scan : century, lookup table month and day (list scan: entries with position 12 / 31)
|
||||
{clock scan {2016 Dec 31} -format {%C%y %b %Od} -locale en -gmt 1}
|
||||
|
||||
# Scan : ISO date-time (CEST)
|
||||
{clock scan "2009-06-30T18:30:00+02:00" -format "%Y-%m-%dT%H:%M:%S%z"}
|
||||
{clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"}
|
||||
# Scan : ISO date-time (UTC)
|
||||
{clock scan "2009-06-30T18:30:00Z" -format "%Y-%m-%dT%H:%M:%S%z"}
|
||||
{clock scan "2009-06-30T18:30:00 UTC" -format "%Y-%m-%dT%H:%M:%S %z"}
|
||||
|
||||
# Scan : locale date-time (en):
|
||||
{clock scan "06/30/2009 18:30:15" -format "%x %X" -gmt 1 -locale en}
|
||||
# Scan : locale date-time (de):
|
||||
{clock scan "30.06.2009 18:30:15" -format "%x %X" -gmt 1 -locale de}
|
||||
|
||||
# Scan : dynamic format (cacheable)
|
||||
{clock scan "25.11.2015 10:35:55" -format [string trim "%d.%m.%Y %H:%M:%S "] -base 0 -gmt 1}
|
||||
|
||||
break
|
||||
# # Scan : long format test (allock chain)
|
||||
# {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1}
|
||||
# # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc):
|
||||
# {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
|
||||
# # Scan : again:
|
||||
# {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
|
||||
} {puts [clock format $_(r) -locale en]}
|
||||
}
|
||||
|
||||
proc test-freescan {{reptime 1000}} {
|
||||
_test_run $reptime {
|
||||
# FreeScan : relative date
|
||||
{clock scan "5 years 18 months 385 days" -base 0 -gmt 1}
|
||||
# FreeScan : relative date with relative weekday
|
||||
{clock scan "5 years 18 months 385 days Fri" -base 0 -gmt 1}
|
||||
# FreeScan : relative date with ordinal month
|
||||
{clock scan "5 years 18 months 385 days next 1 January" -base 0 -gmt 1}
|
||||
# FreeScan : relative date with ordinal month and relative weekday
|
||||
{clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1}
|
||||
# FreeScan : ordinal month
|
||||
{clock scan "next January" -base 0 -gmt 1}
|
||||
# FreeScan : relative week
|
||||
{clock scan "next Fri" -base 0 -gmt 1}
|
||||
# FreeScan : relative weekday and week offset
|
||||
{clock scan "next January + 2 week" -base 0 -gmt 1}
|
||||
# FreeScan : time only with base
|
||||
{clock scan "19:18:30" -base 148863600 -gmt 1}
|
||||
# FreeScan : time only without base, gmt
|
||||
{clock scan "19:18:30" -gmt 1}
|
||||
# FreeScan : time only without base, system
|
||||
{clock scan "19:18:30"}
|
||||
# FreeScan : date, system time zone
|
||||
{clock scan "05/08/2016 20:18:30"}
|
||||
# FreeScan : date, supplied time zone
|
||||
{clock scan "05/08/2016 20:18:30" -timezone :CET}
|
||||
# FreeScan : date, supplied gmt (equivalent -timezone :GMT)
|
||||
{clock scan "05/08/2016 20:18:30" -gmt 1}
|
||||
# FreeScan : date, supplied time zone gmt
|
||||
{clock scan "05/08/2016 20:18:30" -timezone :GMT}
|
||||
# FreeScan : time only, numeric zone in string, base time gmt (exchange zones between gmt / -0500)
|
||||
{clock scan "20:18:30 -0500" -base 148863600 -gmt 1}
|
||||
# FreeScan : time only, zone in string (exchange zones between system / gmt)
|
||||
{clock scan "19:18:30 GMT" -base 148863600}
|
||||
# FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST
|
||||
{clock scan "19:18:30 MST" -base 148863600 -gmt 1
|
||||
clock scan "19:18:30 EST" -base 148863600
|
||||
}
|
||||
} {puts [clock format $_(r) -locale en]}
|
||||
}
|
||||
|
||||
proc test-add {{reptime 1000}} {
|
||||
set tests {
|
||||
# Add : years
|
||||
{clock add 1246379415 5 years -gmt 1}
|
||||
# Add : months
|
||||
{clock add 1246379415 18 months -gmt 1}
|
||||
# Add : weeks
|
||||
{clock add 1246379415 20 weeks -gmt 1}
|
||||
# Add : days
|
||||
{clock add 1246379415 385 days -gmt 1}
|
||||
# Add : weekdays
|
||||
{clock add 1246379415 3 weekdays -gmt 1}
|
||||
|
||||
# Add : hours
|
||||
{clock add 1246379415 5 hours -gmt 1}
|
||||
# Add : minutes
|
||||
{clock add 1246379415 55 minutes -gmt 1}
|
||||
# Add : seconds
|
||||
{clock add 1246379415 100 seconds -gmt 1}
|
||||
|
||||
# Add : +/- in gmt
|
||||
{clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -gmt 1}
|
||||
# Add : +/- in system timezone
|
||||
{clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -timezone :CET}
|
||||
|
||||
# Add : gmt
|
||||
{clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -gmt 1}
|
||||
# Add : system timezone
|
||||
{clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -timezone :CET}
|
||||
|
||||
# Add : all in gmt
|
||||
{clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -gmt 1}
|
||||
# Add : all in system timezone
|
||||
{clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -timezone :CET}
|
||||
|
||||
}
|
||||
# if does not support add of weekdays:
|
||||
if {[catch {clock add 0 3 weekdays -gmt 1}]} {
|
||||
regsub -all {\mweekdays\M} $tests "days" tests
|
||||
}
|
||||
_test_run $reptime $tests {puts [clock format $_(r) -locale en]}
|
||||
}
|
||||
|
||||
proc test-convert {{reptime 1000}} {
|
||||
_test_run $reptime {
|
||||
# Convert locale (en -> de):
|
||||
{clock format [clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en] -format "%a %b %d %Y" -gmt 1 -locale de}
|
||||
# Convert locale (de -> en):
|
||||
{clock format [clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de] -format "%a %b %d %Y" -gmt 1 -locale en}
|
||||
|
||||
# Convert TZ: direct
|
||||
{clock format [clock scan "19:18:30" -base 148863600 -timezone EST] -timezone MST}
|
||||
{clock format [clock scan "19:18:30" -base 148863600 -timezone MST] -timezone EST}
|
||||
# Convert TZ: included in scan string & format
|
||||
{clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone MST}
|
||||
{clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone EST}
|
||||
|
||||
# Format locale 1x: comparison values
|
||||
{clock format 0 -gmt 1 -locale en}
|
||||
{clock format 0 -gmt 1 -locale de}
|
||||
{clock format 0 -gmt 1 -locale fr}
|
||||
# Format locale 2x: without switching locale (en, en)
|
||||
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en}
|
||||
# Format locale 2x: with switching locale (en, de)
|
||||
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de}
|
||||
# Format locale 3x: without switching locale (en, en, en)
|
||||
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en}
|
||||
# Format locale 3x: with switching locale (en, de, fr)
|
||||
{clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de; clock format 0 -gmt 1 -locale fr}
|
||||
|
||||
# Scan locale 2x: without switching locale (en, en) + (de, de)
|
||||
{clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en}
|
||||
{clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de}
|
||||
# Scan locale 2x: with switching locale (en, de)
|
||||
{clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de}
|
||||
# Scan locale 3x: with switching locale (en, de, fr)
|
||||
{clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "mar. mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale fr}
|
||||
|
||||
# Format TZ 2x: comparison values
|
||||
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
{clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
# Format TZ 2x: without switching
|
||||
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
{clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
# Format TZ 2x: with switching
|
||||
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
# Format TZ 3x: with switching (CET, EST, MST)
|
||||
{clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
# Format TZ 3x: with switching (GMT, EST, MST)
|
||||
{clock format 0 -gmt 1 -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"}
|
||||
|
||||
# FreeScan TZ 2x (+1 system-default): without switching TZ
|
||||
{clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 MST" -base 148863600}
|
||||
{clock scan "19:18:30 EST" -base 148863600; clock scan "19:18:30 EST" -base 148863600}
|
||||
# FreeScan TZ 2x (+1 system-default): with switching TZ
|
||||
{clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 EST" -base 148863600}
|
||||
# FreeScan TZ 2x (+1 gmt, +1 system-default)
|
||||
{clock scan "19:18:30 MST" -base 148863600 -gmt 1; clock scan "19:18:30 EST" -base 148863600}
|
||||
|
||||
# Scan TZ: comparison included in scan string vs. given
|
||||
{clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"}
|
||||
{clock scan "2009-06-30T18:30:00 CET" -format "%Y-%m-%dT%H:%M:%S %z"}
|
||||
{clock scan "2009-06-30T18:30:00" -timezone CET -format "%Y-%m-%dT%H:%M:%S"}
|
||||
}
|
||||
}
|
||||
|
||||
proc test-other {{reptime 1000}} {
|
||||
_test_run $reptime {
|
||||
# Bad zone
|
||||
{catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
|
||||
|
||||
# Scan : julian day (overflow)
|
||||
{catch {clock scan 5373485 -format %J}}
|
||||
|
||||
# Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
|
||||
{set i 0; time { clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
|
||||
# Scan : test reusability of GC objects (format is dynamic, so tcl-obj removed with last reference)
|
||||
{set i 50; time { clock scan "[incr i -1] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
|
||||
}
|
||||
}
|
||||
|
||||
proc test-ensemble-perf {{reptime 1000}} {
|
||||
_test_run $reptime {
|
||||
# Clock clicks (ensemble)
|
||||
{clock clicks}
|
||||
# Clock clicks (direct)
|
||||
{::tcl::clock::clicks}
|
||||
# Clock seconds (ensemble)
|
||||
{clock seconds}
|
||||
# Clock seconds (direct)
|
||||
{::tcl::clock::seconds}
|
||||
# Clock microseconds (ensemble)
|
||||
{clock microseconds}
|
||||
# Clock microseconds (direct)
|
||||
{::tcl::clock::microseconds}
|
||||
# Clock scan (ensemble)
|
||||
{clock scan ""}
|
||||
# Clock scan (direct)
|
||||
{::tcl::clock::scan ""}
|
||||
# Clock format (ensemble)
|
||||
{clock format 0 -f %s}
|
||||
# Clock format (direct)
|
||||
{::tcl::clock::format 0 -f %s}
|
||||
}
|
||||
}
|
||||
|
||||
proc test {{reptime 1000}} {
|
||||
puts ""
|
||||
test-ensemble-perf [expr {$reptime / 2}]; #fast enough
|
||||
test-format $reptime
|
||||
test-scan $reptime
|
||||
test-freescan $reptime
|
||||
test-add $reptime
|
||||
test-convert [expr {$reptime / 2}]; #fast enough
|
||||
test-other $reptime
|
||||
|
||||
puts \n**OK**
|
||||
}
|
||||
|
||||
}; # end of ::tclTestPerf-TclClock
|
||||
|
||||
# ------------------------------------------------------------------------
|
||||
|
||||
# if calling direct:
|
||||
if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
|
||||
::tclTestPerf-TclClock::test $in(-time)
|
||||
}
|
||||
@@ -0,0 +1,121 @@
|
||||
# ------------------------------------------------------------------------
|
||||
#
|
||||
# test-performance.tcl --
|
||||
#
|
||||
# This file provides common performance tests for comparison of tcl-speed
|
||||
# degradation or regression by switching between branches.
|
||||
#
|
||||
# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl".
|
||||
#
|
||||
# ------------------------------------------------------------------------
|
||||
#
|
||||
# Copyright (c) 2014 Serg G. Brester (aka sebres)
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file.
|
||||
#
|
||||
|
||||
namespace eval ::tclTestPerf {
|
||||
# warm-up interpeter compiler env, calibrate timerate measurement functionality:
|
||||
|
||||
# if no timerate here - import from unsupported:
|
||||
if {[namespace which -command timerate] eq {}} {
|
||||
namespace inscope ::tcl::unsupported {namespace export timerate}
|
||||
namespace import ::tcl::unsupported::timerate
|
||||
}
|
||||
|
||||
# if not yet calibrated:
|
||||
if {[lindex [timerate {} 10] 6] >= (10-1)} {
|
||||
puts -nonewline "Calibration ... "; flush stdout
|
||||
puts "done: [lrange \
|
||||
[timerate -calibrate {}] \
|
||||
0 1]"
|
||||
}
|
||||
|
||||
proc {**STOP**} {args} {
|
||||
return -code error -level 4 "**STOP** in [info level [expr {[info level]-2}]] [join $args { }]"
|
||||
}
|
||||
|
||||
proc _test_get_commands {lst} {
|
||||
regsub -all {(?:^|\n)[ \t]*(\#[^\n]*|\msetup\M[^\n]*|\mcleanup\M[^\n]*)(?=\n\s*(?:[\{\#]|setup|cleanup|$))} $lst "\n{\\1}"
|
||||
}
|
||||
|
||||
proc _test_out_total {} {
|
||||
upvar _ _
|
||||
|
||||
set tcnt [llength $_(itm)]
|
||||
if {!$tcnt} {
|
||||
puts ""
|
||||
return
|
||||
}
|
||||
|
||||
set mintm 0x7fffffff
|
||||
set maxtm 0
|
||||
set nett 0
|
||||
set wtm 0
|
||||
set wcnt 0
|
||||
set i 0
|
||||
foreach tm $_(itm) {
|
||||
if {[llength $tm] > 6} {
|
||||
set nett [expr {$nett + [lindex $tm 6]}]
|
||||
}
|
||||
set wtm [expr {$wtm + [lindex $tm 0]}]
|
||||
set wcnt [expr {$wcnt + [lindex $tm 2]}]
|
||||
set tm [lindex $tm 0]
|
||||
if {$tm > $maxtm} {set maxtm $tm; set maxi $i}
|
||||
if {$tm < $mintm} {set mintm $tm; set mini $i}
|
||||
incr i
|
||||
}
|
||||
|
||||
puts [string repeat ** 40]
|
||||
set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]]
|
||||
if {$nett > 0} {
|
||||
append s [format " (%.2f nett-sec.)" [expr {$nett / 1000.0}]]
|
||||
}
|
||||
puts "Total $s:"
|
||||
lset _(m) 0 [format %.6f $wtm]
|
||||
lset _(m) 2 $wcnt
|
||||
lset _(m) 4 [format %.3f [expr {$wcnt / (($nett ? $nett : ($tcnt * $_(reptime))) / 1000.0)}]]
|
||||
if {[llength $_(m)] > 6} {
|
||||
lset _(m) 6 [format %.3f $nett]
|
||||
}
|
||||
puts $_(m)
|
||||
puts "Average:"
|
||||
lset _(m) 0 [format %.6f [expr {[lindex $_(m) 0] / $tcnt}]]
|
||||
lset _(m) 2 [expr {[lindex $_(m) 2] / $tcnt}]
|
||||
if {[llength $_(m)] > 6} {
|
||||
lset _(m) 6 [format %.3f [expr {[lindex $_(m) 6] / $tcnt}]]
|
||||
lset _(m) 4 [format %.0f [expr {[lindex $_(m) 2] / [lindex $_(m) 6] * 1000}]]
|
||||
}
|
||||
puts $_(m)
|
||||
puts "Min:"
|
||||
puts [lindex $_(itm) $mini]
|
||||
puts "Max:"
|
||||
puts [lindex $_(itm) $maxi]
|
||||
puts [string repeat ** 40]
|
||||
puts ""
|
||||
}
|
||||
|
||||
proc _test_run {reptime lst {outcmd {puts $_(r)}}} {
|
||||
upvar _ _
|
||||
array set _ [list itm {} reptime $reptime starttime [clock milliseconds]]
|
||||
|
||||
foreach _(c) [_test_get_commands $lst] {
|
||||
puts "% [regsub -all {\n[ \t]*} $_(c) {; }]"
|
||||
if {[regexp {^\s*\#} $_(c)]} continue
|
||||
if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
|
||||
puts [if 1 [lindex $_(c) 1]]
|
||||
continue
|
||||
}
|
||||
if {$reptime > 1} {; #if not once:
|
||||
set _(r) [if 1 $_(c)]
|
||||
if {$outcmd ne {}} $outcmd
|
||||
}
|
||||
puts [set _(m) [timerate $_(c) $reptime]]
|
||||
lappend _(itm) $_(m)
|
||||
puts ""
|
||||
}
|
||||
_test_out_total
|
||||
}
|
||||
|
||||
}; # end of namespace ::tclTestPerf
|
||||
@@ -0,0 +1,8 @@
|
||||
# clock-ivm.test --
|
||||
#
|
||||
# This test file covers the 'clock' command using inverted validity mode.
|
||||
#
|
||||
# See the file "clock.test" for more information.
|
||||
|
||||
clock configure -valid [expr {![clock configure -valid]}]
|
||||
source [file join [file dirname [info script]] clock.test]
|
||||
+910
-106
File diff suppressed because it is too large
Load Diff
+13
-4
@@ -294,7 +294,7 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
|
||||
|
||||
GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
|
||||
tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \
|
||||
tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
|
||||
tclClock.o tclClockFmt.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
|
||||
tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
|
||||
tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \
|
||||
tclEncoding.o tclEnsemble.o \
|
||||
@@ -306,7 +306,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
|
||||
tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
|
||||
tclPkg.o tclPkgConfig.o tclPosixStr.o \
|
||||
tclPreserve.o tclProc.o tclRegexp.o \
|
||||
tclResolve.o tclResult.o tclScan.o tclStringObj.o \
|
||||
tclResolve.o tclResult.o tclScan.o tclStringObj.o tclStrIdxTree.o \
|
||||
tclStrToD.o tclThread.o \
|
||||
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
|
||||
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
|
||||
@@ -398,6 +398,7 @@ GENERIC_SRCS = \
|
||||
$(GENERIC_DIR)/tclBinary.c \
|
||||
$(GENERIC_DIR)/tclCkalloc.c \
|
||||
$(GENERIC_DIR)/tclClock.c \
|
||||
$(GENERIC_DIR)/tclClockFmt.c \
|
||||
$(GENERIC_DIR)/tclCmdAH.c \
|
||||
$(GENERIC_DIR)/tclCmdIL.c \
|
||||
$(GENERIC_DIR)/tclCmdMZ.c \
|
||||
@@ -452,6 +453,7 @@ GENERIC_SRCS = \
|
||||
$(GENERIC_DIR)/tclScan.c \
|
||||
$(GENERIC_DIR)/tclStubInit.c \
|
||||
$(GENERIC_DIR)/tclStringObj.c \
|
||||
$(GENERIC_DIR)/tclStrIdxTree.c \
|
||||
$(GENERIC_DIR)/tclStrToD.c \
|
||||
$(GENERIC_DIR)/tclTest.c \
|
||||
$(GENERIC_DIR)/tclTestObj.c \
|
||||
@@ -1035,6 +1037,7 @@ MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h
|
||||
PARSEHDR=$(GENERIC_DIR)/tclParse.h
|
||||
NREHDR=$(GENERIC_DIR)/tclInt.h
|
||||
TRIMHDR=$(GENERIC_DIR)/tclStringTrim.h
|
||||
TCLDATEHDR=$(GENERIC_DIR)/tclDate.h $(GENERIC_DIR)/tclStrIdxTree.h
|
||||
|
||||
regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
|
||||
$(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \
|
||||
@@ -1071,9 +1074,12 @@ tclBinary.o: $(GENERIC_DIR)/tclBinary.c
|
||||
tclCkalloc.o: $(GENERIC_DIR)/tclCkalloc.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCkalloc.c
|
||||
|
||||
tclClock.o: $(GENERIC_DIR)/tclClock.c
|
||||
tclClock.o: $(GENERIC_DIR)/tclClock.c $(TCLDATEHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClock.c
|
||||
|
||||
tclClockFmt.o: $(GENERIC_DIR)/tclClockFmt.c $(TCLDATEHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclClockFmt.c
|
||||
|
||||
tclCmdAH.o: $(GENERIC_DIR)/tclCmdAH.c
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdAH.c
|
||||
|
||||
@@ -1083,7 +1089,7 @@ tclCmdIL.o: $(GENERIC_DIR)/tclCmdIL.c $(TCLREHDRS)
|
||||
tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCmdMZ.c
|
||||
|
||||
tclDate.o: $(GENERIC_DIR)/tclDate.c
|
||||
tclDate.o: $(GENERIC_DIR)/tclDate.c $(TCLDATEHDR)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c
|
||||
|
||||
tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR)
|
||||
@@ -1302,6 +1308,9 @@ tclScan.o: $(GENERIC_DIR)/tclScan.c
|
||||
tclStringObj.o: $(GENERIC_DIR)/tclStringObj.c $(MATHHDRS)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStringObj.c
|
||||
|
||||
tclStrIdxTree.o: $(GENERIC_DIR)/tclStrIdxTree.c $(GENERIC_DIR)/tclStrIdxTree.h $(MATHHDRS)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrIdxTree.c
|
||||
|
||||
tclStrToD.o: $(GENERIC_DIR)/tclStrToD.c $(MATHHDRS)
|
||||
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclStrToD.c
|
||||
|
||||
|
||||
@@ -81,6 +81,32 @@ TclpGetSeconds(void)
|
||||
return time(NULL);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclpGetMicroseconds --
|
||||
*
|
||||
* This procedure returns the number of microseconds from the epoch.
|
||||
* On most Unix systems the epoch is Midnight Jan 1, 1970 GMT.
|
||||
*
|
||||
* Results:
|
||||
* Number of microseconds from the epoch.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_WideInt
|
||||
TclpGetMicroseconds(void)
|
||||
{
|
||||
Tcl_Time time;
|
||||
|
||||
tclGetTimeProcPtr(&time, tclTimeClientData);
|
||||
return ((Tcl_WideInt)time.sec)*1000000 + time.usec;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
@@ -216,6 +242,51 @@ TclpWideClicksToNanoseconds(
|
||||
|
||||
return nsec;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclpWideClickInMicrosec --
|
||||
*
|
||||
* This procedure return scale to convert click values from the
|
||||
* TclpGetWideClicks native resolution to microsecond resolution
|
||||
* and back.
|
||||
*
|
||||
* Results:
|
||||
* 1 click in microseconds as double.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
double
|
||||
TclpWideClickInMicrosec(void)
|
||||
{
|
||||
if (tclGetTimeProcPtr != NativeGetTime) {
|
||||
return 1.0;
|
||||
} else {
|
||||
#ifdef MAC_OSX_TCL
|
||||
static int initialized = 0;
|
||||
static double scale = 0.0;
|
||||
|
||||
if (initialized) {
|
||||
return scale;
|
||||
} else {
|
||||
mach_timebase_info_data_t tb;
|
||||
|
||||
mach_timebase_info(&tb);
|
||||
/* value of tb.numer / tb.denom = 1 click in nanoseconds */
|
||||
scale = ((double)tb.numer) / tb.denom / 1000;
|
||||
initialized = 1;
|
||||
return scale;
|
||||
}
|
||||
#else
|
||||
#error Wide high-resolution clicks not implemented on this platform
|
||||
#endif
|
||||
}
|
||||
}
|
||||
#endif /* TCL_WIDE_CLICKS */
|
||||
|
||||
/*
|
||||
|
||||
@@ -228,6 +228,7 @@ GENERIC_OBJS = \
|
||||
tclBinary.$(OBJEXT) \
|
||||
tclCkalloc.$(OBJEXT) \
|
||||
tclClock.$(OBJEXT) \
|
||||
tclClockFmt.$(OBJEXT) \
|
||||
tclCmdAH.$(OBJEXT) \
|
||||
tclCmdIL.$(OBJEXT) \
|
||||
tclCmdMZ.$(OBJEXT) \
|
||||
@@ -290,6 +291,7 @@ GENERIC_OBJS = \
|
||||
tclResult.$(OBJEXT) \
|
||||
tclScan.$(OBJEXT) \
|
||||
tclStringObj.$(OBJEXT) \
|
||||
tclStrIdxTree.$(OBJEXT) \
|
||||
tclStrToD.$(OBJEXT) \
|
||||
tclStubInit.$(OBJEXT) \
|
||||
tclThread.$(OBJEXT) \
|
||||
|
||||
@@ -161,6 +161,7 @@ COREOBJS = \
|
||||
$(TMP_DIR)\tclBinary.obj \
|
||||
$(TMP_DIR)\tclCkalloc.obj \
|
||||
$(TMP_DIR)\tclClock.obj \
|
||||
$(TMP_DIR)\tclClockFmt.obj \
|
||||
$(TMP_DIR)\tclCmdAH.obj \
|
||||
$(TMP_DIR)\tclCmdIL.obj \
|
||||
$(TMP_DIR)\tclCmdMZ.obj \
|
||||
@@ -223,6 +224,7 @@ COREOBJS = \
|
||||
$(TMP_DIR)\tclResult.obj \
|
||||
$(TMP_DIR)\tclScan.obj \
|
||||
$(TMP_DIR)\tclStringObj.obj \
|
||||
$(TMP_DIR)\tclStrIdxTree.obj \
|
||||
$(TMP_DIR)\tclStrToD.obj \
|
||||
$(TMP_DIR)\tclStubInit.obj \
|
||||
$(TMP_DIR)\tclThread.obj \
|
||||
|
||||
+232
-39
@@ -109,6 +109,17 @@ static TimeInfo timeInfo = {
|
||||
0
|
||||
};
|
||||
|
||||
/*
|
||||
* Scale to convert wide click values from the TclpGetWideClicks native
|
||||
* resolution to microsecond resolution and back.
|
||||
*/
|
||||
static struct {
|
||||
int initialized; /* 1 if initialized, 0 otherwise */
|
||||
int perfCounter; /* 1 if performance counter usable for wide clicks */
|
||||
double microsecsScale; /* Denominator scale between clock / microsecs */
|
||||
} wideClick = {0, 0.0};
|
||||
|
||||
|
||||
/*
|
||||
* Declarations for functions defined later in this file.
|
||||
*/
|
||||
@@ -123,6 +134,7 @@ static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter,
|
||||
Tcl_WideUInt fileTime);
|
||||
static void NativeScaleTime(Tcl_Time* timebuf,
|
||||
ClientData clientData);
|
||||
static Tcl_WideInt NativeGetMicroseconds(void);
|
||||
static void NativeGetTime(Tcl_Time* timebuf,
|
||||
ClientData clientData);
|
||||
|
||||
@@ -154,10 +166,19 @@ ClientData tclTimeClientData = NULL;
|
||||
unsigned long
|
||||
TclpGetSeconds(void)
|
||||
{
|
||||
Tcl_Time t;
|
||||
Tcl_WideInt usecSincePosixEpoch;
|
||||
|
||||
tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */
|
||||
return t.sec;
|
||||
/* Try to use high resolution timer */
|
||||
if ( tclGetTimeProcPtr == NativeGetTime
|
||||
&& (usecSincePosixEpoch = NativeGetMicroseconds())
|
||||
) {
|
||||
return usecSincePosixEpoch / 1000000;
|
||||
} else {
|
||||
Tcl_Time t;
|
||||
|
||||
tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */
|
||||
return t.sec;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -182,19 +203,147 @@ TclpGetSeconds(void)
|
||||
unsigned long
|
||||
TclpGetClicks(void)
|
||||
{
|
||||
/*
|
||||
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
|
||||
* nearly as we can, and return it.
|
||||
*/
|
||||
Tcl_WideInt usecSincePosixEpoch;
|
||||
|
||||
Tcl_Time now; /* Current Tcl time */
|
||||
unsigned long retval; /* Value to return */
|
||||
/* Try to use high resolution timer */
|
||||
if ( tclGetTimeProcPtr == NativeGetTime
|
||||
&& (usecSincePosixEpoch = NativeGetMicroseconds())
|
||||
) {
|
||||
return (unsigned long)usecSincePosixEpoch;
|
||||
} else {
|
||||
/*
|
||||
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
|
||||
* nearly as we can, and return it.
|
||||
*/
|
||||
|
||||
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
|
||||
Tcl_Time now; /* Current Tcl time */
|
||||
|
||||
retval = (now.sec * 1000000) + now.usec;
|
||||
return retval;
|
||||
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
|
||||
return (unsigned long)(now.sec * 1000000) + now.usec;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclpGetWideClicks --
|
||||
*
|
||||
* This procedure returns a WideInt value that represents the highest
|
||||
* resolution clock in microseconds available on the system.
|
||||
*
|
||||
* Results:
|
||||
* Number of microseconds (from some start time).
|
||||
*
|
||||
* Side effects:
|
||||
* This should be used for time-delta resp. for measurement purposes
|
||||
* only, because on some platforms can return microseconds from some
|
||||
* start time (not from the epoch).
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_WideInt
|
||||
TclpGetWideClicks(void)
|
||||
{
|
||||
LARGE_INTEGER curCounter;
|
||||
|
||||
if (!wideClick.initialized) {
|
||||
LARGE_INTEGER perfCounterFreq;
|
||||
|
||||
/*
|
||||
* The frequency of the performance counter is fixed at system boot and
|
||||
* is consistent across all processors. Therefore, the frequency need
|
||||
* only be queried upon application initialization.
|
||||
*/
|
||||
if (QueryPerformanceFrequency(&perfCounterFreq)) {
|
||||
wideClick.perfCounter = 1;
|
||||
wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart;
|
||||
} else {
|
||||
/* fallback using microseconds */
|
||||
wideClick.perfCounter = 0;
|
||||
wideClick.microsecsScale = 1;
|
||||
}
|
||||
|
||||
wideClick.initialized = 1;
|
||||
}
|
||||
if (wideClick.perfCounter) {
|
||||
if (QueryPerformanceCounter(&curCounter)) {
|
||||
return (Tcl_WideInt)curCounter.QuadPart;
|
||||
}
|
||||
/* fallback using microseconds */
|
||||
wideClick.perfCounter = 0;
|
||||
wideClick.microsecsScale = 1;
|
||||
return TclpGetMicroseconds();
|
||||
} else {
|
||||
return TclpGetMicroseconds();
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclpWideClickInMicrosec --
|
||||
*
|
||||
* This procedure return scale to convert wide click values from the
|
||||
* TclpGetWideClicks native resolution to microsecond resolution
|
||||
* and back.
|
||||
*
|
||||
* Results:
|
||||
* 1 click in microseconds as double.
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
double
|
||||
TclpWideClickInMicrosec(void)
|
||||
{
|
||||
if (!wideClick.initialized) {
|
||||
(void)TclpGetWideClicks(); /* initialize */
|
||||
}
|
||||
return wideClick.microsecsScale;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* TclpGetMicroseconds --
|
||||
*
|
||||
* This procedure returns a WideInt value that represents the highest
|
||||
* resolution clock in microseconds available on the system.
|
||||
*
|
||||
* Results:
|
||||
* Number of microseconds (from the epoch).
|
||||
*
|
||||
* Side effects:
|
||||
* None.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
Tcl_WideInt
|
||||
TclpGetMicroseconds(void)
|
||||
{
|
||||
Tcl_WideInt usecSincePosixEpoch;
|
||||
|
||||
/* Try to use high resolution timer */
|
||||
if ( tclGetTimeProcPtr == NativeGetTime
|
||||
&& (usecSincePosixEpoch = NativeGetMicroseconds())
|
||||
) {
|
||||
return usecSincePosixEpoch;
|
||||
} else {
|
||||
/*
|
||||
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
|
||||
* nearly as we can, and return it.
|
||||
*/
|
||||
|
||||
Tcl_Time now;
|
||||
|
||||
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
|
||||
return (((Tcl_WideInt)now.sec) * 1000000) + now.usec;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -223,7 +372,17 @@ void
|
||||
Tcl_GetTime(
|
||||
Tcl_Time *timePtr) /* Location to store time information. */
|
||||
{
|
||||
tclGetTimeProcPtr(timePtr, tclTimeClientData);
|
||||
Tcl_WideInt usecSincePosixEpoch;
|
||||
|
||||
/* Try to use high resolution timer */
|
||||
if ( tclGetTimeProcPtr == NativeGetTime
|
||||
&& (usecSincePosixEpoch = NativeGetMicroseconds())
|
||||
) {
|
||||
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
|
||||
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
|
||||
} else {
|
||||
tclGetTimeProcPtr(timePtr, tclTimeClientData);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -256,13 +415,14 @@ NativeScaleTime(
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* NativeGetTime --
|
||||
* NativeGetMicroseconds --
|
||||
*
|
||||
* TIP #233: Gets the current system time in seconds and microseconds
|
||||
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
|
||||
* Gets the current system time in microseconds since the beginning
|
||||
* of the epoch: 00:00 UCT, January 1, 1970.
|
||||
*
|
||||
* Results:
|
||||
* Returns the current time in timePtr.
|
||||
* Returns the wide integer with number of microseconds from the epoch, or
|
||||
* 0 if high resolution timer is not available.
|
||||
*
|
||||
* Side effects:
|
||||
* On the first call, initializes a set of static variables to keep track
|
||||
@@ -275,13 +435,12 @@ NativeScaleTime(
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
static void
|
||||
NativeGetTime(
|
||||
Tcl_Time *timePtr,
|
||||
ClientData clientData)
|
||||
static Tcl_WideInt
|
||||
NativeGetMicroseconds(void)
|
||||
{
|
||||
struct _timeb t;
|
||||
|
||||
static LARGE_INTEGER posixEpoch;
|
||||
/* Posix epoch expressed as 100-ns ticks since
|
||||
* the windows epoch. */
|
||||
/*
|
||||
* Initialize static storage on the first trip through.
|
||||
*
|
||||
@@ -292,6 +451,10 @@ NativeGetTime(
|
||||
if (!timeInfo.initialized) {
|
||||
TclpInitLock();
|
||||
if (!timeInfo.initialized) {
|
||||
|
||||
posixEpoch.LowPart = 0xD53E8000;
|
||||
posixEpoch.HighPart = 0x019DB1DE;
|
||||
|
||||
timeInfo.perfCounterAvailable =
|
||||
QueryPerformanceFrequency(&timeInfo.nominalFreq);
|
||||
|
||||
@@ -404,15 +567,9 @@ NativeGetTime(
|
||||
/* Current performance counter. */
|
||||
Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns
|
||||
* ticks since the Windows epoch. */
|
||||
static LARGE_INTEGER posixEpoch;
|
||||
/* Posix epoch expressed as 100-ns ticks since
|
||||
* the windows epoch. */
|
||||
Tcl_WideInt usecSincePosixEpoch;
|
||||
/* Current microseconds since Posix epoch. */
|
||||
|
||||
posixEpoch.LowPart = 0xD53E8000;
|
||||
posixEpoch.HighPart = 0x019DB1DE;
|
||||
|
||||
QueryPerformanceCounter(&curCounter);
|
||||
|
||||
/*
|
||||
@@ -432,9 +589,7 @@ NativeGetTime(
|
||||
if (curCounter.QuadPart <= perfCounterLastCall.QuadPart) {
|
||||
usecSincePosixEpoch =
|
||||
(fileTimeLastCall.QuadPart - posixEpoch.QuadPart) / 10;
|
||||
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
|
||||
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
|
||||
return;
|
||||
return usecSincePosixEpoch;
|
||||
}
|
||||
|
||||
/*
|
||||
@@ -455,19 +610,57 @@ NativeGetTime(
|
||||
* 10000000 / curCounterFreq.QuadPart);
|
||||
|
||||
usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10;
|
||||
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
|
||||
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
|
||||
return;
|
||||
return usecSincePosixEpoch;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* High resolution timer is not available. Just use ftime.
|
||||
* High resolution timer is not available.
|
||||
*/
|
||||
return 0;
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* NativeGetTime --
|
||||
*
|
||||
* TIP #233: Gets the current system time in seconds and microseconds
|
||||
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
|
||||
*
|
||||
* Results:
|
||||
* Returns the current time in timePtr.
|
||||
*
|
||||
* Side effects:
|
||||
* See NativeGetMicroseconds for more information.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
|
||||
_ftime(&t);
|
||||
timePtr->sec = (long)t.time;
|
||||
timePtr->usec = t.millitm * 1000;
|
||||
static void
|
||||
NativeGetTime(
|
||||
Tcl_Time *timePtr,
|
||||
ClientData clientData)
|
||||
{
|
||||
Tcl_WideInt usecSincePosixEpoch;
|
||||
|
||||
/*
|
||||
* Try to use high resolution timer.
|
||||
*/
|
||||
if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) {
|
||||
timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
|
||||
timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
|
||||
} else {
|
||||
/*
|
||||
* High resolution timer is not available. Just use ftime.
|
||||
*/
|
||||
|
||||
struct _timeb t;
|
||||
|
||||
_ftime(&t);
|
||||
timePtr->sec = (long)t.time;
|
||||
timePtr->usec = t.millitm * 1000;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
|
||||
Reference in New Issue
Block a user