## xlogger.pkg
#
# Control of x-kit tracing.
#
# This package is used extensively internally
# and also exported for client use.
#
# Internal users include:
#
# src/lib/x-kit/xclient/src/stuff/xgripe.pkg# src/lib/x-kit/xclient/src/window/color-spec.pkg# src/lib/x-kit/xclient/src/window/draw-imp-old.pkg# src/lib/x-kit/xclient/src/window/font-imp-old.pkg# src/lib/x-kit/xclient/src/window/pen-to-gcontext-imp-old.pkg# src/lib/x-kit/xclient/src/window/keymap-imp-old.pkg# src/lib/x-kit/xclient/src/window/window-property-imp-old.pkg# src/lib/x-kit/xclient/src/window/selection-imp-old.pkg# src/lib/x-kit/xclient/src/window/hostwindow-to-widget-router-old.pkg# src/lib/x-kit/xclient/src/window/xsocket-to-hostwindow-router-old.pkg# src/lib/x-kit/xclient/src/wire/display-old.pkg# src/lib/x-kit/xclient/src/wire/socket-closer-imp-old.pkg# src/lib/x-kit/xclient/src/wire/wire-to-value.pkg# src/lib/x-kit/xclient/src/wire/xsocket-old.pkg#
# src/lib/x-kit/widget/old/basic/hostwindow.pkg# src/lib/x-kit/widget/old/basic/xevent-mail-router.pkg# src/lib/x-kit/widget/old/leaf/canvas.pkg# src/lib/x-kit/widget/lib/image-imp.pkg# src/lib/x-kit/widget/old/lib/ro-pixmap-cache-old.pkg# src/lib/x-kit/widget/old/lib/shade-imp-old.pkg# src/lib/x-kit/widget/old/text/one-line-virtual-terminal.pkg# src/lib/x-kit/widget/old/text/text-widget.pkg#
#
# External users include:
#
# src/lib/x-kit/tut/arithmetic-game/arithmetic-game-app.pkg# src/lib/x-kit/tut/bouncing-heads/bouncing-heads-app.pkg# src/lib/x-kit/tut/badbricks-game/badbricks-game-app.pkg # src/lib/x-kit/tut/calculator/calculator-app.pkg# src/lib/x-kit/tut/colormixer/colormixer-app.pkg# src/lib/x-kit/tut/show-graph/show-graph-app.pkg# src/lib/x-kit/widget/old/fancy/graphviz/text/text-canvas.pkg# src/lib/x-kit/widget/old/fancy/graphviz/text/view-buffer.pkg# src/lib/x-kit/widget/old/fancy/graphviz/text/text-display.pkg# src/lib/x-kit/widget/old/fancy/graphviz/text/scroll-viewer.pkg# src/lib/x-kit/tut/nbody/animate-sim-g.pkg# src/lib/x-kit/tut/plaid/plaid-app.pkg# src/lib/x-kit/tut/triangle/triangle-app.pkg# src/lib/x-kit/tut/widget/label-slider.pkg# src/lib/x-kit/tut/widget/simple-with-menu.pkg# src/lib/x-kit/tut/widget/simple.pkg# src/lib/x-kit/tut/widget/test-vtty.pkg# src/lib/x-kit/tut/widget/test-font.pkg# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublib### "Our Earth is degenerate in these later days:
### bribery and corruption are rife,
### children no longer obey their parents,
### and every man wants to write a book -- the
### end of the world is clearly near!"
###
### -- Assyrian clay tablet circa 2800 B.C.
stipulate
package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package dw = thread_deathwatch; # thread_deathwatch is from src/lib/src/lib/thread-kit/src/lib/thread-deathwatch.pkg package log = logger; # logger is from src/lib/src/lib/thread-kit/src/lib/logger.pkgherein
package xlogger {
#
# The root of all x-kit trace modules:
#
xkit_logging = log::make_logtree_leaf { parent => fil::all_logging, name => "xlogger::xkit_logging", default => FALSE };
# A trace module for controlling
# the printing of error messages:
#
error_logging = log::make_logtree_leaf { parent => xkit_logging, name => "xlogger::error_logging", default => FALSE };
# A trace module for controlling make_thread output:
#
make_thread_logging = log::make_logtree_leaf { parent => xkit_logging, name => "xlogger::make_thread_logging", default => FALSE };
# x-kit library-level trace modules
#
lib_logging = log::make_logtree_leaf { parent => xkit_logging, name => "xlogger::lib_logging", default => FALSE };
#
io_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::io_logging", default => FALSE };
font_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::font_logging", default => FALSE };
color_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::color_logging", default => FALSE };
#
draw_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::draw_logging", default => FALSE };
dm_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::dm_logging", default => FALSE };
#
xsocket_to_hostwindow_router_tracing = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::xsocket_to_hostwindow_router_tracing", default => TRUE };
hostwindow_to_widget_router_tracing = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::hostwindow_to_widget_router_tracing", default => FALSE };
#
graphics_context_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::graphics_context_logging", default => FALSE };
selection_logging = log::make_logtree_leaf { parent => lib_logging, name => "xlogger::selection_logging", default => FALSE };
# The root of the widgets trace modules:
#
widgets_logging = log::make_logtree_leaf { parent => xkit_logging, name => "xlogger::widgets_logging", default => FALSE };
log_if = log::log_if;
fun err_trace f
=
log_if error_logging 0 f;
fun reset ()
=
{ log::disable xkit_logging;
log::enable error_logging;
};
my _ =
reset (); # Make sure error reporting is turned on.
# Initialiize the state of the trace modules
# according to the argument list.
#
# The format of an argument is:
#
# [!|-|+]name
#
# where
#
# "-name" means log::disenable "name"
# "+name" means log::enable "name"
# "!name" means log::enable_only "name"
# "name" is an abbreviation for "+name".
#
fun init args
=
{ fun tail s
=
substring (s, 1, size s - 1);
fun do_arg ""
=>
();
do_arg s
=>
case (string::get_byte_as_char (s, 0))
#
'+' => log::enable (fil::find_logtree_node_by_name (tail s));
'-' => log::disable (fil::find_logtree_node_by_name (tail s));
'!' => log::enable_node (fil::find_logtree_node_by_name (tail s));
_ => log::enable (fil::find_logtree_node_by_name s);
esac;
end;
reset ();
apply do_arg args;
};
/***
listLen = REF 16
lineLen = REF 20
fun prBuf lvl s = let
pr = pr lvl
fun f (i, 1, 0) = (pr "\n "; pr (makestring (ro_int8_vec_get (s, i))))
| f (i, 1, _) = pr (makestring (ro_int8_vec_get (s, i)))
| f (i, n, 0) = (pr "\n "; f (i, n, *lineLen))
| f (i, n, k) = (
pr (makestring (ro_int8_vec_get (s, i)));
pr ", ";
f (i+1, n - 1, k - 1))
n = string::size s
in
pr "[ ";
if (n <= *listLen)
then (f (0, n, *lineLen); pr " ]\n")
else (f (0, *listLen, *lineLen); pr " ...]\n")
end
***/
stipulate
# NOTE: The "raised_at" function
# should probably be provided by Lib7. XXX BUGGO FIXME
fun raised_at exn
=
case (list::reverse (lib7::exception_history exn))
#
[] => "";
(s ! _) => "raised at " + s;
esac;
fun handle_xerror (thread, exn as xgripe::XERROR s)
=>
{ log::log_if error_logging 0 {.
cat [ "exception (XERROR ", s, ") in ",
threadkit::get_thread's_id_as_string thread,
raised_at exn
];
};
TRUE;
};
handle_xerror _
=>
FALSE;
end;
herein
my _ =
uncaught_exception_reporting::add_uncaught_exception_action
#
handle_xerror;
end;
# thread_deathwatch is from src/lib/src/lib/thread-kit/src/lib/thread-deathwatch.pkg fun make_thread'
(thread_args: List(threadkit::Make_Thread_Args) ) # Name of thread for reporting purposes -- not used algorithmically.
(f: X -> Void) # Code for thread to run.
(x: X)
=
{ thread_name = get_thread_name thread_args
where
fun get_thread_name ([] ) => ""; # Default to empty name if not specified.
get_thread_name ((threadkit::THREAD_NAME thread_name) ! rest) => thread_name;
get_thread_name ( _ ! rest) => get_thread_name rest;
end;
end;
fun thread_body_wrapper x
=
{ thread = get_current_microthread ();
#
dw::start_thread_deathwatch (thread_name, thread);
log_if make_thread_logging 0 {. cat [ "make_thread '", thread_name, "' ", get_thread's_id_as_string thread ]; };
f x;
log_if make_thread_logging 0 {. cat [ "thread '", thread_name, "' ", get_thread's_id_as_string thread, " exiting." ]; };
dw::stop_thread_deathwatch thread;
}
except
ex = { fun f (s, l) # This part may be obsolete now that microthread::make_thread'
= " ** " # logs exception info in microthread.state ...? -- 2012-08-12 CrT
! s
! "\n"
! l
;
trace_back
=
list::fold_backward f [] (lib7::exception_history ex);
case ex
#
xgripe::XERROR s
=>
log_if error_logging 5 {. cat ([ "exception (XERROR ", s, ") in thread '", thread_name, "'\n" ] @ trace_back); };
DIE s
=>
log_if error_logging 5 {. cat ([ "exception DIE(", s, ") in thread '", thread_name, "'\n" ] @ trace_back); };
_ =>
log_if error_logging 5 {. cat ([ "exception ", exception_message ex, " in thread '", thread_name, "'\n" ] @ trace_back); };
esac;
dw::stop_thread_deathwatch
(get_current_microthread ());
};
threadkit::make_thread' thread_args thread_body_wrapper x;
};
fun make_thread
(thread_name: String)
(thread_body: Void -> Void)
=
make_thread' [ threadkit::THREAD_NAME thread_name ] thread_body ();
# Wrapper to report uncaught exceptions:
#
fun diag (f, s) x
=
(f x)
except
ex = { log_if error_logging 0 {. cat [ "exception ", exception_name ex, " in ", s ]; };
raise exception ex;
};
}; # package xlogger
end; # stipulate