BEGIN {
local $@;
eval {
Hash::Util->import('hv_store'); 1
} or do {
*hv_store = sub (\%$$) {
$_[0]{$_[1]} = $_[2];
weaken $_[0]{$_[1]} if ref $_[2]
};
warn "XUL::Gui> Hash::Util::hv_store not found, memory usage will be higher\n"
}
}
our $VERSION = '0.63';
our $THREADS = $INC{'threads.pm'};
our $TESTING;
our $DEBUG = 0;
our $MOZILLA = 1;
our $AUTOBUFFER = 1;
our $EXTENDED_OBJECTS = 1;
our $TIED_WIDGETS = 0;
our $FILL_GENID_OBJECTS = 1;
$Carp::Internal{"XUL::Gui$_"}++ for '', '::Object', '::Server';
sub import {
splice @_ => 1, 1, ':all'
if @_ == 2 and $_[1] =~ /^(\*|all|)$/;
goto &{ Exporter->can('import') }
if @_ == 1
or 1 < (@_ = grep {not
/^(?: ([\w:!]*) -> \*? ([\w:!]*)
| ([\w:!]+::!*)
)$/x && XUL::Gui->oo( $3 or $2 or $1 )
} @_)
}
sub FLEX {flex => 1, @_}
sub FILL {qw/-flex 1 -align stretch/, @_}
sub FIT {sizeToContent => 1, @_}
sub SCROLL {style => 'overflow: auto', @_}
sub MIDDLE {qw/-align center -pack center/, @_}
sub BLUR {qw/-onfocus this.blur()/, @_}
our @Xul = map {$_, (ucfirst lc) x /.[A-Z]/} qw {
Action ArrowScrollBox Assign BBox Binding Bindings Box Broadcaster
BroadcasterSet Browser Button Caption CheckBox ColorPicker Column
Columns Command CommandSet Conditions Content DatePicker Deck
Description Dialog DialogHeader DropMarker Editor Grid Grippy GroupBox
HBox IFrame Image Key KeySet Label ListBox ListCell ListCol ListCols
ListHead ListHeader ListItem Member Menu MenuBar MenuItem MenuList
MenuPopup MenuSeparator Notification NotificationBox Observes Overlay
Page Panel Param PopupSet PrefPane PrefWindow Preference Preferences
ProgressMeter Query QuerySet Radio RadioGroup Resizer RichListBox
RichListItem Row Rows Rule Scale Script ScrollBar ScrollBox ScrollCorner
Separator Spacer SpinButtons Splitter Stack StatusBar StatusBarPanel
StringBundle StringBundleSet Tab TabBox TabPanel TabPanels Tabs Template
TextBox TextNode TimePicker TitleBar ToolBar ToolBarButton ToolBarGrippy
ToolBarItem ToolBarPalette ToolBarSeparator ToolBarSet ToolBarSpacer
ToolBarSpring ToolBox ToolTip Tree TreeCell TreeChildren TreeCol
TreeCols TreeItem TreeRow TreeSeparator Triple VBox Where Window Wizard
WizardPage
};
our %HTML = map {("html_$_" => "html:$_", uc $_ => "html:$_")} qw {
a abbr acronym address applet area audio b base basefont bdo bgsound big
blink blockquote body br button canvas caption center cite code col
colgroup comment dd del dfn dir div dl dt em embed fieldset font form
frame frameset h1 h2 h3 h4 h5 h6 head hr html i iframe ilayer img input
ins isindex kbd label layer legend li link listing map marquee menu meta
multicol nobr noembed noframes nolayer noscript object ol optgroup
option p param plaintext pre q rb rbc rp rt rtc ruby s samp script
select small source spacer span strike strong style sub sup table tbody
td textarea tfoot th thead title tr tt u ul var video wbr xml xmp
};
our %EXPORT_TAGS = (
util => [qw/zip mapn apply trace/],
base => [qw/%ID ID display quit alert widget/],
widgets => [qw/filepicker ComboBox prompt/],
tools => [qw/gui interval timeout toggle function serve XUL/],
pragma => [qw/buffered now cached noevents delay doevents flush/],
xul => [@Xul],
html => [keys %HTML],
const => [qw/FLEX FIT FILL SCROLL MIDDLE BLUR/],
image => [qw/bitmap bitmap2src/],
internal => [qw/tag object genid realid/],
);
our @EXPORT_OK = map @$_ => values %EXPORT_TAGS;
our @EXPORT = map @{ $EXPORT_TAGS{$_} } =>
qw/util base tools pragma xul html const image/;
@EXPORT_TAGS{qw/default all/} = (\@EXPORT, \@EXPORT_OK);
our %defaults = (
onclose => sub {quit(); 0},
resizeTo => sub {gui("window.resizeTo($_[1],$_[2]);")},
],
textbox => [ value => sub :lvalue {tie my $ret, 'XUL::Gui::Scalar', shift, '_value'; $ret},
_value => sub :lvalue {tie my $ret, 'XUL::Gui::Scalar', shift, 'value'; $ret}
],
);
our $server = XUL::Gui::Server->new;
our (%ID, %dialogs);
my ($preprocess, $toJS, $toXML);
{*ID = my $id = {};
sub realid :lvalue {
@_ ? $$id{$_[0]} : (my $id = $id)
}
}
{my $id; sub genid () {'xul_' . ++$id}}
sub isa_object {
no warnings;
blessed(@_ ? $_[0] : $_) eq 'XUL::Gui::Object'
}
my $weaken = sub {weaken $_[0] if ref $_[0] and not isweak $_[0]};
my $weak_set = sub {
my ($obj, $key) = @_;
my $type = reftype $obj or return warn "weak_set @_";
my $strong = defined $key
? $type eq 'HASH'
? do {
if ($TIED_WIDGETS and my $tied = tied %$obj) {
$obj = $tied->hash
}
\$$obj{$key}
}
: $type eq 'ARRAY'
? \$$obj[$key]
: return warn "weak_set @_"
: $type eq 'SCALAR'
? $obj
: return warn "weak_set @_";
$$strong = $_[2] if @_ > 2;
weaken $$strong if ref $$strong
and not isweak $$strong;
return
};
sub mapn (&$@);
sub CLONE_SKIP {1}
sub parse {
my (@C, %A, %M);
while (@_) {
my $x = shift;
if (isa_object $x) {push @C, $x; next}
grep {not defined and $_ = '???'} $x, $_[0]
and croak "parse failure: [ $x => $_[0] ] @_[1..$#_],";
$x =~ s/^-//;
if ($x =~ /^_?on/ or ref $_[0] ne 'CODE') {
$x eq 'style' and $A{$x} .= (shift).';'
or $A{$x} = shift}
else {$M{$x} = shift}
}
C => \@C, A => \%A, M => \%M
}
{my %loaded;
sub oo {
no strict 'refs';
my $target = $_[1] || 'XUL::Gui::OO';
my $force = $target =~ s/!//g;
my $methods = not $target =~ s/::$//;
$target ||= 'main';
$force ||= !$methods;
my $pkg = "$target\::";
if (%$pkg and not $force)
{return $loaded{$pkg} || croak "package '$pkg' not empty"}
mapn {
my $sub = \&{$_[1]};
*{$pkg.$_} = $methods ? sub {shift; goto &$sub} : $sub;
} 2 => %{{
(map {lc, $_} grep {not /_/} keys %HTML, @{$EXPORT_TAGS{const}}),
$MOZILLA ? (map {lcfirst, $_} @Xul) : (),
(map {$_, $_} grep {not /\W|^self$/} @EXPORT_OK),
(map {lc, $_, lcfirst, $_} @{$EXPORT_TAGS{widgets}})
}};
*{$pkg.'id'} = $methods ? sub :lvalue {$XUL::Gui::ID{$_[1]}}
: \&ID;
bless $loaded{$pkg} = {} => substr $pkg, 0, -2
}}
sub display {
for (my $i = 0; $i < @_; $i++) {
next if isa_object $_[$i];
ref $_[$i] eq 'CODE'
? delay ((splice @_, $i--, 1), $$server{root})
: $i++
}
if (@_ == 1 and not isa_object $_[0]) {
@_ = PRE(shift)
}
my $args = { &parse };
if ($$args{A}{xml}) {
return join "\n" =>
map $_->$toXML( 0, $$args{A}{xml} )
=> @{$$args{C}}
}
$server->start( $args )
}
sub quit {
gui('setTimeout("quit()", 5); 0');
$$server{run} = 0;
}
sub serve {$server->serve(@_)}
bless my $object = {
WIDGET => 0,
NOPROXY => 1,
ISA => [],
ID => '[object]',
M => {
attr => sub :lvalue {$_[0]{A}{ $_[1] }},
child => sub :lvalue {$_[0]{C}[ $_[1] ]},
can => sub :lvalue {$_[0]{M}{ $_[1] }},
attributes => sub {%{ $_[0]{A} }},
children => sub {@{ $_[0]{C} }},
methods => sub {%{ $_[0]{M} }},
has => sub {
my $self = shift;
my ($A, $M) = @$self{qw/A M/};
my @found = map {
my $required = index($_, '!' ) == -1 ? 0 : s/!//g;
my ($key, $as) = index($_, '->') == -1 ? ($_, $_) : /(.+)->(.+)/;
exists $$A{ $key }
? ($as => $$A{ $key }) :
exists $$M{ $key }
? ($as => $$M{ $key }) :
$required ? do {
local $Carp::CarpLevel = 1;
croak "widget requires attribute/method '$key'";
} : ()
} split /\s+/ => @_ > 1 ? "@_" : $_[0];
wantarray ? @found
: @found == 2 ? $found[1] : @found / 2
},
id => sub {$_[0]{ID}},
parent => sub {$_[0]{P }},
widget => sub {$_[0]{W }},
super => sub {$_[0]{ISA}[$_[1] or 0]},
proto => sub :lvalue {$_[0]{ISA}},
extends => sub {
my $self = shift;
my $target = (\%ID == realid) ? $self : \%ID;
my $base = $_[0]{W} or croak 'extends takes a widget';
if ($TIED_WIDGETS) {
XUL::Gui::Hash->new($target, $base)
} else {
$$target{$_} = $$base{$_} for grep {/[a-z]/} keys %$base;
}
unshift @{$$self{ISA}}, $base;
@_
},
}
} => 'XUL::Gui::Object';
my $setup_object = sub {
my $self = shift;
for (@{$$self{C}}) {
$_->$weak_set(P => $self)
}
};
my $install_widget = sub {
my ($self, $widget) = @_;
my $w = \$$self{W};
if ($$w) {
if ($$w != $widget and not $$$w{W}) {
$$$w{W} = $widget;
}
} else {
$$w = $widget;
}
};
sub object {
my $tag = lc (shift or '');
if (my $defaults = $defaults{$tag}) {
unshift @_, @$defaults
}
bless my $self = {
ISA => [$object],
$tag ? (
TAG => $tag,
DIRTY => $tag,
) : (),
&parse
} => 'XUL::Gui::Object';
if (my $id = $$self{A}{id}) {
($$self{ID} = $id)
=~ /\W/ and do {
$$self{ID} = 'invalid';
croak "id '$id' contains non-word character"
}
} else {
$$self{ID} = $$self{A}{id} = genid
}
if ($tag) {
$self->$setup_object;
$ID{$$self{ID}} = $self;
}
$self
}
sub tag {
my @args = @_;
sub {
object @args,
(@_ == 1 and not isa_object $_[0])
? 'TEXT' : (),
@_
}
}
{no strict 'refs';
*$_ = tag $_ for @Xul;
*$_ = tag $HTML{$_} for keys %HTML;
}
sub ID (*):lvalue {$ID{$_[0]}}
sub widget (&%) {
my ($code, %methods, $sub) = @_;
my $caller = caller;
$sub = sub {
my %data;
my $id = realid;
my $inner = \%ID != $id;
my $self = $TIED_WIDGETS
? XUL::Gui::Hash->new({parse @_})
: {parse @_};
my $wid = $inner ? genid : $$self{A}{id} || genid;
my $_self = $TIED_WIDGETS ? tied(%$self)->hash : $self;
@$_self{qw/ID WIDGET CALLER NOPROXY/} = ($wid, $sub, $caller, 1);
for (keys %methods) {
my ($k, $v) = ($_, $methods{$_});
if (ref $v ne 'CODE') {
$data{$k} = ref $v ? dclone $v : $v;
$v = sub :lvalue {$data{$k}};
}
$$_self{M}{$k} ||= $v
}
hv_store %$_self, $_ => $data{$_} for keys %data;
$$id{$wid} = bless $self => 'XUL::Gui::Object';
weaken $$id{$wid} unless $THREADS;
$ID{$$_self{A}{id} or genid} = $self if $inner;
no strict 'refs';
my $callid = "$caller\::ID";
my $setcid = %$callid && \%$callid == \%ID;
local %ID;
local *$callid = \%ID if $setcid;
local ($_, *_) = ($self) x 2;
local $_{W} = $self;
$$_self{ISA} = [ $object ];
my $objects = [ &$code ];
my @named_objects;
mapn {
isa_object my $obj = $_[1]
or return warn "not an object: $_";
if ($TIED_WIDGETS) {
if (my $tied = tied %{$_[1]}) {
$tied->unshift($self, $$_self{A});
} else {
XUL::Gui::Hash->new($_[1], $self, $$_self{A});
}
}
$$id{ my $gid = genid } = $obj;
if (exists $$obj{WIDGET}) {
weaken $$id{$gid}
}
if ($FILL_GENID_OBJECTS
or $$obj{A}{id} && $$obj{A}{id} !~ /^xul_\d+$/) {
isweak $obj or weaken $obj;
hv_store %$_self, $_ => $obj;
if (exists $$obj{W}) {
$$obj{EXTENDED_FROM} = $$obj{W}
}
$$obj{NAME} = $$obj{A}{id};
push @named_objects, $obj;
}
$$obj{W} = $self;
$$obj{ID} = $$obj{A}{id} = $gid;
} 2 => %ID;
unless ($TIED_WIDGETS) {
my @keys_self = grep /[a-z]/ => keys %$_self;
my @keys_A = keys %{$$_self{A}};
for my $obj (@named_objects) {
exists $$obj{$_} or hv_store %$obj, $_, $$_self{$_} for @keys_self;
exists $$obj{$_} or hv_store %$obj, $_, $$_self{A}{$_} for @keys_A;
}
}
@$objects[0 .. $#$objects]
}
}
sub alert {
gui( "alert('".&escape."')" );
wantarray ? @_ : pop
}
sub prompt {
gui( "prompt('".&escape."')" )
}
sub filepicker {
$MOZILLA or croak "filepicker not available (XUL disabled)";
my $type = shift || 'open';
my $mode = {
open => wantarray
? [modeOpenMultiple => 'Select Files' ]
: [modeOpen => 'Select a File' ],
save => [modeSave => 'Save as' ],
dir => [modeGetFolder => 'Select a Folder'],
}->{$type};
my $res = gui(qq ~
(function () {
xul_gui.deadman_pause();
var nsIFilePicker = Components.interfaces.nsIFilePicker;
var fp = Components.classes["\@mozilla.org/filepicker;1"]
.createInstance(nsIFilePicker);
fp.init(window, "$$mode[1]", nsIFilePicker.$$mode[0]);
@{[mapn {qq{
fp.appendFilter("$_[0]", "$_[1]");
}} 2 => @_ ]}
var res = fp.show();
xul_gui.deadman_resume();
if (res == nsIFilePicker.returnCancel) return;~ .
($type eq 'open' && wantarray ? q {
var files = fp.files;
var paths = [];
while (files.hasMoreElements()) {
var arg = files.getNext().QueryInterface(
Components.interfaces.nsILocalFile ).path;
paths.push(arg);
}
return paths.join("\n")
} : q {return fp.file.path;}
) . '})()');
defined $res
? wantarray
? split /\n/ => $res
: $res
: ()
}
sub trace {
my $caller = caller;
carp 'trace: ', join ', ' => map {
(isa_object) ? lookup($_, $caller) : $_
} @_;
wantarray ? @_ : pop
}
{my %cache;
my $last_caller;
sub lookup {
no strict 'refs';
my $self = shift;
my $proto = $$self{WIDGET} || $$self{W}{WIDGET}
or return $$self{ID} || $self;
if (@_) {$last_caller = $_[0]}
else {@_ = $last_caller ||= caller}
my $name = $cache{$proto};
unless ($name) {
our %space;
local *space = \%{"$_[0]\::"};
local $@;
keys %space;
while (my ($key, $glob) = each %space) {
no warnings;
if (eval {*$glob{CODE} == $proto}) {
$cache{$proto} = $name = $key;
last
}
}
}
$name and return
$name . ($$self{WIDGET} ? '{'
: '{'.($$self{W}{A}{id} or $$self{W}{ID}).'}->{')
. ($$self{NAME} or $$self{ID}).'}';
$$self{ID} or $self
}}
sub function ($) {
my $js = shift;
bless [sub {
my $self = shift;
my $func = 'ID.' . genid;
delay( sub {
$js =~ s[\$?W{\s*(\w+)\s*}] [ID.$$self{W}{$1}{ID}]g;
gui(
qq{SET;$func = function (event) {
try {return (function(){ $js }).call( ID.$$self{ID} )}
catch (e) {alert( e.name + "\\n" + e.message )}
}})
});
"$func(event)"
}] => 'XUL::Gui::Function'
}
sub interval (&$@) {
my ($code, $time) = splice @_, 0, 2;
my $list = \@_;
my $id = genid;
realid($id)= sub {$code->(@$list)};
gui( qq{SET;ID.$id = setInterval( "pevt('XUL::Gui::realid(q|$id|)->()')", $time)} );
sub {gui(qq{SET;clearInterval(ID.$id)})}
}
sub timeout (&$@) {
my ($code, $time) = splice @_, 0, 2;
my $list = \@_;
my $id = genid;
realid($id) = sub {$code->(@$list)};
gui( qq{SET;ID.$id = setTimeout( "pevt('XUL::Gui::realid(q|$id|)->()')", $time)} );
sub {gui(qq{SET;cancelTimeout(ID.$id)})}
}
sub escape {
my $str = $_[0];
return $str if $str !~ /[\\\n\r']|[^[:ascii:]]/;
$str =~ s/\\/\\\\/g;
$str =~ s/\n/\\n/g;
$str =~ s/\r/\\r/g;
$str =~ s/'/\\'/g;
$str =~ /[^[:ascii:]]/
? encode ascii => $str
=> sub {sprintf '\u%04X', $_[0]}
: $str
}
{my %xul; @xul{map lc, @Xul} = @Xul;
sub XUL {
$MOZILLA or croak "XUL disabled";
local $@;
for ("@_") {
s {<(\w+)(.+?)} "XUL::Gui::$xul{lc $1}($2"g;
s {/>} '),'g;
s {</\w+>} '),'g;
s {>} ''g;
s {(\w+)\s*=\s*(\S+)} "'$1'=>$2"g;
s <([^\\](}|"|'))\s+> "$1,"g;
return eval 'package '.caller().";$_"
or carp "content skipped due to parse failure: $@\n\n$_"
}
}}
{my ($buffered, @buffer, @setbuf, $cached, %cache, $now);
sub gui :lvalue {
my $msg = "@_\n";
my $type = '';
if (substr($msg, 1, 2) eq 'ET') {
my $first = substr $msg, 0, 1;
if ($first eq 'S' or $first eq 'G') {
if ((my $check = substr $msg, 3, 1) eq '(') {
$type = $first . 'ET';
}
elsif ($check eq ';') {
$type = $first . 'ET';
$msg = substr $msg, 4;
}
}
}
unless ($now) {
push @buffer, $msg and return if $buffered;
push @setbuf, $msg and return if $AUTOBUFFER
and $type eq 'SET'
and not $cached;
return $cache{$msg} if exists $cache{$msg};
}
if (@setbuf) {
$msg = join '' => @setbuf, $msg;
@setbuf = ();
}
defined wantarray or $msg .= ';true'
unless $cached;
$server->write('text/plain', $msg);
my $res = $server->read_until('/res');
if (defined wantarray or $cached) {
($res = $$res{CONTENT}) =~ /^(...) (.*)/s
or croak "invalid response: $res";
$res = $1 eq 'OBJ'
? ($ID{$2} || object undef, id=>$2)
: $1 eq 'UND'
? undef
: $2;
if ($cached) {
if ($type eq 'SET') {
$type = 'GET';
$msg =~ s/.[^,]+(?=\).*?$)//;
substr $msg, 0, 3, 'GET';
}
$cache{$msg} = $res if $type eq 'GET'
}
}
$res
}
sub flush {
if (@setbuf) {
$server->write('text/plain', join '' => @setbuf);
@setbuf = ();
$server->read_until('/res');
}
}
sub buffered (&@) {
$buffered++;
&{+shift};
unless (--$buffered) {
gui "SET;@buffer";
@buffer = ();
}
return
}
sub cached (&) {
$cached++;
my $ret = shift->();
%cache = () unless --$cached;
$ret
}
sub now (&) {
my ($want, @ret) = wantarray;
$now++;
$want ? @ret = shift->()
: $ret[0] = shift->();
$now--;
$want ? @ret : $ret[0]
}
}
sub delay (&@) {
my $code = shift;
my $args = \@_;
push @{$$server{queue}}, sub {@$args and local *_ = \$$args[0]; $code->(@$args)};
return
}
sub noevents (&@) {
gui 'xul_gui.cacheEvents(false);';
my @ret = &{+shift};
gui 'xul_gui.cacheEvents(true);';
@ret
}
sub doevents () {
$server->{dispatch}{'/ping'}();
$server->read_until('/ping');
return
}
sub mapn (&$@) {
my ($sub, $n, @ret) = splice @_, 0, 2;
croak '$_[1] must be >= 1' unless $n >= 1;
return map $sub->($_) => @_ if $n == 1;
my $want = defined wantarray;
while (@_) {
local *_ = \$_[0];
if ($want) {push @ret =>
$sub->(splice @_, 0, $n)}
else {$sub->(splice @_, 0, $n)}
}
@ret
}
sub zip {
map {my $i = $_;
map $$_[$i] => @_
} 0 .. max map $#$_ => @_
}
sub apply (&@) {
my ($sub, @ret) = @_;
$sub->() for @ret;
wantarray ? @ret : pop @ret
}
sub toggle {
no warnings;
my @opt = (splice(@_, 1), 0, 1);
$_[0] = $opt[ $_[0] eq $opt[0] or $_[0] ne $opt[1] ]
}
sub bitmap {
my ($width, $height) = splice @_, 0, 2;
my @pad = map {(0) x ($_ and 4 - $_)} ($width*3) % 4;
my $size = $height * ($width * 3 + @pad);
pack 'n V n n (N)2 (V)2 n n N V (N)4 (a*)*' =>
0x42_4D,
(54 + $size),
0x00_00,
0x00_00,
0x36_00_00_00,
0x28_00_00_00,
$width,
$height,
0x01_00,
0x18_00,
0x00_00_00_00,
$size,
0x13_0B_00_00,
0x13_0B_00_00,
0x00_00_00_00,
0x00_00_00_00,
reverse
@_ > 1
? map {pack 'C*' => splice(@_, 0, $width*3), @pad} 1 .. $height
: map {ref $_
? pack 'C*' => @$_, @pad
: pack 'a* C*' => $_, @pad
} @{$_[0]}
}
sub bitmap2src {'data:image/bitmap;base64,' . encode_base64 &bitmap}
package
XUL::Gui::Object;
my $can; $can = sub {
my ($self, $method) = @_;
$server->status(' ' . XUL::Gui::lookup($self) . "->can( $method ) ?")
if ($DEBUG > 4
or $DEBUG > 3 and $method !~ /^~/)
and $self != $object;
$$self{M}{$method}
or do {
return if $self == $object;
if ($$self{WIDGET}) {
if (exists $$self{$method}) {
return ref $$self{$method} eq 'CODE'
? $$self{$method}
: sub:lvalue {$$self{$method}}
}
if (exists $$self{A}{$method}) {
return sub:lvalue {$$self{A}{$method}}
}
} else {
return unless $EXTENDED_OBJECTS
}
for (@{$$self{ISA}})
{return $_->$can($method) || next}
}
};
sub can :lvalue;
sub attr :lvalue;
sub child :lvalue;
use overload fallback => 1, '@{}' => sub { tie my @ret => 'XUL::Gui::Array', shift;
\@ret
};
{
my $debug_perl_method_call = sub {
my ($self, $name) = splice @_, 0, 3;
my $caller = caller 1;
$server->status('perl: '. XUL::Gui::lookup($self, $caller) . "->$name(" .
(join ', ' => map {(XUL::Gui::isa_object)
? XUL::Gui::lookup($_, $caller) : "'$_'"} @_). ")")
};
my $debug_js_method_call = sub {
my ($self, $name) = splice @_, 0, 2;
$server->status( "gui: ID.$$self{ID}.$name(" .
(join ', ' => map {(XUL::Gui::isa_object)
? "ID.$$_{ID}" : "'$_'"} @_). ")" )
};
sub AUTOLOAD :lvalue {
my $self = $_[0];
my $name = substr our $AUTOLOAD, 1 + rindex $AUTOLOAD, ':'
or Carp::croak "invalid autoload: $AUTOLOAD";
if (my $method = $self->$can($name)) {
$debug_perl_method_call->($self, $name, @_) if $DEBUG;
goto &$method
}
if ($$self{NOPROXY} or not shift->{ID}) {
Carp::croak "no method '$name' on ". XUL::Gui::lookup($self, scalar caller)
}
my $void = not defined wantarray;
if (substr($name, -1) eq '_' && chop $name or @_ or $void) {
$debug_js_method_call->($self, $name, @_) if $DEBUG > 1;
{($$self{uc $name} or next)
-> (local $_ = $self)
=> return}
my @pre;
my $arg = join ',' => map {not defined and 'null' or
XUL::Gui::isa_object and do {
push @pre, $_->$toJS(undef, $self) if $$_{DIRTY};
"ID.$$_{ID}"
} or "'" . XUL::Gui::escape($_) . "'"
} @_;
local $" = '';
return XUL::Gui::gui 'SET;' x $void, "@pre; ID.$$self{ID}.$name($arg);"
}
$server->status("proxy: ID.$$self{ID}.$name") if $DEBUG > 2;
tie my $ret, 'XUL::Gui::Scalar', $self, $name;
$ret
}
}
{my @queue;
my $rid = XUL::Gui::realid;
sub DESTROY {
return unless @_
and Scalar::Util::reftype $_[0] eq 'HASH'
and $_[0]{ID};
delete $rid->{$_[0]{ID}};
push @queue, "delete ID.$_[0]{ID};";
if (@queue == 1) {
XUL::Gui::delay {
local $" = '';
XUL::Gui::gui "SET;@queue";
@queue = ();
for (keys %$rid) {
unless (defined $$rid{$_}) {
delete $$rid{$_}
}
}
}
}
untie %{$_[0]} if tied %{$_[0]};
}}
sub CLONE_SKIP {1}
{my $deparser;
$toXML = sub {
my $self = shift;
my $tab = shift || 0;
my (@xml, @perl);
my $text = '';
my $deparse = (shift||'') eq 'perl' ? do {
$deparser ||= do {
my $d = B::Deparse->new('-sC');
$d->ambient_pragmas(qw/strict all warnings all/);
$d
}} : 0;
$self->$preprocess unless $deparse;
for ($$self{CODE}) {
if (defined) {
my $tabs = "\t" x $tab;
s/^/$tabs/mg;
return substr $_, $tab;
}
}
my $tag = $$self{TAG};
push @xml, "<$tag ";
for (keys %{$$self{A}}) {
if ($deparse and ref (my $code = $$self{A}{$_}) eq 'CODE') {
push @xml, qq{$_="alert('handled by perl')" };
push @perl, bless {CODE => "<!-- \n$_ => sub "
. $deparse->coderef2text($code)."\n-->\n"};
next
}
my $val = XUL::Gui::escape $$self{A}{$_};
if ($_ eq 'TEXT') {
$val =~ s/\\n/\n/g;
$text = $val;
next
}
push @xml, qq{$_="$val" };
}
if (@{$$self{C}} or $text or @perl) {
push @xml, ">$text\n";
push @xml, "\t" x ($tab+1), $_->$toXML($tab+1, $deparse ? 'perl' : ())
for @perl, @{$$self{C}};
push @xml, "\t" x $tab, "</$tag>\n";
} else {
if ($MOZILLA) {
push @xml, "/>\n"
} else {
push @xml, "></$tag>\n"
}
}
join '' => @xml
}}
{my $id = XUL::Gui::realid;
$preprocess = sub {
my $self = $_[0];
die 'processed again' unless $$self{DIRTY};
$$self{DIRTY} = 0;
my $attr = $$self{A};
for my $key (keys %$attr) {
my $val = \$$attr{$key};
if (ref $$val eq 'XUL::Gui::Function') {
$$val = $$$val[0]( $self )
}
my $ref = ref $$val;
if ($ref eq 'SCALAR' or $ref eq 'REF') {
my $bound = $$val;
$$val = $$bound;
tie $$bound => 'XUL::Gui::Scalar', $self, $key;
}
if (substr($key, 0, 1) eq '_') {
substr $key, 0, 1, '';
}
next unless index($key, 'on') == 0 and ref $$val eq 'CODE';
$$self{uc $key} = $$val;
$$val = "EVT(event,'$$self{ID}');";
}
}}
$toJS = sub {
my ($root, $final, $parent) = @_;
my @queue = $root;
my (@pre, @post);
my $realid = XUL::Gui::realid;
if ($parent) {
$root->$weak_set( P => $parent );
push @{$$parent{C}}, $root;
if (my $widget = $$parent{W}) {
$root->$install_widget($widget)
}
}
while (my $node = shift @queue) {
$node->$preprocess;
if (my $code = $$node{CODE}) {
push @pre, $code;
next
}
my $id = "ID.$$node{ID}";
my ($attribute, $children, $tag) = @$node{qw/A C TAG/};
my $widget = $$node{W};
for my $child (@$children) {
push @queue, $child;
push @post, qq{$id.appendChild(ID.$$child{ID});} if $$child{TAG};
$child->$weak_set( P => $node );
$child->$install_widget($widget) if $widget;
}
$weaken->($$realid{$$node{ID}}) unless $THREADS;
push @pre, qq{$id=document.createElement} .
($MOZILLA
? index ($tag, ':') == -1
? qq{('$tag');}
: $tag =~ /^html:(.+)/
? qq{('$1');}
: Carp::croak "$tag is not an HTML tag");
keys %$attribute;
while (my ($key, $val) = each %$attribute) {
my $clean = XUL::Gui::escape $val;
if ($key eq 'TEXT') {
push @pre, qq{$id.appendChild(document.createTextNode('$clean'));}
} elsif (substr($key, 0, 1) eq '_') {
if (substr($key, 1, 2) eq 'on') {
push @post, qq{$id.} . (substr $key, 1) . qq{=function(event){if(!event){event=window.event}$val};}
} else {
push @post, qq{$id\['}. (substr $key, 1). qq{']='$clean';}
}
} else {
push @pre, qq{$id.setAttribute('\L$key\E','$clean');}
}
}
}
push @post, "$final.appendChild(ID.$$root{ID});" if $final;
local $" = $DEBUG ? "\n" : '';
"@pre@post"
};
my $remove_children = sub {
my $self = shift;
if (@_) {
my %remove = map {$_ => 1} @_;
@{$$self{C}} = grep {not $remove{$_}} @{$$self{C}};
} else {
@{$$self{C}} = ()
}
};
sub removeChildren {
my $self = shift;
@_ ? XUL::Gui::buffered {$self->removeChild_($_) for @_} @_
: XUL::Gui::gui "SET;ID.$$self{ID}.removeChildren();";
$self->$remove_children(@_);
$self
}
sub removeItems {
my $self = shift;
@_ ? XUL::Gui::buffered {$self->removeItem_($_) for @_} @_
: XUL::Gui::gui "SET;ID.$$self{ID}.removeItems();";
$self->$remove_children(@_ ? @_ : grep {$$_{TAG} =~ /item/i} @{ $$self{C} });
$self
}
sub appendChild {
my ($self, $child) = @_;
push @{ $$self{C} }, $child;
$self->appendChild_( $child );
}
sub removeChild {
my ($self, $child) = @_;
$self->removeChild_($child);
my $children = $$self{C};
for (0 .. $#$children) {
if ($$children[$_] == $child) {
return splice @$children, $_, 1
}
}
}
sub appendChildren {
my $self = shift;
XUL::Gui::buffered {$self->appendChild($_) for @_} @_;
$self
}
sub prependChild {
my ($self, $child, $count, $first) = @_;
if ($$self{TAG} eq 'tabs') {
$first = $self->getItemAtIndex( $count || 0 )
} else {
$first = $self->firstChild;
while ($count-- > 0) {
last unless $first;
$first = $first->nextSibling;
}
}
$first ? $self->insertBefore( $child, $first )
: $self->appendChild ( $child );
push @{$$self{C}}, $child;
$self
}
sub replaceChildren {
my ($self, @children) = @_;
XUL::Gui::buffered {
XUL::Gui::noevents {
$self->removeChildren
->appendChildren( @children )
}};
$self
}
sub appendItems {
my ($self, @items) = @_;
XUL::Gui::buffered {
(XUL::Gui::isa_object)
? $self->appendChild($_)
: $self->appendItem( ref eq 'ARRAY' ? @$_ : $_ )
for @items
};
$self
}
sub replaceItems {
my ($self, @items) = @_;
XUL::Gui::buffered {
XUL::Gui::noevents {
$self->removeItems
->appendItems( @items )
}};
$self
}
package
XUL::Gui::Scalar;
sub TIESCALAR {bless [ @_[1..$#_] ] => $_[0]}
sub DESTROY { }
sub CLONE_SKIP {1}
sub FETCH {
my ($self, $AL) = @{+shift};
return $$self{uc $AL} if $AL =~ /^on/;
XUL::Gui::gui $AL =~ /^_(.+)/
? "GET;ID.$$self{ID}\['$1'];"
: "GET(ID.$$self{ID}, '$AL');"
}
sub STORE {
my ($self, $AL, $new) = (@{+shift}, @_);
if ($AL =~ /^on/) {
if (ref $new eq 'XUL::Gui::Function') {
$new = $$new[0]($self);
} else {
not defined $new or ref $new eq 'CODE'
or croak "assignment to event handler must be CODE ref, 'function q{...}', or undef";
$new = $new ? do {$$self{uc $AL} = $new; "EVT(event, '$$self{ID}')"} : '';
}
}
$new = defined $new ? "'" . XUL::Gui::escape($new) . "'" : 'null';
XUL::Gui::gui $AL =~ /^_(.+)/
? "SET;ID.$$self{ID}\['$1'] = $new;"
: "SET(ID.$$self{ID}, '$AL', $new);"
}
{my ($fetch, $store) = (\&FETCH, \&STORE);
package
XUL::Gui::Array;
sub TIEARRAY {bless \pop}
sub FETCH {@_ = [${$_[0]}, '_'.$_[1]]; goto &$fetch}
sub FETCHSIZE {@_ = [${$_[0]}, '_length']; goto &$fetch}
sub STORE {@_ = ([${$_[0]}, '_'.$_[1]], $_[2]); goto &$store}
sub STORESIZE {@_ = ([${$_[0]}, '_length'], $_[1]); goto &$store}
BEGIN {*EXTEND = \&STORESIZE}
sub EXISTS {${$_[0] }->hasOwnProperty($_[1])}
sub POP {${$_[0] }->pop }
sub SHIFT {${$_[0] }->shift }
sub CLEAR {${$_[0] }->splice (0 )}
sub PUSH {${shift;}->push (@_)}
sub UNSHIFT {${shift;}->unshift(@_)}
sub SPLICE {@{${shift;}->splice (@_)}}
sub DELETE {XUL::Gui::gui "delete ID.$${$_[0]}{ID}\[$_[1]]"}
}
package
XUL::Gui::Server;
our ($req, $active, @cleanup);
sub new {bless {}}
sub status {print STDERR "XUL::Gui> @_\n" unless shift->{silent}; 1}
sub start {
my $self = shift;
$$self{args} = shift;
$$self{content} = $$self{args}{C};
$$self{content} = [XUL::Gui::META()] unless @{$$self{content}};
$weaken->($$self{args}{C});
$$self{caller} = caller 1;
$active = $self;
$$self{$_} = $$self{args}{A}{$_}
for qw(debug silent trusted launch skin chrome port delay mozilla default_browser serve_files);
defined $$self{$_} or $$self{$_} = 1
for qw(launch chrome skin);
$self->status("version $VERSION") if
local $DEBUG = $$self{debug} || $DEBUG;
push @cleanup, $self;
local $MOZILLA = defined $$self{mozilla} ? $$self{mozilla} : $MOZILLA
or $DEBUG && $self->status('XUL enhancements disabled. using HTML only mode');
$$self{silent}++ if $TESTING;
local $| = 1 if $DEBUG;
$$self{port} ||= int (10000 + rand 45000);
$$self{port}++ until
$$self{server} = IO::Socket::INET->new(
Proto => 'tcp',
PeerAddr => 'localhost',
LocalAddr => "localhost:$$self{port}",
Listen => 1,
);
$self->build_dispatch;
$$self{run} = 1;
$self->launch if $$self{launch} or $$self{trusted};
$$self{client} = $$self{server}->accept;
$$self{client}->autoflush(1);
$self->status('opening window');
local $@;
my $error = eval {$self->read_until('main loop:'); 1}
? 0 : $@ || 'something bad happened';
if ($$self{firefox}) {
kill HUP => -$$self{ffpid};
kill HUP => $$self{ffpid};
close $$self{firefox};
}
{($$self{dir} or last)->unlink_on_destroy(1)}
die $error if $error
and ref $error ne 'XUL::Gui server stopped';
$self->stop('display stopped');
$self->cleanup;
}
sub abort {die bless [] => 'XUL::Gui server stopped'}
sub read_until {
my ($self, $stop) = @_;
my $run = \$$self{run};
my $dispatch = $$self{dispatch};
while (local $req = $self->read) {
my $url = $$req{URL};
$self->status(($stop =~ /:/ ? '' : 'read until ')."$stop got $url")
if $DEBUG > 4 and $url ne '/ping';
return $req if $url eq $stop;
if (my $handler = $$dispatch{$url}) {
$handler->();
} elsif (my $prefix = $$self{serve_files}) {
$url = ($prefix =~ m{ [\\\/] $ }x ? $prefix : '.') . $url;
if (open my $file, '<', $url) {
$self->write('text/plain', do {local $/; <$file>})
} else {
$self->status("file: $url not found");
$self->write('text/plain', '')
}
}
$$run or abort;
}
}
sub assert {
return if openhandle pop;
my $name = ((caller 2)[3] =~ /([^:]+)$/ ? "$1 " : '') . shift;
croak "XUL::Gui> $name error: client not connected,"
}
sub read {
my ($self, $client) = ($_[0], $_[0]{client});
my ($length, %req);
local $/ = "\015\012";
local *_;
assert read=> $client;
my $header = <$client>;
$header and ($req{URL}) = $header =~ /^\s*\w+\s*(\S+)\s*HTTP/
or do {
$self->status(
$header
? "broken message received: $header"
: 'firefox seems to be closed'
);
abort
};
{chomp ($_ = <$client>);
$length ||= /^\s*content-length\D+(\d+)/i ? $1 : 0;
$_ and redo}
read $client => $req{CONTENT}, $length;
$self->status( "read: $req{URL} $req{CONTENT}" )
if $DEBUG > 3 and $req{URL} ne '/ping';
if ($$self{delay} and $req{URL} ne '/ping') {
Time::HiRes::usleep(1000*$$self{delay})
}
\%req
}
sub write {
my ($self, $type, $msg) = @_;
assert write => my $client = $$self{client};
XUL::Gui::flush if $msg eq 'NOOP';
if ($DEBUG > 3) {
(my $msg = "$type $msg") =~ s/[\x80-\xFF]+/ ... /g;
$self->status(
$DEBUG > 4
? "write $msg"
: (substr "write $msg", 0, 115)
. (' ...' x (length $msg > 115))
)
}
print $client join "\015\012" =>
'HTTP/1.1 200 OK',
'Expires: -1',
'Keep-Alive: 300',
'Content-type: ' . $type,
'Content-length: ' . length $msg,
'',
$msg
}
sub stop {
my $self = shift;
local $SIG{HUP} = 'IGNORE';
kill HUP => -$$;
$self->status(@_);
}
sub serve {
my ($self, $path, $type, $data) = @_;
$path =~ m[^/(?:client.js|event|ping|exit|perl)?$]
and croak "reserved path: $path";
$self->status("serve $path $type") if $DEBUG;
$$self{dispatch}{$path} = sub {
$self->write($type, $data);
};
$path
}
sub build_dispatch {
my $self = shift;
my $root;
$$self{dispatch} = {
exists $$self{dispatch} ? %{$$self{dispatch}} : (),
'/' => sub {
my ($meta, $html);
if ($MOZILLA) {
$meta = qq{<?xml version="1.0" encoding="UTF-8"?>\n} .
$root = $$self{content}[0]{TAG} eq 'window'
? shift @{$$self{content}}
: XUL::Gui::Window()
} else {
$html = $$self{content}[0]{TAG} eq 'html:html'
? shift @{$$self{content}}
: XUL::Gui::HTML();
for (@{$$html{C}}) {
if ($$_{TAG} eq 'html:body') {
$root = $_;
last;
}
}
unless ($root) {
for (0 .. $
if ($$self{content}[$_]{TAG} eq 'html:body') {
$root = splice @{$$self{content}}, $_, 1;
last;
}
}
push @{$$html{C}}, $root ||= XUL::Gui::BODY();
}
}
for (qw/onunload onclose/) {
$$self{$_} ||= $$root{A}{$_};
$$root{A}{$_} = 'return xul_gui.shutdown();';
}
unshift @{$$self{content}}, @{ $$root{C} };
$$self{root} = $root;
$self->write(
$MOZILLA ? 'application/vnd.mozilla.xul+xml'
: 'text/html',
$meta . (
$MOZILLA ? $root->$toXML
: $html->$toXML
)
)
},
'/client.js' => sub {
$self->write( 'text/javascript',
join ";\n" => $self->client_js,
qq {xul_gui.root = ID.$$root{ID} = document.getElementById('$$root{ID}')},
(map {$_->$toJS("ID.$$root{ID}")} @{$$self{content}}),
'xul_gui.start()'
);
push @{$$root{C}}, splice @{$$self{content}};
},
'/event' => sub {
$self->status("event $$req{CONTENT}") if $DEBUG > 1;
my ($code, $id, $evt, $obj) = split ' ', $$req{CONTENT};
for ($ID{$id}) {
my $handler = $$_{"ON\U$evt"};
if (ref $handler eq 'CODE') {
$handler->( $_, XUL::Gui::object(undef, id=>$obj) );
} else {$self->status("no event handler found: $$req{CONTENT}")}
}
$self->write('text/plain', 'NOOP');
},
'/perl' => sub {
$self->status("perl $$req{CONTENT}") if $DEBUG > 1;
local $@;
my $return;
eval "no strict; package $$self{caller}; \$return = do {$$req{CONTENT}}; 1"
or warn "perl( $$req{CONTENT} ) error: $@\n";
$self->write( 'text/plain', "RETURN " . ($return || ''));
},
'/ping' => sub {
if (my @delay = splice @{$$self{queue}}) {
$self->status('/ping clearing delay queue') if $DEBUG > 1;
$_->() for @delay;
XUL::Gui::flush;
}
local $DEBUG = 0;
$self->write('text/plain', 'NOOP');
},
'/favicon.ico' => sub {
$self->write('text/plain', '');
},
'/close' => sub {
my $shutdown = 1;
for (grep defined, @$self{qw/onclose onunload/}) {
$shutdown = ref eq 'CODE' ? $_->() : XUL::Gui::gui $_;
}
$self->write('text/plain', 'RETURN ' . ($shutdown ? 'true' : 'false'));
$$self{run} = ! $shutdown if $$self{run};
}
}
}
{my @firefox;
sub launch {
my $self = shift;
if ($$self{default_browser} or not $MOZILLA) {
my $cmd = ($^O =~ /MSWin/ ? 'start' :
$^O =~ /darwin/ ? 'open' : 'xdg-open')
$self->status('launching default browser' . ($DEBUG ? ": $cmd" : ''));
system $cmd and die $!;
return
}
unless (@firefox) {
find sub {push @firefox, [length, $File::Find::name]
if /^(:?firefox|iceweasel|xulrunner.*)(?:-bin|\.exe)?$/i and -f} => $_
for grep {/mozilla|firefox|iceweasel|xulrunner/i }
map {
if (opendir my $dir => my $path = $_)
{map "$path/$_" => readdir $dir} else {}
}
$^O =~ /MSWin/ ? @ENV{qw/ProgramFiles ProgramFiles(x86)/} :
$^O =~ /darwin/ ? '/Applications' :
split /[:;]/ => $ENV{PATH};
@firefox = sort {$$a[0] < $$b[0]} @firefox
}
if (@firefox) {
my $app;
for ($$self{trusted}) {
defined and !$_ or $_ =
`"$firefox[0][1]" -v 2>&1` =~
/ (?: firefox | iceweasel ) \s+ [34]
| xulrunner \s+ (?: 1\.[5-9] | 2\.[0-3] )
/ix
}
if ($$self{trusted}) {
local $@;
eval {
$$self{dir} = File::Temp->newdir('xulgui_XXXXXX', TMPDIR => 1);
$$self{dir}->unlink_on_destroy(0);
my $dirname = $$self{dir}->dirname;
my $base = (File::Spec->splitdir($dirname))[-1];
my ($file, $dir) = map {my $method = $_;
sub {File::Spec->$method( $dirname, split /\s+/ => "@_" )}
} qw( catfile catdir );
mkdir $dir->($_) or die $!
for qw(chrome defaults), "chrome $base", 'defaults preferences';
open my $manifest, '>', $file->('chrome chrome.manifest') or die $!;
print $manifest "content $base file:$base/";
open my $boot, '>', $file->('chrome', $base, 'boot.xul') or die $!; {
no warnings 'redefine';
local *write = sub {
my $self = shift;
my $code = pop;
$self->status("write \n\t". join "\n\t", split /\n/, $code) if $DEBUG > 3;
$code
};
print $boot $$self{dispatch}{'/'}();
}
open my $prefs, '>', $file->('defaults preferences prefs.js') or die $!;
print $prefs qq {pref("toolkit.defaultChromeURI", "chrome://$base/content/boot.xul");}; open my $ini, '>', $app = $file->('application.ini') or die $!;
print $ini split /[\t ]+/ => qq {
[App]
Name=$base
Version=$XUL::Gui::VERSION
BuildID=$base
[Gecko]
MinVersion=1.6
MaxVersion=2.3
};
$self->status("trusted: $app") if $DEBUG > 2;
1
} or do {
chomp (my $err = ($@ or $!));
$self->status("trusted mode failed: $err");
$$self{trusted} = 0;
undef $app;
}
} else {
while ($firefox[0][1] =~ /xulrunner[^\/\\]$/i) {
shift @firefox;
unless (@firefox) {
status {}, 'firefox not found: xulrunner was found but trusted mode is disabled';
return
}
}
}
my $firefox = $firefox[0][1];
$firefox =~ tr./.\\. if $^O =~ /MSWin/;
my $cmd = qq{"$firefox" }
. ($app
? "-app $app"
: ($$self{chrome} ? '-chrome ' : '')
) . (q{ 1>&2 2>/dev/null} x ($^O !~ /MSWin/));
if ($$self{launch}) {
$self->status('launching firefox' . ($DEBUG ? ": $cmd" : ''));
if (not $$self{trusted} and $^O =~ /darwin/) {
system qq[osascript -e 'tell application "Firefox" to OpenURL "http://localhost:$$self{port}"'] } else {
$$self{ffpid} = open $$self{firefox} => "$cmd |";
}
} else {
status {}, "launch gui with:\n\t$cmd"
}
}
else {status {}, 'firefox not found: start manually'}
}}
sub CLONE {
local $@;
eval {$$active{client}->close};
eval {$$active{server}->close};
}
BEGIN {*cleanup = \&CLONE}
END {
local $@;
for (@cleanup) {
eval {$_->cleanup};
eval {
$$_{dir}->unlink_on_destroy(1);
$$_{dir}->DESTROY;
};
}
eval {File::Temp::cleanup()};
}
sub client_js {
my $self = shift;
XUL::Gui::apply {
s/<port>/$$self{port}/g;
unless ($MOZILLA) {
s/\bconst\b/var/g;
s/^/if (!window.Element) window.Element = function(){};/;
}
} <<'</script>' }
const xul_gui = (function () {
var $jsid = 0;
var $ID = {};
var $noEvents = {};
var $cacheEvents = true;
var $ping = 50;
var $port = <port>;
var $queue = [];
var $mutex = false;
var $delayqueue = [];
var $server = new XMLHttpRequest();
var $lives = 5;
var $interval;
var $deadman;
function deadman () {
if (--$lives <= 0) quit();
$deadman = setTimeout(deadman, 50);
}
function deadman_pause () {clearTimeout($deadman)}
function deadman_resume () {$lives++; deadman()}
function pinger () {
if ($mutex || !$cacheEvents) return;
while ($delayqueue.length > 0)
$delayqueue.shift().call();
EVT( null, null );
}
function start () {
$interval = setInterval( pinger, $ping );
deadman();
}
function shutdown () {return send('close','')}
function send ($to, $val) {
var $url = $host + $to;
var $resurl = $host + 'res';
var $type;
var $realval;
while (1) {
deadman_pause();
$server.open( 'POST', $url, false );
$server.send( $val );
$lives = 5;
deadman_resume();
$val = $server.responseText;
if ($val == 'NOOP') return $realval;
if ($val.substr(0, 7) == 'RETURN ') return eval( $val.substr(7) );
try {$realval = eval( $val )}
catch ($err) {
if ($err == 'quit') return $server = null;
alert (
typeof $err == 'object'
? [$err.name, $val, $err.message].join("\n\n")
: $err
);
$realval = null;
}
$url = $resurl;
$val = $realval;
$type = typeof $val;
if ($val === true ) $val = 'RES 1'
else if ($val === false || $val === 0 ) $val = 'RES 0'
else if ($val === null || $val === undefined) $val = 'UND EF'
else if ($type == 'object')
if ($val.hasAttribute && $val.hasAttribute('id'))
$val = 'OBJ ' + $val.getAttribute('id')
else
xul_gui.ID[ 'xul_js_' + $jsid ] = $val,
$val = 'OBJ xul_js_' + $jsid++
else $val = 'RES ' + $val
}
}
function EVT ($event, $id) {
if ($noEvents.__count__ > 0
&& $id in $noEvents) return;
if ($mutex) {
if($cacheEvents && $event)
$queue.push([$event, $id]);
return
}
$mutex = true;
var $ret;
var $evt;
do {
if ($evt) {
$event = $evt[0];
$id = $evt[1];
}
if ($event) {
if ($event.type == 'perl') {
$ret = send('perl', $event.code);
break;
} else {
$ID['xul_js_' + $jsid] = $event;
send('event', 'EVT ' + $id +
' ' + $event.type + ' ' + ('xul_js_' + $jsid++));
}
} else {
send('ping', null)
}
} while ($evt = $queue.shift());
$mutex = false;
if ($event) setTimeout(pinger, 10);
return $ret;
}
function GET ($self, $k) {
if (typeof $self.hasAttribute == 'function' && $self.hasAttribute($k))
return $self.getAttribute($k);
if (typeof $self[$k] == 'function')
return $self[$k]();
return $self[$k];
}
function SET ($self, $k, $v) {
if (typeof $self.hasAttribute == 'function'
&& $self.hasAttribute($k) ) {
$self.setAttribute($k, $v);
return $v;
}
return $self[$k] = $v;
}
function quit () {
clearInterval($interval);
EVT = function(){};
try {
var $appStartup = Components.classes[
'@mozilla.org/toolkit/app-startup;1'
].getService(Components.interfaces.nsIAppStartup);
$appStartup.quit(Components.interfaces.nsIAppStartup.eForceQuit);
} catch ($e) {}
try {
window.close();
} catch ($e) {}
throw 'quit';
}
function pevt ($code) {
EVT({ type: 'perl', code: $code }, null)
}
function perl ($code) {
return ($mutex ? send('perl', $code) : pevt($code))
}
function delay ($code) {
$delayqueue.push(
typeof $code == 'function'
? $code
: function(){eval($code)}
)
}
Element.prototype.noEvents = function ($value) {
return $value
? $noEvents[this] = true
: delete $noEvents[this]
};
return {
ID: $ID,
noEvents: $noEvents,
start: start,
shutdown: shutdown,
send: send,
EVT: EVT,
GET: GET,
SET: SET,
quit: quit,
pevt: pevt,
perl: perl,
delay: delay,
cacheEvents: function ($val) {$cacheEvents = $val},
deadman_pause: deadman_pause,
deadman_resume: deadman_resume
}
})();
for (var $name in xul_gui)
window[$name] = xul_gui[$name];
const ID = xul_gui.ID;
(function ($proto) {
for (var $name in $proto)
Element.prototype[$name] = $proto[$name]
})({
removeChildren: function () {
while (this.firstChild)
this.removeChild( this.firstChild )
},
removeItems: function () {
while (this.lastChild
&& this.lastChild.nodeName == 'listitem')
this.removeChild( this.lastChild )
},
computed: function ($style) {
return document.defaultView
.getComputedStyle( this, null )
.getPropertyValue( $style )
},
scrollTo: function ($x, $y) {
try {
this.boxObject
.QueryInterface( Components.interfaces.nsIScrollBoxObject )
.scrollTo($x, $y)
} catch ($e)
{ alert('error: ' + this.tagName + ' does not scroll') }
}
});
</script>
package
XUL::Gui;
no warnings 'once';
*ComboBox = widget {
my $sel = $_->has('default') || '';
my $in = grep /^$sel/ =>
map {ref $_ ? $$_[1] : $_}
@{ $_->has('items!') };
my $menu = MenuList(
id => 'list',
$_ -> has('oncommand editable flex liststyle->style'),
MenuPopup(
id => 'popup',
$_ -> has('popupstyle->style'),
map {MenuItem(
$_{W}->has('itemstyle->style'),
zip [qw/label tooltiptext value selected/] =>
apply {$$_[3] = ($sel and $$_[2] =~ /^$sel/) ? 'true' : 'false'}
ref $_ eq 'ARRAY'
? [@$_[0, 0, 1]]
: [($_) x 3]
)} ($_{A}{editable} && $sel && !$in ? $sel : ()),
@{ $_->has('items!') }
)
);
$_->has('label')
? Hbox( align => 'center', Label( $_->has('label->value') ), $menu )
: $menu
}
value => sub {
my $self = shift;
my $item = $$self{list}->selectedItem;
$item ? $item->value
: $$self{list}->inputField->_value
};
{package
XUL::Gui::Hash;
sub new {
if (not defined wantarray) {
my %base = %{$_[1]};
tie %{$_[1]} => $_[0], \%base, @_[2 .. $#_];
return;
}
my ($class, $self) = splice @_, 0, 2;
tie my %hash => $class, $self, @_;
blessed ($self)
? bless \%hash => ref $self
: \%hash
}
sub unshift {
my $self = shift;
unshift @{$$self{isa}}, @_;
isweak $_ or weaken $_ for @{$$self{isa}};
}
sub hasOwn {exists $_[0]{hash}{$_[1]}}
sub hash :lvalue {$_[0]{hash}}
sub TIEHASH {
my $class = shift;
bless my $self = {
hash => shift || {},
isa => [ @_ ]
} => $class;
weaken $_ for @{$$self{isa}};
$self
}
sub FETCH {
my ($self, $key) = @_;
if (exists $$self{hash}{$key}) {
return $$self{hash}{$key}
}
return if $key eq uc $key;
for (@{$$self{isa}}) {
return $$_{$key} if $_ and %$_ and exists $$_{$key}
}
return
}
sub STORE {$_[0]{hash}{$_[1]} = $_[2]}
sub DELETE {delete $_[0]{hash}{$_[1]}}
sub CLEAR {$_[0]{hash} = {}}
sub EXISTS {
my ($self, $key) = @_;
return 1 if exists $$self{hash}{$key};
return if $key eq uc $key;
for (@{$$self{isa}}) {
return 1 if $_ and %$_ and exists $$_{$key}
}
return
}
sub FIRSTKEY {
my ($self) = @_;
my @each = ($$self{hash}, @{$$self{isa}});
keys %$_ for @each;
my %seen;
my $count = @each;
goto &{
$$self{nextkey} = sub {
my $want = wantarray;
while (@each) {
if ($want) {
if (my ($k, $v) = each %{$each[0]}) {
redo if $seen{$k}++;
redo if $k eq uc $k and $count != @each;
return $k, $v
}
} else {
if (defined (my $k = each %{$each[0]})) {
redo if $seen{$k}++;
redo if $k eq uc $k and $count != @each;
return $k;
}
}
shift @each
}
return
}
}
}
sub NEXTKEY {$_[0]{nextkey}()}
sub SCALAR {
my $self = shift;
for ($$self{hash}, @{$$self{isa}}) {
return scalar (%$_) || next
}
return
}
sub UNTIE {
my $self = shift;
delete $$self{$_} for keys %$self;
}
}
__PACKAGE__ if 'first require'