PreviousUpNext

15.4.1605  src/lib/x-kit/xclient/src/stuff/xlogger.pkg

## 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.pkg
herein

    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


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext