1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        J.Wielemaker@cs.nu.nl
    5    WWW:           http://www.swi-prolog.nl/projects/xpce/
    6    Copyright (c)  1985-2022, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9                              SWI-Prolog Solutions b.v.
   10    All rights reserved.
   11
   12    Redistribution and use in source and binary forms, with or without
   13    modification, are permitted provided that the following conditions
   14    are met:
   15
   16    1. Redistributions of source code must retain the above copyright
   17       notice, this list of conditions and the following disclaimer.
   18
   19    2. Redistributions in binary form must reproduce the above copyright
   20       notice, this list of conditions and the following disclaimer in
   21       the documentation and/or other materials provided with the
   22       distribution.
   23
   24    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   25    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   26    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   27    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   28    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   29    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   30    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   31    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   32    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   33    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   34    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   35    POSSIBILITY OF SUCH DAMAGE.
   36*/
   37
   38:- module(pce_principal,
   39          [ new/2, free/1,
   40
   41            send/2, send/3, send/4, send/5, send/6, send/7,
   42            send/8,
   43
   44            get/3, get/4, get/5, get/6, get/7, get/8,
   45
   46            send_class/3,
   47            get_class/4,
   48
   49            object/1, object/2,
   50
   51            pce_class/6,
   52            pce_lazy_send_method/3,
   53            pce_lazy_get_method/3,
   54            pce_uses_template/2,
   55
   56            pce_method_implementation/2,
   57
   58            pce_open/3,                 % +Object, +Mode, -Stream
   59            in_pce_thread/1,            % :Goal
   60            set_pce_thread/0,
   61            pce_dispatch/0,
   62
   63            pce_postscript_stream/1,    % -Stream
   64
   65            op(200, fy,  @),
   66            op(250, yfx, ?),
   67            op(800, xfx, :=)
   68          ]).   69:- autoload(library(apply),[convlist/3,maplist/2]).   70:- autoload(library(lists),[member/2,last/2,reverse/2]).   71:- autoload(library(swi_compatibility),[pce_info/1]).   72:- autoload(library(system),[unlock_predicate/1]).   73
   74:- public
   75    in_pce_thread_sync2/2.   76
   77:- meta_predicate
   78    send_class(+, +, :),
   79    send(+, :),
   80    send(+, :, +),
   81    send(+, :, +, +),
   82    send(+, :, +, +, +),
   83    send(+, :, +, +, +, +),
   84    send(+, :, +, +, +, +, +),
   85
   86    get_class(+, +, :, -),
   87    get(+, :, -),
   88    get(+, :, +, -),
   89    get(+, :, +, +, -),
   90    get(+, :, +, +, +, -),
   91    get(+, :, +, +, +, +, -),
   92    get(+, :, +, +, +, +, +, -),
   93
   94    new(?, :).   95
   96                /********************************
   97                *             HOME              *
   98                ********************************/

 pce_home(-Home) is det

True when Home is the home directory of XPCE.

  104pce_home(PceHome) :-
  105    absolute_file_name(pce('.'), PceHome,
  106                       [ file_type(directory),
  107                         file_errors(fail)
  108                       ]),
  109    exists_directory(PceHome),
  110    !.
  111pce_home(PceHome) :-
  112    getenv('XPCEHOME', PceHome),
  113    exists_directory(PceHome),
  114    !.
  115pce_home(PceHome) :-
  116    (   current_prolog_flag(xpce_version, Version),
  117        atom_concat('/xpce-', Version, Suffix)
  118    ;   Suffix = '/xpce'
  119    ),
  120    absolute_file_name(swi(Suffix), PceHome,
  121                       [ file_type(directory),
  122                         file_errors(fail)
  123                       ]),
  124    exists_directory(PceHome),
  125    !.
  126pce_home(PceHome) :-
  127    current_prolog_flag(saved_program, true),
  128    !,
  129    (   current_prolog_flag(home, PceHome)
  130    ->  true
  131    ;   current_prolog_flag(executable, Exe)
  132    ->  file_directory_name(Exe, PceHome)
  133    ;   PceHome = '.'
  134    ).
  135pce_home(_) :-
  136    throw(error(pce_error(no_home), _)).

 xpce_application_dir(-Dir)

Set the directory for storing user XPCE configuration and data.

  142xpce_application_dir(Dir) :-
  143    create_config_directory(user_app_config(xpce), Dir),
  144    !.
  145xpce_application_dir(Dir) :-
  146    expand_file_name('~/.xpce', [Dir]).

 create_config_directory(+Alias, -Dir) is semidet

