forked from dylan-lang/logging
-
Notifications
You must be signed in to change notification settings - Fork 0
/
logging.dylan
884 lines (752 loc) · 28.9 KB
/
logging.dylan
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
Module: logging-impl
Author: Carl L Gay
Synopsis: Simple logging mechanism. Some ideas taken from log4j.
Copyright: Copyright (c) 2013 Dylan Hackers. See License.txt for details.
/*
See README.rst for documentation.
todo -- implement keep-versions in <rolling-file-log-target>
todo -- implement compress-on-close? in <rolling-file-log-target>
todo -- configuration parser
todo -- more documentation
todo -- more tests
todo -- Handle errors gracefully. e.g., if the disk fills up it may be
better to do nothing than to err. Catch errors in user code when
logging a message and log "*** error generating log message ***",
for example. If logging to stream/file fails, log to stderr as
a fallback. (e.g., someone forks and closes all fds)
todo -- <file-log-target> should accept a string for the filename to
avoid making people import locators. God I hate the locators
library.
todo -- <rolling-file-log-target>: Should roll the file when either a
max size or a max time is reached, whichever comes first.
Should make it possible for users to override roll-log-file?
and rolled-log-file-name methods if they want to roll their
own. Should also have option to compress on roll. Should also
be able to specify that it roll "daily at midnight" etc.
todo -- Add a way to extend the set of format directives from outside
the library. Get rid of code duplication in formatter parsing.
??? -- Is there a reasonable use case where you might not want \n at the
end of each log entry? Rather than hard-coding the \n one could
specify it in the formatter's control string. The worry is that
everyone would forget to add it every time they write a new formatter.
idea -- There's often a tension between the level of logging you want
to retain permanently and the level of logging you need for
debugging. Could support writing different log levels to
additional targets. Then one could log debug messages to a
separate file and set them to roll every 5 minutes, with a
small number of revisions, and you have essentially a circular
buffer of recent debug info. Log to RAMdisk...even better, to
avoid disk contention. :-)
idea -- It is useful for general purpose libraries (e.g., an XML parser)
to do logging. You normally want this logging disabled. A calling
library will probably want to turn on the XML parser's logging for
specific threads, for debugging purposes. The XML parser can use
an exported thread variable to hold its debug log and callers can
rebind that to the log they want. (Not really an issue for this
logging library to address...more of a suggestion for something to
add to future documentation.) Just enabling the XML parser's log
won't always be what users want because it will enable logging in
all threads.
todo -- Look at concurrency issues. For example, is it possible for log
messages to be written with out-of-order timestamps when multiple
threads log to the same file via different log targets. Can either
document that and say "don't do that" or fix it. Similarly, could
add OPTIONAL file locking (a la fcntl.flock(fd, LOCK_EX)) so that
multiple processes can ensure that large log messages are written
atomically and guarantee monotonically increasing log entry dates.
Must be optional since it's heavyweight.
idea -- Support logging categories. Each log message is associated with a
category. Each category has a log level associated with it. This
makes it easy to adjust the types of debug logging per category at
run time. Categories could be hierarchical so that messages from
entire subsystems can be enabled/disabled en masse.
todo -- See http://pypi.python.org/pypi/LogPy/1.0 for some (well, at least one)
interesting ideas. Attach arbitrary tags to log messages (instead of
hierarchical categories or in addition to?).
*/
///////////////////////////////////////////////////////////
//// Log classes
////
define variable $root-log :: false-or(<log>) = #f;
define sealed generic log-name
(log :: <abstract-log>) => (name :: <string>);
define sealed generic log-parent
(log :: <abstract-log>) => (parent :: false-or(<abstract-log>));
define sealed generic log-children
(log :: <abstract-log>) => (children :: <string-table>);
define sealed generic log-additive?
(log :: <abstract-log>) => (additive? :: <boolean>);
define sealed generic log-enabled?
(log :: <abstract-log>) => (enabled? :: <boolean>);
define abstract class <abstract-log> (<object>)
// A dotted path name. All parent logs in the path must already exist.
constant slot log-name :: <string>,
required-init-keyword: name:;
slot log-parent :: false-or(<abstract-log>) = #f,
init-keyword: parent:;
constant slot log-children :: <string-table> = make(<string-table>),
init-keyword: children:;
// If this is #t then log messages sent to this log will be passed up
// the hierarchy to parent logs as well, until it reaches a log
// whose additivity is #f. Terminology stolen from log4j.
//
slot log-additive? :: <boolean> = #t,
init-keyword: additive?:;
// If disabled, no messages will be logged to this log's targets.
// The value of log-additive? will still be respected. In other
// words, logging to a disabled log will still log to ancestor
// logs if they are themselves enabled.
//
slot log-enabled? :: <boolean> = #t,
init-keyword: enabled?:;
end class <abstract-log>;
define method initialize
(log :: <abstract-log>, #key name :: <string>)
next-method();
if ($root-log)
add-log($root-log, log, as(<list>, split(name, '.')), name);
end;
end method initialize;
define function local-name
(log :: <abstract-log>)
=> (local-name :: <string>)
last(split(log.log-name, '.'))
end;
// Instances of this class are used as placeholders in the log hierarchy when
// a log is created before its parents are created. i.e., if the first log
// created is named "x.y.z" then both x and x.y will be <placeholder-log>s.
// (If x.y is later created as a real log then the placeholder will be replaced.)
//
define open class <placeholder-log> (<abstract-log>)
end;
define sealed generic log-level (log :: <log>) => (level :: <log-level>);
define sealed generic log-targets (log :: <log>) => (targets :: <vector>);
define sealed generic log-formatter (log :: <log>) => (formatter :: <log-formatter>);
define open class <log> (<abstract-log>)
slot log-level :: <log-level> = $trace-level,
init-keyword: level:;
constant slot log-targets :: <stretchy-vector> = make(<stretchy-vector>),
init-keyword: targets:;
slot log-formatter :: <log-formatter> = $default-log-formatter,
init-keyword: formatter:;
end class <log>;
define method make
(class :: subclass(<log>),
#rest args,
#key formatter, targets :: false-or(<sequence>))
=> (log)
// Formatter may be specified as a string for convenience.
if (instance?(formatter, <string>))
formatter := make(<log-formatter>, pattern: formatter);
end;
// Make sure targets is a <stretchy-vector>. It's convenient for users
// to be able to pass list(make(<target> ...)) though.
let targets = as(<stretchy-vector>, targets | #[]);
apply(next-method, class,
targets: targets,
formatter: formatter | $default-log-formatter,
args)
end method make;
define method print-object
(log :: <log>, stream :: <stream>)
=> ()
if (*print-escape?*)
next-method();
else
format(stream, "%s (%sadditive, level: %s, targets: %s)",
log.log-name,
if (log.log-additive?) "" else "non-" end,
log.log-level.level-name,
if (empty?(log.log-targets))
"None"
else
join(log.log-targets, ", ", key: curry(format-to-string, "%s"))
end);
end;
end method print-object;
define method add-target
(log :: <log>, target :: <log-target>) => ()
add-new!(log.log-targets, target)
end;
define method remove-target
(log :: <log>, target :: <log-target>) => ()
remove!(log.log-targets, target);
end;
define method remove-all-targets
(log :: <log>) => ()
for (target in log.log-targets)
remove-target(log, target)
end;
end;
define open class <logging-error> (<error>, <simple-condition>)
end;
define function logging-error
(control-string, #rest args)
signal(make(<logging-error>,
format-string: control-string,
format-arguments: args))
end;
define function get-root-log
() => (log :: <log>)
$root-log
end;
define function get-log
(name :: <string>) => (log :: false-or(<abstract-log>))
%get-log($root-log, as(<list>, split(name, '.')), name)
end;
define method %get-log
(log :: <abstract-log>, path :: <list>, original-name :: <string>)
if (empty?(path))
log
else
let child = element(log.log-children, first(path), default: #f);
child & %get-log(child, path.tail, original-name)
end
end method %get-log;
define method %get-log
(log :: <placeholder-log>, path :: <list>, original-name :: <string>)
~empty?(path) & next-method()
end method %get-log;
define method %get-log
(log == #f, path :: <list>, original-name :: <string>)
logging-error("Log not found: %s", original-name);
end method %get-log;
define function add-log
(parent :: <abstract-log>, new :: <abstract-log>, path :: <list>,
original-name :: <string>)
let name :: <string> = first(path);
let child = element(parent.log-children, name, default: #f);
if (path.size == 1)
if (child)
if (instance?(child, <placeholder-log>))
// Copy the placeholder's children into the new log that
// is replacing it.
for (grandchild in child.log-children)
new.log-children[local-name(grandchild)] := grandchild;
grandchild.log-parent := new;
end;
else
logging-error("Invalid log name, %s. A child log named %s "
"already exists.", original-name, name);
end;
end;
parent.log-children[name] := new;
new.log-parent := parent;
else
if (~child)
child := make(<placeholder-log>, name: name, parent: parent);
parent.log-children[name] := child;
end;
add-log(child, new, path.tail, original-name);
end;
end function add-log;
///////////////////////////////////////////////////////////
//// Log levels
////
// Root of the log level hierarchy. Logging uses a simple class
// hierarchy to determine what messages should be logged.
//
define open abstract primary class <log-level> (<object>)
constant slot level-name :: <byte-string>,
init-keyword: name:;
end;
define open class <trace-level> (<log-level>)
inherited slot level-name = "trace";
end;
define open class <debug-level> (<trace-level>)
inherited slot level-name = "debug";
end;
define open class <info-level> (<debug-level>)
inherited slot level-name = "info";
end;
define open class <warn-level> (<info-level>)
inherited slot level-name = "WARN";
end;
define open class <error-level> (<warn-level>)
inherited slot level-name = "ERROR";
end;
define constant $trace-level = make(<trace-level>);
define constant $debug-level = make(<debug-level>);
define constant $info-level = make(<info-level>);
define constant $warn-level = make(<warn-level>);
define constant $error-level = make(<error-level>);
define method log-level-applicable?
(given-level :: <log-level>, level :: <log-level>)
=> (applicable? :: <boolean>)
instance?(given-level, level.object-class)
end;
///////////////////////////////////////////////////////////
//// Logging messages
////
// This is generally called via log-info, log-error, etc, which simply curry
// the first argument.
//
define method log-message
(given-level :: <log-level>, log :: <log>, object :: <object>, #rest args)
=> ()
if (log.log-enabled? & log-level-applicable?(given-level, log.log-level))
for (target :: <log-target> in log.log-targets)
log-to-target(target, given-level, log.log-formatter, object, args);
end;
end;
if (log.log-additive?)
apply(log-message, given-level, log.log-parent, object, args);
end;
end method log-message;
define method log-message
(given-level :: <log-level>, log :: <placeholder-log>, object :: <object>,
#rest args)
if (log.log-additive?)
apply(log-message, given-level, log.log-parent, object, args)
end;
end;
// I'm not sure log-trace is a useful distinction from log-debug.
// I copied it from log4j terminology. I dropped log-fatal.
// TODO(cgay): these days I would probably drop log-trace and keep
// log-fatal. It's a nice way to exit the program with a backtrace.
define constant log-trace = curry(log-message, $trace-level);
define constant log-debug = curry(log-message, $debug-level);
define inline function log-debug-if
(test, log :: <abstract-log>, object, #rest args)
if (test)
apply(log-debug, log, object, args);
end;
end;
define constant log-info = curry(log-message, $info-level);
define constant log-warning = curry(log-message, $warn-level);
define constant log-error = curry(log-message, $error-level);
///////////////////////////////////////////////////////////
//// Targets
////
// Abstract target for logging. Subclasses represent different
// backend targets such as streams, files, databases, etc.
//
define open abstract class <log-target> (<closable-object>)
end;
// When this is called, the decision has already been made that this object
// must be logged for the given log level, so methods should unconditionally
// write the object to the backing store.
//
define open generic log-to-target
(target :: <log-target>, level :: <log-level>, formatter :: <log-formatter>,
object :: <object>, args :: <sequence>)
=> ();
// Override this if you want to use a normal formatter string but
// want to write objects to the log stream instead of strings.
//
define open generic write-message
(target :: <log-target>, object :: <object>, args :: <sequence>)
=> ();
// Note that there is no default method on "object :: <object>".
define method close
(target :: <log-target>, #key)
=> ()
// do nothing
end;
// A log target that simply discards its output.
define sealed class <null-log-target> (<log-target>)
end;
define sealed method log-to-target
(target :: <null-log-target>, level :: <log-level>,
formatter :: <log-formatter>, format-string :: <string>,
args :: <sequence>)
=> ()
// do nothing
end;
define constant $null-log-target :: <null-log-target>
= make(<null-log-target>);
// A log target that outputs directly to a stream.
// e.g., make(<stream-log-target>, stream: *standard-output*)
//
define open class <stream-log-target> (<log-target>)
constant slot target-stream :: <stream>,
required-init-keyword: #"stream";
end;
define method print-object
(target :: <stream-log-target>, stream :: <stream>)
=> ()
if (*print-escape?*)
next-method();
else
write(stream, "stream target");
end;
end method print-object;
define constant $stdout-log-target
= make(<stream-log-target>, stream: *standard-output*);
define constant $stderr-log-target
= make(<stream-log-target>, stream: *standard-error*);
define method log-to-target
(target :: <stream-log-target>, level :: <log-level>, formatter :: <log-formatter>,
format-string :: <string>, args :: <sequence>)
=> ()
let stream :: <stream> = target.target-stream;
with-stream-locked (stream)
pattern-to-stream(formatter, stream, level, target, format-string, args);
write(stream, "\n");
force-output(stream);
end;
end method log-to-target;
define method write-message
(target :: <stream-log-target>, format-string :: <string>, args :: <sequence>)
=> ()
apply(format, target.target-stream, format-string, args);
end method write-message;
// A log target that is backed by a single, monolithic file.
// (Why is this not a subclass of <stream-log-target>?)
//
define class <file-log-target> (<log-target>)
constant slot target-pathname :: <pathname>,
required-init-keyword: pathname:;
slot target-stream :: false-or(<file-stream>) = #f;
end;
define method initialize
(target :: <file-log-target>, #key)
next-method();
open-target-stream(target);
end;
define method print-object
(target :: <file-log-target>, stream :: <stream>)
=> ()
if (*print-escape?*)
next-method();
else
format(stream, "file %s", as(<string>, target.target-pathname));
end;
end method print-object;
define open generic open-target-stream
(target :: <file-log-target>) => (stream :: <stream>);
define method open-target-stream
(target :: <file-log-target>)
=> (stream :: <file-stream>)
ensure-directories-exist(target.target-pathname);
target.target-stream := make(<file-stream>,
locator: target.target-pathname,
element-type: <character>,
direction: #"output",
if-exists: #"append",
if-does-not-exist: #"create")
end;
define method log-to-target
(target :: <file-log-target>, level :: <log-level>,
formatter :: <log-formatter>, format-string :: <string>,
format-args :: <sequence>)
=> ()
let stream :: <stream> = target.target-stream;
with-stream-locked (stream)
pattern-to-stream(formatter, stream, level, target, format-string, format-args);
write(stream, "\n");
force-output(stream);
end;
end method log-to-target;
define method write-message
(target :: <file-log-target>, format-string :: <string>, args :: <sequence>)
=> ()
apply(format, target.target-stream, format-string, args);
end;
define method close
(target :: <file-log-target>, #key abort?)
=> ()
if (target.target-stream)
close(target.target-stream, abort?: abort?);
end;
end;
// A log target that is backed by a file and ensures that the file
// only grows to a certain size, after which it is renamed to
// filename.<date-when-file-was-opened>.
//
// I investigated making this a subclass of <wrapper-stream> but it
// didn't work well due to the need to create the inner-stream
// first and pass it as an init arg. That doesn't work too well
// given that I want to roll the log if the file exists when I
// first attempt to open it. It leads to various special cases.
//
// Attempt to re-open the file if logging to it gets (the equivalent
// of) bad file descriptor?
//
define class <rolling-file-log-target> (<file-log-target>)
constant slot max-file-size :: <integer> = 100 * 1024 * 1024,
init-keyword: max-size:;
// TODO: not yet implemented
// If this is #f then all versions are kept.
//constant slot keep-versions :: false-or(<integer>) = #f,
// init-keyword: #"keep-versions";
// TODO: not yet implemented
//constant slot compress-on-close? :: <boolean> = #t,
// init-keyword: #"compress?";
// Date when the underlying file was created. When it gets closed
// it will be renamed with this date in the name.
slot file-creation-date :: <date> = current-date();
end class <rolling-file-log-target>;
define constant $log-roller-lock :: <lock> = make(<lock>);
define method initialize
(target :: <rolling-file-log-target>, #key roll :: <boolean> = #t)
if (roll
& file-exists?(target.target-pathname)
& file-property(target.target-pathname, #"size") > 0)
roll-log-file(target);
end;
next-method();
end method initialize;
define method print-object
(target :: <rolling-file-log-target>, stream :: <stream>)
=> ()
if (*print-escape?*)
next-method();
else
format(stream, "rolling file %s", as(<string>, target.target-pathname));
end;
end method print-object;
define method log-to-target
(target :: <rolling-file-log-target>, level :: <log-level>,
formatter :: <log-formatter>, format-string :: <string>,
format-args :: <sequence>)
=> ()
next-method();
// todo -- calling stream-size may be very slow? Maybe log-to-target should
// return the number of bytes written, but that could be inefficient (e.g.,
// it might have to format to string and then write that to the underlying
// stream instead of formatting directly to the stream).
if (stream-size(target.target-stream) >= target.max-file-size)
roll-log-file(target);
end;
end;
define method roll-log-file
(target :: <rolling-file-log-target>)
with-lock ($log-roller-lock)
if (target.target-stream) // may be #f first time
close(target.target-stream);
end;
// todo -- make the archived log filename accept %{date:fmt} and
// %{version} escapes. e.g., "foo.log.%{version}"
// Also consider putting more info in the rolled filenames, such
// as process id, hostname, etc. Makes it easier to combine files
// into a single location.
let date = format-date("%Y%m%dT%H%M%S", target.file-creation-date);
let oldloc = as(<file-locator>, target.target-pathname);
let newloc = merge-locators(as(<file-locator>,
concatenate(locator-name(oldloc), ".", date)),
oldloc);
rename-file(oldloc, newloc);
target.file-creation-date := current-date();
open-target-stream(target);
end with-lock;
end method roll-log-file;
///////////////////////////////////////////////////////////
//// Formatting
////
define open class <log-formatter> (<object>)
constant slot formatter-pattern :: <string>,
required-init-keyword: pattern:;
slot parsed-pattern :: <sequence>;
end class <log-formatter>;
// Leave in for debugging for now.
ignore(formatter-pattern);
define method initialize
(formatter :: <log-formatter>, #key pattern :: <string>)
next-method();
formatter.parsed-pattern := parse-formatter-pattern(pattern);
end;
// Should be called with the stream locked.
//
define method pattern-to-stream
(formatter :: <log-formatter>, stream :: <stream>,
level :: <log-level>, target :: <log-target>,
object :: <object>, args :: <sequence>)
=> ()
for (item in formatter.parsed-pattern)
if (instance?(item, <string>))
write(stream, item);
else
// This is a little hokey, but it was easier to allow some
// formatter functions to just return a string and others
// to write to the underlying stream, so if the function
// returns #f it means "i already did my output".
let result = item(level, target, object, args);
if (result)
write(stream, result);
end;
end;
end;
end method pattern-to-stream;
// Parse a string of the form "%{r} blah %{m} ..." into a list of functions
// and/or strings. The functions can be called with no arguments and return
// strings. The concatenation of all the resulting strings is the log message.
// (The concatenation needn't ever be done if writing to a stream, but I do
// wonder which would be faster, concatenation or multiple stream writes.
// Might be worth benchmarking at some point.)
//
define method parse-formatter-pattern
(pattern :: <string>)
=> (parsed :: <sequence>)
let result :: <stretchy-vector> = make(<stretchy-vector>);
block (exit)
let dispatch-char :: <byte-character> = '%';
let index :: <integer> = 0;
let control-size :: <integer> = pattern.size;
local method next-char () => (char :: <character>)
if (index >= control-size)
logging-error("Log format control string ended prematurely: %s",
pattern);
else
let char = pattern[index];
index := index + 1;
char
end
end method;
local method peek-char () => (char :: false-or(<character>))
if (index < control-size)
pattern[index]
end
end;
while (index < control-size)
// Skip to dispatch char.
for (i :: <integer> = index then (i + 1),
until: ((i == control-size)
| (pattern[i] == dispatch-char)))
finally
if (i ~== index)
add!(result, copy-sequence(pattern, start: index, end: i));
end;
if (i == control-size)
exit();
else
index := i + 1;
end;
end for;
let start :: <integer> = index;
let align :: <symbol> = #"right";
let width :: <integer> = 0;
let char = next-char();
if (char == '-')
align := #"left";
char := next-char();
end;
if (member?(char, "0123456789"))
let (wid, idx) = string-to-integer(pattern, start: index - 1);
width := wid;
index := idx;
char := next-char();
end;
local method pad (string :: <string>)
let len :: <integer> = string.size;
if (width <= len)
string
else
let fill :: <string> = make(<string>, size: width - len, fill: ' ');
if (align == #"left")
concatenate(string, fill)
else
concatenate(fill, string)
end
end
end method;
local method parse-long-format-control ()
let bpos = index;
while (~member?(peek-char(), ":}")) next-char() end;
let word = copy-sequence(pattern, start: bpos, end: index);
let arg = #f;
if (pattern[index] == ':')
next-char();
let start = index;
while(peek-char() ~= '}') next-char() end;
arg := copy-sequence(pattern, start: start, end: index);
end;
next-char(); // eat '}'
select (word by \=)
"date" =>
method (#rest args)
pad(if (arg)
format-date(arg, current-date())
else
as-iso8601-string(current-date())
end)
end;
"level" =>
method (level, target, object, args)
pad(level-name(level))
end;
"message" =>
method (level, target, object, args)
write-message(target, object, args);
#f
end;
"pid" =>
method (#rest args)
pad(integer-to-string(current-process-id()));
end;
"millis" =>
method (#rest args)
pad(number-to-string(elapsed-milliseconds()));
end;
"thread" =>
method (#rest args)
pad(thread-name(current-thread()));
end;
otherwise =>
// Unknown control string. Just output the text we've seen...
copy-sequence(pattern, start: start, end: index);
end select;
end method;
add!(result,
select (char)
'{' => parse-long-format-control();
'd' =>
method (#rest args)
pad(as-iso8601-string(current-date()));
end;
'l', 'L' =>
method (level, target, object, args)
pad(level-name(level))
end;
'm' =>
method (level, target, object, args)
write-message(target, object, args);
#f
end;
'p' =>
method (#rest args)
pad(integer-to-string(current-process-id()));
end;
'r' =>
method (#rest args)
pad(number-to-string(elapsed-milliseconds()));
end;
't' =>
method (#rest args)
pad(thread-name(current-thread()));
end;
'%' => pad("%");
otherwise =>
// Unknown control char. Just output the text we've seen...
copy-sequence(pattern, start: start, end: index);
end);
end while;
end block;
result
end method parse-formatter-pattern;
define constant $default-log-formatter :: <log-formatter>
= make(<log-formatter>, pattern: "%{date:%Y-%m-%dT%H:%M:%S.%F%z} %-5L [%t] %m");
define constant $application-start-date :: <date> = current-date();
define function elapsed-milliseconds
() => (millis :: <double-integer>)
let duration :: <duration> = current-date() - $application-start-date;
let (days, hours, minutes, seconds, microseconds) = decode-duration(duration);
plus(div(microseconds, 1000.0),
plus(mul(seconds, 1000),
plus(mul(minutes, 60000),
plus(mul(hours, 3600000), mul(days, 86400000)))))
end function elapsed-milliseconds;
/////////////////////////////////////////////////////
//// For use by the test suite
////
define function reset-logging
()
// maybe should close existing log targets?
$root-log := make(<log>, name: "root", additive?: #f, enabled?: #f);
end;
/////////////////////////////////////////////////////
//// Initialize
////
begin
reset-logging();
end;