## xevent-mail-router.pkg
#
# Generic X-event mail routers.
# Each non-leaf widget will have one.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "angelheaded hipsters burning for
### the ancient heavenly connection
### to the starry dynamo in the
### machinery of night"
###
### -- Alen Ginsberg
stipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkgherein
package xevent_mail_router
: (weak) Xevent_Mail_Router # Xevent_Mail_Router is from src/lib/x-kit/widget/old/basic/xevent-mail-router.api {
exception NOT_FOUND;
Plea_Mail
= ADD_CHILD (xc::Window, xc::Momplug)
| DEL_CHILD xc::Window
| GET_CHILD xc::Window
;
Xevent_Mail_Router
=
XEVENT_MAIL_ROUTER
{ plea_slot: Mailslot( Plea_Mail ),
reply_slot: Mailslot( Null_Or( xc::Momplug ))
};
# make a buffer-handler; ddeboer, fall 2004.
# Try to synchronize on inev, queueing value v; or
# Try to synchronize on outev v if queue is nonempty, where v is head of queue.
# bufferEvt: (X addr_msg -> Mailop(Void)) -> (X addr_msg -> Mailop(Void))
# Note: Should use wrap_queue where possible. # wrap_queue is from src/lib/x-kit/widget/old/basic/widget-base.pkg #
fun buffer_mailop out_statement: ( xc::Envelope(X) -> Mailop( Void ) )
=
in_mailop
where
in_slot = make_mailslot ();
fun loop ([], []) => loop ([ take_from_mailslot in_slot ], []);
loop ([], rear) => loop (reverse rear,[]);
loop (front as (msg_out ! r), rear)
=>
do_one_mailop [
#
out_statement msg_out
==>
{. loop (r, rear); },
take_from_mailslot' in_slot
==>
(\\ msg = loop (front, msg ! rear))
];
end;
fun in_mailop msg
=
put_in_mailslot' (in_slot, msg);
make_thread "router" {.
loop ([],[]);
};
end;
# end addition
# The router is constructed with a widget cable for a
# composite widget and an initial distribution
# list. The router listens for mail on the kidplug,
# resolves the envelope address to a momplug
# and forwards the message.
#
fun make_xevent_mail_router (xc::KIDPLUG { from_mouse', from_keyboard', from_other', ... }, my_out, out_list)
=
{ route_plea_slot = make_mailslot ();
route_reply_slot = make_mailslot ();
window_map = xc::make_map ();
find = xc::get window_map;
# findMsg = addrLookup winMap
fun find_msg envelope
=
xc::next_stop_for_envelope_via_hashtable window_map envelope;
set = xc::set window_map;
drop = xc::drop window_map;
fun m_mailop (xc::MOMPLUG { mouse_sink, ... } ) = mouse_sink;
fun k_mailop (xc::MOMPLUG { keyboard_sink, ... } ) = keyboard_sink;
fun ci_mailop (xc::MOMPLUG { other_sink, ... } ) = other_sink;
my_out = case my_out
#
xc::MOMPLUG { mouse_sink, keyboard_sink, other_sink, from_kid' }
=>
xc::MOMPLUG { mouse_sink => buffer_mailop mouse_sink,
keyboard_sink => buffer_mailop keyboard_sink,
other_sink => buffer_mailop other_sink,
from_kid'
};
esac;
fun do_plea (ADD_CHILD (w, xc::MOMPLUG { mouse_sink, keyboard_sink, other_sink, from_kid' } ))
=>
set
( w,
xc::MOMPLUG { mouse_sink => buffer_mailop mouse_sink,
keyboard_sink => buffer_mailop keyboard_sink,
other_sink => buffer_mailop other_sink,
from_kid'
}
);
do_plea (DEL_CHILD w) => drop w;
do_plea (GET_CHILD w) => put_in_mailslot (route_reply_slot, (THE (find w)) except _ = NULL);
end;
fun handle_mailop proj envelope
=
case (xc::route_envelope envelope)
#
xc::TO_SELF _
=>
do_one_mailop [
proj my_out envelope,
take_from_mailslot' route_plea_slot
==>
(\\ req = { do_plea req;
handle_mailop proj envelope;
}
)
];
xc::TO_CHILD msg'
=>
block_until_mailop_fires (proj (find_msg msg') msg');
esac;
mailop
=
cat_mailops
[
take_from_mailslot' route_plea_slot ==> do_plea,
from_mouse' ==> handle_mailop m_mailop,
from_keyboard' ==> handle_mailop k_mailop,
from_other' ==> handle_mailop ci_mailop
];
fun loop ()
=
{ block_until_mailop_fires mailop;
#
loop ();
};
fun init (item ! rest)
=>
{ set item;
#
init rest;
};
init []
=>
();
end;
init out_list;
xlogger::make_thread "Router" loop;
XEVENT_MAIL_ROUTER
{ plea_slot => route_plea_slot,
reply_slot => route_reply_slot
};
};
fun add_child (XEVENT_MAIL_ROUTER { plea_slot, ... } ) arg = put_in_mailslot (plea_slot, ADD_CHILD arg);
fun del_child (XEVENT_MAIL_ROUTER { plea_slot, ... } ) arg = put_in_mailslot (plea_slot, DEL_CHILD arg);
fun get_momplug (XEVENT_MAIL_ROUTER { plea_slot, reply_slot } ) arg
=
{ put_in_mailslot (plea_slot, GET_CHILD arg);
#
case (take_from_mailslot reply_slot)
#
NULL => raise exception NOT_FOUND;
THE e => e;
esac;
};
# Simple router for a composite widget
# with a single child:
#
fun route_pair (xc::KIDPLUG { from_mouse', from_keyboard', from_other', ... }, parent_out, child_out)
=
{
fun m_mailop (xc::MOMPLUG { mouse_sink, ... } ) = mouse_sink; # mouse_msg addr_msg -> Mailop(Void)
fun k_mailop (xc::MOMPLUG { keyboard_sink, ... } ) = keyboard_sink;
fun ci_mailop (xc::MOMPLUG { other_sink, ... } ) = other_sink;
child_out
=
case child_out
#
xc::MOMPLUG { mouse_sink, keyboard_sink, other_sink, from_kid' }
=>
xc::MOMPLUG
{ mouse_sink => buffer_mailop mouse_sink,
keyboard_sink => buffer_mailop keyboard_sink,
other_sink => buffer_mailop other_sink,
from_kid'
};
esac;
fun handle_mailop proj envelope
=
case (xc::route_envelope envelope)
#
xc::TO_SELF _ => block_until_mailop_fires (proj parent_out envelope );
xc::TO_CHILD envelope' => block_until_mailop_fires (proj child_out envelope');
esac;
fun loop ()
=
loop (block_until_mailop_fires (cat_mailops
[ from_mouse' ==> handle_mailop m_mailop,
from_keyboard' ==> handle_mailop k_mailop,
from_other' ==> handle_mailop ci_mailop
]
) );
xlogger::make_thread "Router2" loop;
();
};
}; # package xevent_mail_router
end;