Try to find an existing config directory or create a writeable config directory below a directory owned by this process. If there are multiple possibilities, create the one that requires the least number of new directories.

  156create_config_directory(Alias, Dir) :-
  157    member(Access, [write, read]),
  158    absolute_file_name(Alias, Dir0,
  159                       [ file_type(directory),
  160                         access(Access),
  161                         file_errors(fail)
  162                       ]),
  163    !,
  164    Dir = Dir0.
  165create_config_directory(Alias, Dir) :-
  166    findall(Candidate,
  167            absolute_file_name(Alias, Candidate,
  168                               [ solutions(all),
  169                                 file_errors(fail)
  170                               ]),
  171            Candidates),
  172    convlist(missing, Candidates, Paths),
  173    member(_-Create, Paths),
  174    catch(maplist(make_directory, Create), _, fail),
  175    !,
  176    last(Create, Dir).
  177
  178missing(Dir, Len-Create) :-
  179    missing_(Dir, Create0),
  180    reverse(Create0, Create),
  181    length(Create, Len).
  182
  183missing_(Dir, []) :-
  184    exists_directory(Dir),
  185    access_file(Dir, write),
  186    '$my_file'(Dir),
  187    !.
  188missing_(Dir, [Dir|T]) :-
  189    file_directory_name(Dir, Parent),
  190    Parent \== Dir,
  191    missing_(Parent, T).
  192
  193
  194                /********************************
  195                *           LOAD C-PART         *
  196                ********************************/
  197
  198init_pce :-
  199    catch(use_foreign_library(foreign(pl2xpce)),
  200          error(Error, _Context),           % suppress stack trace
  201          (   print_message(error, error(Error, _)),
  202              fail
  203          )),
  204    pce_home(Home),
  205    xpce_application_dir(AppDir),
  206    pce_init(Home, AppDir),
  207    !,
  208    create_prolog_flag(xpce, true, []),
  209    thread_self(Me),
  210    assert(pce:pce_thread(Me)).
  211init_pce :-
  212    print_message(error, error(pce_error(init_failed), _)),
  213    halt(1).
  214
  215:- initialization(init_pce, now).  216
  217:- noprofile((send_implementation/3,
  218              get_implementation/4,
  219              send_class/3,
  220              get_class/4,
  221              new/2,
  222              send/2,
  223              get/3)).  224
  225
  226                /********************************
  227                *          PROLOG LAYER         *
  228                ********************************/

 free(+Ref) is det

Delete object if it exists.

  235free(Ref) :-
  236    object(Ref),
  237    !,
  238    send(Ref, free).
  239free(_).

 send(+Object, +Selector, +Arg...) is semidet

Succeeds if sending a message to Object with Selector and the given Arguments succeeds. Normally, goal_expansion/2 expands all these goals into send(Receiver, Method(Args...)).

  248send(Receiver, M:Selector, A1) :-
  249    functor(Message, Selector, 1),
  250    arg(1, Message, A1),
  251    send(Receiver, M:Message).
  252
  253send(Receiver, M:Selector, A1, A2) :-
  254    functor(Message, Selector, 2),
  255    arg(1, Message, A1),
  256    arg(2, Message, A2),
  257    send(Receiver, M:Message).
  258
  259send(Receiver, M:Selector, A1, A2, A3) :-
  260    functor(Message, Selector, 3),
  261    arg(1, Message, A1),
  262    arg(2, Message, A2),
  263    arg(3, Message, A3),
  264    send(Receiver, M:Message).
  265
  266send(Receiver, M:Selector, A1, A2, A3, A4) :-
  267    functor(Message, Selector, 4),
  268    arg(1, Message, A1),
  269    arg(2, Message, A2),
  270    arg(3, Message, A3),
  271    arg(4, Message, A4),
  272    send(Receiver, M:Message).
  273
  274send(Receiver, M:Selector, A1, A2, A3, A4, A5) :-
  275    functor(Message, Selector, 5),
  276    arg(1, Message, A1),
  277    arg(2, Message, A2),
  278    arg(3, Message, A3),
  279    arg(4, Message, A4),
  280    arg(5, Message, A5),
  281    send(Receiver, M:Message).
  282
  283send(Receiver, M:Selector, A1, A2, A3, A4, A5, A6) :-
  284    functor(Message, Selector, 6),
  285    arg(1, Message, A1),
  286    arg(2, Message, A2),
  287    arg(3, Message, A3),
  288    arg(4, Message, A4),
  289    arg(5, Message, A5),
  290    arg(6, Message, A6),
  291    send(Receiver, M:Message).

 get(+Object, :Selector, +Arg..., ?Rval) is semidet

