Compare commits

...
Author SHA1 Message Date
sebres 6855aaa799 clock scan: compatibility - scan regression on spaces, mandatory trailing spaces in format, see test "clock-45.4" 2018-11-29 20:14:14 +00:00
sebres a6482d22e2 test-cases: clock-45.* - new compatibility tests checking several scan regression on spaces 2018-11-29 20:12:45 +00:00
sebres 577976dba7 clock scan: consider extra trailing spaces at end of input (closes tclclockmod#14), only the first space at end is interesting in non-strict mode (should match SPACE token if present in scan-format) 2018-11-29 20:11:14 +00:00
sebres 68a780a3bf clock scan: consider multiple spaces between tokens (closes tclclockmod#13): combine multiple white-spaces as single token in format. 2018-11-29 20:04:42 +00:00
sebres 9931564ea5 tclGetDate.y: added missing semicolon, tclDate.c rebuilt using Bison 3.1;
resolves warning "maybe-uninitialized" by `*++yyvsp = yylval;`
2018-10-08 14:08:05 +00:00
sebres 26cbce7e81 closed DST-hole bug "Validity check should get the rule the time-leak corresponding DST switch of TZ", see https://github.com/sebres/tclclockmod/issues/11 for details;
backported from https://github.com/sebres/tclclockmod/pull/12
2018-10-05 19:54:16 +00:00
sebres ed80b6476b Introduces new validity rule (gh-11): check input-time is valid regarding time-zone conversion inside the time-zone ranges (not in DST-hole);
ConvertLocalToUTC/ConvertUTCToLocal rewritten to use common cache (and ConvertLocalToUTC invalidates the local seconds, if it was outside the time-zone ranges during conversion);
Bonus: improves performance of the involved cache by time-zone conversions (if more as 1 TZ), see both performance test-cases "Convert TZ: direct":
(1.3µs vs. 1.7µs previously)
2018-10-05 19:38:19 +00:00
sebres e5fd7b2a2a scan: new tests for validation rules: invalid time (DST-hole, out of range in time-zone) 2018-10-05 18:13:40 +00:00
sebres 81f2a20b3c merge 8.6 2018-07-20 16:25:50 +00:00
sebres 71f7b946a6 amend to [98a00c62b4798792]: fixed sort of the tests 2018-05-30 11:49:19 +00:00
sebres 83a8197fe9 back-porting of tclclockmod done, merge current 8.6 2018-05-29 17:58:53 +00:00
sebres 153e32d613 fixed ticket [dc69e5ecf04313429fd202b1906cd85bb7888f95]: missing zones AKST/AKDT 2018-05-29 17:41:00 +00:00
sebres 1b580435fc forgotten flag "CLF_DAYOFWEEK" in one case, where day of week is set 2018-05-29 17:38:29 +00:00
sebres f185b8c243 revert explicit adding of validity mode suffix in all test-cases: used wrapper command "test" instead 2018-05-29 17:38:02 +00:00
sebres 991ad56e9c tests: sort test-files without extension (e. g. "clock" before "clock-ivm"). 2018-05-29 17:37:03 +00:00
sebres 371c0aec0b conditional test-call rewritten: realized via tests\clock-ivm.test to cover inverted default validation mode 2018-05-29 17:27:23 +00:00
sebres 2f35271c9d fixed week-based calculation if neither mmdd nor ddd available; 2018-05-29 17:26:12 +00:00
sebres 3cf665c0f5 validation rules: extended for day of year (and test covered now) 2018-05-29 17:25:48 +00:00
sebres ef90044383 amend after rebase to master: follow rename yyDayNumber to yyDayOfWeek 2018-05-29 17:24:41 +00:00
sebres 5fb141ae40 validation rules ready for scan/freescan; test cases extended; code review and clean-up;
running of test cases with and without validate.
2018-05-29 17:24:24 +00:00
sebres da19723bdc first simple validation rules introduced 2018-05-29 17:21:09 +00:00
sebres d1b1eb61ee try to re-implement validation rules for clock scan (option -valid 1|0), see http://core.tcl.tk/tcl/tktview?name=3475995 2018-05-29 17:20:36 +00:00
sebres bacdc67e69 Merge branch 'freescan_tz_fix' 2018-05-29 17:19:31 +00:00
sebres fc3ea33681 follow http://core.tcl.tk/tcl/info/a3463a55a6a27eed: Historical change affecting tests: Detroit did not observe Daylight Saving Time in 1967 2018-05-29 17:18:26 +00:00
sebres 86fa45a2d2 Fixed performance test-cases: several test-cases repaired to be feasible using original clock engine. 2018-05-29 17:16:56 +00:00
sebres e3d338650f fixed test-cases (regardless the current time zone) 2018-05-29 17:14:52 +00:00
sebres 88f8e603d9 FreeScan: rewritten lexer rules and some tokens for better space recognition; fewer conflicts (shift/reduce, reduce/reduce);
differentiate between TZ like "GMT+1" and relative offsets "GMT +1 day", etc.;
test-cases extended for new cases.
2018-05-29 17:14:36 +00:00
sebres 2c4913d479 Apply Flightaware DST fix 2018-05-29 17:13:50 +00:00
sebres 3681b8fdb5 try to fix GMT+0000, etc. **still wrong**, because of "GMT+1" and because of longest match "00:00 GMT +1000 days" (in this case "days" == "1 day")...
% clock scan "+1000 days" -base 100000000 -gmt 1
186364800
% clock scan "00:00 GMT +1000 days" -base 100000000 -gmt 1
100015200

% clock format [clock scan "GMT+10"]
Thu Sep 14 19:54:16 CEST 2017
% clock format [clock scan "GMT+1000"]
Thu Sep 14 10:04:20 CEST 2017
% clock format [clock scan "GMT+10"]
Thu Sep 14 19:54:23 CEST 2017
% clock format [clock scan "GMT-1000"]
Fri Sep 15 06:04:39 CEST 2017
%
2018-05-29 17:12:28 +00:00
sebres 9b3dad29d7 FreeScan: repair scanning date/time with TZ using '+', ex.: "31 Jan 14 23:59:59 +0100", additionally another TZ formats can be used now (token [zone] used instead of sequence '-' tNUMBER); test cases extended.
Closes http://core.tcl.tk/tcl/tktview?name=5019748c73
Cherry picked from fossil branch "sebres_clock_tz_fix", check-in [5f72c863f17145b4]
2018-05-29 17:11:52 +00:00
sebres 743a4fee3d replace unneeded calculation of seconds of day (already available in field secondOfDay) 2018-05-29 17:11:09 +00:00
sebres 35b9322dc3 fixed multi-threaded race condition, if the same format will be first time used by 2 threads simultaneously:
assign tokenized lists (scnTok/fmtTok) to format storage firstly if it get ready.
2018-05-29 17:10:51 +00:00
sebres a194fa9779 code review and cleanup (remove unused code) 2018-05-29 17:09:48 +00:00
sebres b8ef30620b code review and cleanup (remove unused code) 2018-05-29 17:04:51 +00:00
sebres 46c8ea3458 Added max permitted threshold (buffer size > result size) in percent, to directly return the buffer without reallocate (don't affect small formats with size < 80 (MIN_FMT_RESULT_BLOCK_ALLOC)) 2018-05-29 17:03:28 +00:00
sebres 10673db0ce further optimization: better cache for GMT-timezone + minimize (re)allocation of buffers 2018-05-29 17:02:57 +00:00
sebres 14c5c590e0 code review: micro optimizations 2018-05-29 17:01:00 +00:00
sebres 533ca10a79 generic\tclStrIdxTree.c: bug fix (lost abbreviation), if tree will be built from 2 lists, and the short form differentiate from long form ("jan." vs "january", note the dot-char), don't use longest form - should be split in 2 entries with common parent "jan".
Thus use simple case (don't split) only if found item is covered in full (e. g. "jan" vs "january", note without dot-char).
Test covered now (clock-29.181x, locale "fr") - `clock scan [clock format 0 -format {%a %d-%m-%Y} -locale fr] -format {%a %d-%m-%Y} -locale fr`
2018-05-29 16:59:22 +00:00
sebres 916a8e7276 performance: GetMonthDay re-implemented using most faster algorithm (without cycle). 2018-05-29 16:47:02 +00:00
sebres baa4ae5c90 try to resolve warnings by some forwards declarations: redefinition of typedef 'ClockScanToken' is a C11 feature [-Wtypedef-redefinition] 2018-05-29 16:45:56 +00:00
sebres ae8248cd39 fixed test case clock-0.1 "auto-loading of ensemble and stubs on demand" - makes no sense if tclclockmod loaded. 2018-05-29 16:45:07 +00:00
sebres 2293dabf3f Initialize prevf to fix (used before set) warning.
* Prevf doesn't get used at line 145 unless `prevItem != NULL` and prevf also gets set in the same block, so this is safe.
2018-05-29 16:42:27 +00:00
sebres 90c1f734c0 tests-perf\test-performance.tcl: ported from sebres-8-6-event-perf-branch (common test performance framework), removed from "tests-perf\clock.perf.tcl" and used as include. 2018-05-29 16:40:26 +00:00
dgp 336cf18ae8 Merge core-8-6-branch (execpt file win/makefile.vc) 2017-10-20 12:36:40 +00:00
sebres 08d9bb4c7c fixed overflow of year (resp. julianday), closes ticket [16e4fc3096]; test cases adjusted. 2017-08-08 15:19:18 +00:00
jan.nijtmans b20173ba38 merge core-8-6-branch 2017-06-07 15:21:27 +00:00
sebres 12edf1f533 fixed wrong options suggestions by wrong args, like 'bad option "-base" ...' (for format) or 'bad option "-format" ...' (for add).
Note: sub-commands share common options table, because for the options often used the same literals (objects), so it avoids permanent "recompiling" of option object representation to indexType with another table.
2017-06-07 14:16:35 +00:00
jan.nijtmans 9e607ddb5a Clock options should be alphabetica (so "-base" first). Struct members should start with lowercase. 2017-06-07 12:38:39 +00:00
jan.nijtmans 33602d0a11 Fix LookupLastTransition() for behavior when tick < compVal, undo Tcl_EvalObjEx -> TclEvalObjEx change, eliminate two inline macro's which are only used once. Eliminate many unnecessary MODULE_SCOPE declarations (duplicated with header files) 2017-06-07 10:40:40 +00:00
jan.nijtmans 4b7fc1bb11 merge core-8-6-branch 2017-06-07 09:29:12 +00:00
sebres e72c67b399 removing "-compile" option on ensembles - allow to compile tcl-internal ensembles within namespace "::tcl::*" (apparently only having map for sub-commands). 2017-06-02 22:43:57 +00:00
sebres b81fc4d41d restored lost documentation of "timerate" 2017-06-02 21:51:35 +00:00
sebres bfa8e4f4dc amend fix default locale, (fixed everywhere - no current locale anymore for default, avoid set it after clear caches, etc.) 2017-06-02 21:48:40 +00:00
sebres ed0399c961 unix/makefile: add header dependencies 2017-06-02 20:45:03 +00:00
sebres 68b7104563 extends performance test cases for converting between locales / TZ, for multiple switching between locales / TZ by scan and format, etc. 2017-06-02 20:10:43 +00:00
sebres 6c2d2971a2 fix default locale: differentiate between no locale specified or "C" (en) and current locale (corresponds system language, resp. env(LANG)) 2017-06-02 20:10:16 +00:00
sebres a592eefcbe [win32] repair clock using system timezone (default :localtime) resp. locale for windows (broken after removal of registry-fix in [848d01b6ef]) 2017-06-02 20:09:53 +00:00
sebres 2fce52b2ae close small performance degradation if alternate between two time zones (e. g. convert from one to another): additionally to last used cache also previously used time zone. 2017-06-02 20:09:25 +00:00
sebres 750bed46fd close small performance degradation if alternate between two locales (e. g. convert from one to another): additionally to last used cache also previously used locale. 2017-06-02 20:09:10 +00:00
sebres d48588c89c Removed public interface to create smart-pointer to dictionaries "dict smartref", common locales catalog rewritten to hold internally onetime referenced merged locales (even as smart-ref). 2017-06-02 20:08:55 +00:00
sebres d5552e2fbe [win32] repair clock test-cases for windows, using system locale / TZ :localtime (broken after removal of registry-fix in [848d01b6ef]) 2017-06-02 20:07:10 +00:00
sebres 0cdd360369 Move "timerate" functionality to "::tcl::unsupported".
This partially reverts commit [848d01b6ef].
2017-06-02 20:06:28 +00:00
jan.nijtmans 449ce271b1 merge-mark core-8-6-branch (no changes) 2017-06-02 11:11:20 +00:00
sebres 9011c35db1 missing static keyword for inline declarations 2017-06-02 06:53:35 +00:00
27 changed files with 11434 additions and 4743 deletions
+37 -2
View File
@@ -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
View File
@@ -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:
+7
View File
@@ -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
View File
File diff suppressed because it is too large Load Diff
File diff suppressed because it is too large Load Diff
+346
View File
@@ -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
View File
File diff suppressed because it is too large Load Diff
+537
View File
@@ -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 */
+54
View File
@@ -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;
}
/*
*----------------------------------------------------------------------
*
+8
View File
@@ -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
+9
View File
@@ -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
View File
@@ -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;
}
+23
View File
@@ -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 */
/*
+528
View File
@@ -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 **)&copyPtr->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:
*/
+169
View File
@@ -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
View File
File diff suppressed because it is too large Load Diff
+61 -37
View File
@@ -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)
}
}
}
}
+14 -1
View File
@@ -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]
+411
View File
@@ -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)
}
+121
View File
@@ -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
+8
View File
@@ -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
View File
File diff suppressed because it is too large Load Diff
+13 -4
View File
@@ -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
+71
View File
@@ -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 */
/*
+2
View File
@@ -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) \
+2
View File
@@ -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
View File
@@ -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;
}
}
/*