1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        jan@swi-prolog.org
    5    WWW:           https://www.swi-prolog.org
    6    Copyright (c)  1985-2021, University of Amsterdam
    7			      SWI-Prolog Solutions b.v.
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(pce_debug,
   37        [ debugpce/0
   38        , debugpce/1
   39        , nodebugpce/0
   40        , nodebugpce/1
   41        , tracepce/1                    % Trace a pce method
   42        , notracepce/1                  % UnTrace a pce method
   43        , spypce/1                      % Trace a pce method
   44        , nospypce/1                    % UnTrace a pce method
   45        , checkpce/0                    % Check all global pce objects
   46        , show_slots/1                  % Show all pce slot-values
   47        , pcerefer/1                    % Print objects refering to me
   48        , pcerefer/2                    % Print objects refering to me
   49        , pce_global_objects/1          % -globals
   50        ]).   51:- use_module(library(pce)).   52:- require([ forall/2
   53           , pce_to_method/2
   54           , append/3
   55           , between/3
   56           , genarg/3
   57           ]).   58:- set_prolog_flag(generate_debug_info, false).   59:- meta_predicate test(0,-).   60
   61% leave this to the user
   62% :- op(100, xfx, user:(<-)).
   63
   64%   debugpce/0
   65%   nodebugpce/0
   66
   67debugpce :-
   68    send(@pce, debugging, @on).
   69nodebugpce :-
   70    send(@pce, debugging, @off).
   71
   72
   73%%   debugpce(+Subject) is det.
   74%%   nodebugpce(+Subject) is det.
   75%
   76%   Start/stop printing debugging messages on `Subject'. System maintenance
   77%   usage only.
   78
   79debugpce(Subject) :-
   80    send(@pce, debug_subject, Subject).
   81
   82nodebugpce(Subject) :-
   83    send(@pce, nodebug_subject, Subject).
   84
   85
   86
   87%       (no)tracepce(+ClassName ->|<- +Selector)
   88%
   89%       Send a ->trace message to the refered method.  This will cause
   90%       PCE to  print the enters,  exits or failures  of  this method.
   91%       Prints  the class  and selector   on  which  the tracepoint is
   92%       actually set (which might be an inherited method).
   93
   94tracepce(Spec) :-
   95    method(Spec, Method),
   96    send(Method, trace, full),
   97    trace_feedback('Tracing', Method).
   98
   99notracepce(Spec) :-
  100    !,
  101    method(Spec, Method),
  102    send(Method, trace, full, @off),
  103    trace_feedback('Stopped tracing', Method).
  104
  105%       (no)spypce(+ClassName ->|<- +Selector)
  106%
  107%       Put a spy-point on the Prolog implementation or XPCE method object
  108
  109spypce(Spec) :-
  110    method(Spec, Method),
  111    send(Method, break, full),
  112    (   prolog_method(Method)
  113    ->  debug
  114    ;   true
  115    ),
  116    trace_feedback('Spying', Method).
  117
  118nospypce(Spec) :-
  119    method(Spec, Method),
  120    send(Method, break, full, @off),
  121    trace_feedback('Stopped spying', Method).
  122
  123method(Spec, Method) :-
  124    pce_to_method(Spec, Method),
  125    send(Method, instance_of, behaviour).
  126
  127
  128%       succeed if the method is implemented in Prolog (dubious test).
  129
  130prolog_method(Implementation) :-
  131    send(Implementation, instance_of, method),
  132    get(Implementation, message, Msg),
  133    send(Msg, instance_of, c_pointer).
  134
  135trace_feedback(Action, Obj) :-
  136    (   prolog_method(Obj)
  137    ->  Type = 'Prolog implementation of'
  138    ;   get(Obj?class_name, label_name, Type)
  139    ),
  140    get(Obj?context, name, ClassName),
  141    get(Obj, name, Selector),
  142    get(Obj, access_arrow, Arrow),
  143    format('~w ~w: ~w ~w~w~n', [Action, Type, ClassName, Arrow, Selector]).
  144
  145
  146                /********************************
  147                *       CHECK PCE DATABASE      *
  148                ********************************/
  149
  150%!  pce_global_objects(-ChainOfGlobalObjects)
  151%   Return a chain with all globally known objects.
  152
  153pce_global_objects(Chain) :-
  154    new(Chain, chain),
  155    send(@pce, for_name_reference,
  156         message(@prolog, '_append_reference', Chain, @arg1)).
  157
  158'_append_reference'(_, Name) :-
  159    non_object_reference(Name),
  160    !.
  161'_append_reference'(Chain, Name) :-
  162    send(Chain, '_append', @Name).
  163
  164non_object_reference('_object_to_itf_table').
  165non_object_reference('_name_to_itf_table').
  166non_object_reference('_handle_to_itf_table').
  167
  168%       checkpce/0
  169%
  170%       Runs a recursive  '_check' on all  reachable objects.  See the
  171%       reference documentation of `Object ->_check' for details.
  172
  173checkpce :-
  174    get(@pce, is_runtime_system, @on),
  175    !,
  176    send(checkpce, error, runtime_version).
  177checkpce :-
  178    test(check_pce_database, Status),
  179    test(check_pce_types, Status),
  180    test(check_classes, Status),
  181    test(check_redefined_methods, Status),
  182    Status = yes.
  183
  184check_classes :-
  185    (   pce_expansion:compiling(_, _)
  186    ->  forall(pce_expansion:compiling(Class, Path),
  187               ( file_base_name(Path, File),
  188                 send(@pce, format,
  189                      '[PCE: WARNING: definition of class \c
  190                          %s in ~s not closed]\n',
  191                      Class, File))),
  192        fail
  193    ;   true
  194    ).
  195
  196check_redefined_methods :-
  197    findall(S, redefined_send_method(S), SL),
  198    maplist(report_redefined_method, SL),
  199    findall(G, redefined_get_method(G), GL),
  200    maplist(report_redefined_method, GL),
  201    SL == [],
  202    GL == [].
  203
  204redefined_send_method(method(Class, Sel, B0, B1)) :-
  205    pce_principal:pce_lazy_send_method(Sel, Class, B1),
  206    (   pce_principal:pce_lazy_send_method(Sel, Class, B0)
  207    ->  B0 \== B1
  208    ;   fail
  209    ).
  210redefined_get_method(method(Class, Sel, B0, B1)) :-
  211    pce_principal:pce_lazy_get_method(Sel, Class, B1),
  212    (   pce_principal:pce_lazy_get_method(Sel, Class, B0)
  213    ->  B0 \== B1
  214    ;   fail
  215    ).
  216
  217report_redefined_method(method(_, _, B0, B1)) :-
  218    arg(1, B0, Id0),                % deliberate redefinition
  219    arg(1, B1, Id1),
  220    Id0 \== Id1,
  221    !.
  222report_redefined_method(method(Class, Sel, B0, B1)) :-
  223    describe_location(B1, Loc1),
  224    (   Loc1 = File:Line
  225    ->  Loc = file(File, Line)
  226    ;   true
  227    ),
  228    print_message(error,
  229                  error(pce(redefined_method(Class, Sel, B0, B1)),
  230                        Loc)).
  231
  232describe_location(Binder, File:Line) :-
  233    genarg(_, Binder, source_location(File, Line)),
  234    !.
  235describe_location(_, '<no source>').
  236
  237
  238check_pce_database :-
  239    pce_global_objects(All),
  240    send(All, '_check'),
  241    send(All, done).
  242
  243check_pce_types :-
  244    get(@pce, unresolved_types, Types),
  245    get(Types, find_all,
  246        message(@prolog, no_autoload_class, @arg1?context?print_name),
  247        Unresolved),
  248    (   send(Unresolved, empty)
  249    ->  true
  250    ;   send(@pce, format,
  251             '[PCE: WARNING: The following type(s) have no associated class:\n'),
  252        send(Unresolved, for_all,
  253             message(@pce, format, '\t%N\n', @arg1)),
  254        send(@pce, format, ']\n')
  255    ).
  256
  257
  258no_autoload_class(ClassName) :-
  259    pce_prolog_class(ClassName), !, fail.
  260no_autoload_class(ClassName) :-
  261    pce_autoload:autoload_decl(ClassName, _), !, fail.
  262no_autoload_class(_).
  263
  264
  265%!  show_slots(+Reference)
  266%
  267%   Show  all   slots of the   named object.  Actually,  this is a
  268%   terminal version  of   the inspector  tool  provided  with the
  269%   manual.  Notably used by me if PCE is in such  a bad shape the
  270%   inspector won't run anymore
  271
  272show_slots(X) :-
  273    get(X, '_class', Class),
  274    get(Class, slots, Slots),
  275    Max is Slots - 1,
  276    X = @Ref,
  277    get(X, '_class_name', ClassName),
  278    format('@~w/~w~n', [Ref, ClassName]),
  279    between(0, Max, Slot),
  280        get(X, '_slot', Slot, Value),
  281        get(Class, instance_variable, Slot, Var),
  282        get(Var, name, Name),
  283        format('~t~8|~w~t~30|~p~n', [Name, Value]),
  284    fail ; true.
  285
  286
  287                /********************************
  288                *             REFER             *
  289                ********************************/
  290
  291pcerefer(Obj) :-
  292    get(Obj, '_references', Refs),
  293    format('~p has ~d references~n', [Obj, Refs]),
  294    (   Refs > 0
  295    ->  pce_global_objects(All),
  296        new(Found, number(0)),
  297        send(All, for_slot_reference,
  298             if(message(Obj, '_same_reference', @arg4),
  299                message(@prolog, call,
  300                        pcerefer, Obj, @arg1, @arg2, @arg3, All, Found))),
  301        send(All, done),
  302        get(Found, value, FoundRefs),
  303        (   Refs == FoundRefs
  304        ->  format('Found all references~n', [])
  305        ;   format('Found ~d of ~d references~n', [FoundRefs, Refs])
  306        ),
  307        free(Found)
  308    ;   true
  309    ).
  310
  311
  312pcerefer(From, Obj) :-
  313    get(Obj, references, Refs),
  314    format('~p has ~d references~n', [Obj, Refs]),
  315    (   Refs > 0
  316    ->  new(Found, number(0)),
  317        send(From, for_slot_reference,
  318             if(Obj == @arg4,
  319                message(@prolog, call,
  320                        pcerefer, Obj, @arg1, @arg2, @arg3, @nil, Found))),
  321        free(Found)
  322    ;   true
  323    ).
  324
  325:- public pcerefer/6.  326
  327pcerefer(Obj, From, Type, Where, All, Found) :-
  328    Obj \== All,
  329    From \== All,
  330    !,
  331    get(From, '_class_name', ClassName),
  332    format('~t~8|~w ~w of ~w/~w --> ~p~n',
  333           [Type, Where, From, ClassName, Obj]),
  334    send(Found, plus, 1).
  335pcerefer(_, _, _, _, _, _).
  336
  337
  338                /********************************
  339                *           UTILITIES           *
  340                ********************************/
  341
  342test(Goal, _) :-
  343    Goal,
  344    !.
  345test(_, no).
  346
  347                 /*******************************
  348                 *            MESSAGES          *
  349                 *******************************/
  350
  351
  352:- multifile
  353    prolog:message/3.  354
  355prolog:message(error(pce(redefined_method(Class, Sel, B0, B1)), _)) -->
  356    { describe_location(B0, Loc0),
  357      describe_location(B1, Loc1),
  358      (   functor(B0, bind_send, _)
  359      ->  Arrow = (->)
  360      ;   Arrow = (<-)
  361      )
  362    },
  363    [ '~w: ~w~w~w redefined'-[Loc1, Class, Arrow, Sel], nl,
  364      '\tFirst definition at ~w'-[Loc0]
  365    ]