See the comments with send/[3-12].

  298get(Receiver, M:Selector, A1, Answer) :-
  299    functor(Message, Selector, 1),
  300    arg(1, Message, A1),
  301    get(Receiver, M:Message, Answer).
  302
  303get(Receiver, M:Selector, A1, A2, Answer) :-
  304    functor(Message, Selector, 2),
  305    arg(1, Message, A1),
  306    arg(2, Message, A2),
  307    get(Receiver, M:Message, Answer).
  308
  309get(Receiver, M:Selector, A1, A2, A3, Answer) :-
  310    functor(Message, Selector, 3),
  311    arg(1, Message, A1),
  312    arg(2, Message, A2),
  313    arg(3, Message, A3),
  314    get(Receiver, M:Message, Answer).
  315
  316get(Receiver, M:Selector, A1, A2, A3, A4, Answer) :-
  317    functor(Message, Selector, 4),
  318    arg(1, Message, A1),
  319    arg(2, Message, A2),
  320    arg(3, Message, A3),
  321    arg(4, Message, A4),
  322    get(Receiver, M:Message, Answer).
  323
  324get(Receiver, M:Selector, A1, A2, A3, A4, A5, Answer) :-
  325    functor(Message, Selector, 5),
  326    arg(1, Message, A1),
  327    arg(2, Message, A2),
  328    arg(3, Message, A3),
  329    arg(4, Message, A4),
  330    arg(5, Message, A5),
  331    get(Receiver, M:Message, Answer).
  332
  333
  334                 /*******************************
  335                 *           NEW SEND           *
  336                 *******************************/
  337
  338:- multifile
  339    send_implementation/3,
  340    get_implementation/4.

 send_implementation(+Id, +Message, +Object)

Method-bodies are compiled into clauses for this predicate. Id is a unique identifier for the implementation, Message is a compound whose functor is the method name and whose arguments are the arguments to the method-call. Object is the receiving object.

  350send_implementation(true, _Args, _Obj).
  351send_implementation(fail, _Args, _Obj) :- fail.
  352send_implementation(once(Id), Args, Obj) :-
  353    send_implementation(Id, Args, Obj),
  354    !.
  355send_implementation(spy(Id), Args, Obj) :-
  356    (   current_prolog_flag(debug, true)
  357    ->  trace,
  358        send_implementation(Id, Args, Obj)
  359    ;   send_implementation(Id, Args, Obj)
  360    ).
  361send_implementation(trace(Id), Args, Obj) :-
  362    pce_info(pce_trace(enter, send_implementation(Id, Args, Obj))),
  363    (   send_implementation(Id, Args, Obj)
  364    ->  pce_info(pce_trace(exit, send_implementation(Id, Args, Obj)))
  365    ;   pce_info(pce_trace(fail, send_implementation(Id, Args, Obj)))
  366    ).

 get_implementation(+Id, +Message, +Object, -Return)

As send_implementation/3, but for get-methods.

  373get_implementation(true, _Args, _Obj, _Rval).
  374get_implementation(fail, _Args, _Obj, _Rval) :- fail.
  375get_implementation(once(Id), Args, Obj, Rval) :-
  376    get_implementation(Id, Args, Obj, Rval),
  377    !.
  378get_implementation(spy(Id), Args, Obj, Rval) :-
  379    (   current_prolog_flag(debug, true)
  380    ->  trace,
  381        get_implementation(Id, Args, Obj, Rval)
  382    ;   get_implementation(Id, Args, Obj, Rval)
  383    ).
  384get_implementation(trace(Id), Args, Obj, Rval) :-
  385    pce_info(pce_trace(enter, get_implementation(Id, Args, Obj, Rval))),
  386    (   get_implementation(Id, Args, Obj, Rval)
  387    ->  pce_info(pce_trace(exit, get_implementation(Id, Args, Obj, Rval)))
  388    ;   pce_info(pce_trace(fail, get_implementation(Id, Args, Obj, Rval))),
  389        fail
  390    ).
  391
  392%       SWI-Prolog: make this a normal user (debug-able) predicate.
  393
  394pce_ifhostproperty(prolog(swi), [
  395(:- unlock_predicate(send_implementation/3)),
  396(:- unlock_predicate(get_implementation/4)),
  397(:- '$set_predicate_attribute'(send_implementation(_,_,_),  hide_childs, false)),
  398(:- '$set_predicate_attribute'(get_implementation(_,_,_,_), hide_childs, false))
  399                   ]).
  400
  401
  402                 /*******************************
  403                 *          DECLARATIONS        *
  404                 *******************************/
  405
  406:- multifile
  407    pce_class/6,
  408    pce_lazy_send_method/3,
  409    pce_lazy_get_method/3,
  410    pce_uses_template/2.  411
  412
  413                 /*******************************
  414                 *            @PROLOG           *
  415                 *******************************/
  416
  417:- initialization
  418   (object(@prolog) -> true ; send(@host, name_reference, prolog)).