File Coverage

blib/lib/XUL/Gui.pm

Criterion	Covered	Total	%
statement	200	853	23.4
branch	44	426	10.3
condition	27	229	11.7
subroutine	52	167	31.1
pod	29	42	69.0
total	352	1717	20.5

package XUL::Gui;
    use warnings;
    use strict;
    use Carp;
    use Storable     'dclone';
    use List::Util   'max';
    use MIME::Base64 'encode_base64';
    use Encode       'encode';
    use Scalar::Util qw/weaken isweak reftype blessed/;
    BEGIN {
        local $@;
        eval {
            require Hash::Util;
            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'};  # disables a number of optimizations that break under threads
    our $TESTING;
    our $DEBUG              = 0; # verbosity from 0 - 6
    our $MOZILLA            = 1; # enables mozilla specific XUL, otherwise only HTML tags will work (Web::Gui mode)
    our $AUTOBUFFER         = 1; # enable autobuffering of SET messages
    our $EXTENDED_OBJECTS   = 1; # enable inheritance for normal objects (does not apply to widgets)
    our $TIED_WIDGETS       = 0; # enable data inheritance instead of copying in widgets (10-20% slower, potentially less memory usage)
    our $FILL_GENID_OBJECTS = 1; # include objects without a user set ID in the widget namespace
                                   # MUST BE SET BEFORE WIDGETS ARE CREATED (ideally, right after "use XUL::Gui;")
                                   # disabling this option will save some time and memory, but will
                                   # require accessing the object's {W} key to get to widget members for unnamed objects

    $Carp::Internal{"XUL::Gui$_"}++ for '', '::Object', '::Server';

    sub import {
        splice @_ => 1, 1, ':all'
            if @_ == 2 and $_[1] =~ /^(\*|all|)$/;

        require Exporter and
        goto &{ Exporter->can('import') }
            if @_ == 1
            or 1  < (@_ = grep {not
                /^(?: ([\w:!]*) -> \*? ([\w:!]*)
                    | ([\w:!]+::!*)
                )$/x && XUL::Gui->oo( $3 or $2 or $1 )
            } @_)
    }

=head1 NAME

XUL::Gui - render cross platform gui applications with firefox from perl

=head1 VERSION

version 0.63

this module is under active development, interfaces may change.

this code is currently in beta, use in production environments at your own risk

=head1 SYNOPSIS

    use XUL::Gui;
    display Label 'hello, world!';

    # short enough?  remove "Label" for bonus points

    use XUL::Gui;
    display Window title => "XUL::Gui's long hello",
        GroupBox(
            Caption('XUL'),
            Button(
                label     => 'click me',
                oncommand => sub {$_->label = 'ouch'}
            ),
            Button(
                id        => 'btn',
                label     =>'automatic id registration',
                oncommand => sub {
                    ID(btn)->label = 'means no more variable clutter';
                    ID(txt)->value = 'and makes cross tag updates easy';
            }),
            Button(
                type  => 'menu',
                label => 'menu button',
                MenuPopup map
                    {MenuItem label => $_} qw/first second third/
            ),
            TextBox( id => 'txt', width => 300 ),
            ProgressMeter( mode => 'undetermined' ),
        ),
        GroupBox(
            Caption('HTML too'),
            TABLE( width => '100%',
                TR map {TD $_}
                    'one', I('two'), B('three'), U('four'), SUP('five')
            ),
            BR, HR,
            P('all the HTML tags are in CAPS'),
        );

=head1 DESCRIPTION

this module exposes the entire functionality of mozilla firefox's rendering
engine to perl by providing all of the C< XUL > and C< HTML > tags as functions
and allowing you to interact with those objects directly from perl. gui
applications created with this toolkit are cross platform, fully support CSS
styling, inherit firefox's rich assortment of web technologies (browser, canvas
and video tags, flash and other plugins), and are even easier to write than
C< HTML >.

=head2 how things work

gui's created with this module are event driven. an arbitrarily complex (and
runtime mutable) object tree is passed to C< display >, which then creates the
gui in firefox and starts the event loop. C< display > will wait for and respond
to events until the C< quit > function is called, or the user closes the window.

all of javascript's event handlers are available, and can be written in perl
(normally) or javascript (for handlers that need to be very fast such as image
rollovers with onmouseover or the like). this is not to say that perl side
handlers are slow, but with rollovers and fast mouse movements, sometimes there
is mild lag due to protocol overhead.

this module is written in pure perl, and only depends upon core modules, making
it easy to distribute your application. the goal of this module is to make all
steps of gui development as easy as possible. XUL's widgets and nested design
structure gets us most of the way there, and this module with its light weight
syntax, and 'do what i mean' nature hopefully finishes the job. everything has
sensible defaults with minimal boilerplate, and nested design means a logical
code flow that isn't littered with variables. please send feedback if you think
anything could be improved.

=head2 building blocks

just like in C< HTML>, you build up your gui using tags. all tags (C< XUL >
tags, C< HTML > tags, user defined widgets, and the C< display > function) are
parsed the same way, and can fit into one of four templates:

=over 8

=item * no arguments

    HR()


=item * one simple argument

    B('some bold text')
    some bold text

in the special case of a tag with one argument, which is not another tag, that
argument is added to that tag as a text node. this is mostly useful for HTML
tags, but works with XUL as well. once parsed, the line C< B('...') > becomes
C<< B( TEXT => '...' ) >>. the special C< TEXT > attribute can be used directly
if other attributes need to be set: C<< FONT( color=>'blue', TEXT=>'...' ) >>.

=item * multiple attributes

    Label( value=>'some text', style=>'color: red' )


=item * attributes and children

    Hbox( id => 'mybox', pack => 'center',
        Label( value => 'hello' ),
        BR,
        B('world')
    )




        world


=back

as you can see, the tag functions in perl nest and behave the same way as their
counterpart element constructors in C< HTML/XUL >.  just like in C< HTML >, you
access the elements in your gui by C< id >. but rather than using
C< document.getElementById(...) > all the time, setting the C< id > attribute
names an element in the global C< %ID > hash.  the same hash can be accessed
using the C< ID(some_id) > function.

    my $object = Button( id => 'btn', label => 'OK' );

    #  $ID{btn} == ID(btn) == $object

the ID hash also exists in javascript:

    ID.btn == document.getElementById('btn')

due to the way this module works, every element needs an C< id >, so if you
don't set one yourself, an auto generated C< id > matching C< /^xul_\d+$/ > is
used.  you can use any C< id > that matches C< /\w+/ >

Tk's attribute style with a leading dash is supported.
this is useful for readability when collapsing attribute lists with C< qw// >

    TextBox id=>'txt', width=>75, height=>20, type=>'number', decimalplaces=>4;
    TextBox qw/-id txt -width 75 -height 20 -type number -decimalplaces 4/;

multiple 'style' attributes are joined with ';' into a single attribute



=head3 xul documentation links

all C< XUL > and C< HTML > objects in perl are exact mirrors of their javascript
counterparts and can be acted on as such. for anything not written in this
document or L, developer.mozilla.com is the official source of
documentation:

=over

=item * L

=item * L

=item * L

=item * L - XUL periodic table

=back

=head2 event handlers

any tag attribute name that matches C< /^on/ > is an event handler (onclick,
onfocus, ...), and expects a C< sub {...} > (perl event handler) or
C< function q{...} > (javascript event handler).

perl event handlers get passed a reference to their object and an event object

    Button( label=>'click me', oncommand=> sub {
        my ($self, $event) = @_;
        $self->label = $event->type;
    })

in the event handler, C< $_ == $_[0] > so a shorter version would be:

    oncommand => sub {$_->label = pop->type}

javascript event handlers have C< event > and C< this > set for you

    Button( label=>'click me', oncommand=> function q{
        this.label = event.type;
    })

any attribute with a name that doesn't match C< /^on/ > that has a code ref
value is added to the object as a method.  methods are explained in more detail
later on.

=head1 EXPORT

    use XUL::Gui;   # is the same as
    use XUL::Gui qw/:base :util :pragma :xul :html :const :image/;

    the following export tags are available:

    :base       %ID ID alert display quit widget
    :tools      function gui interval serve timeout toggle XUL
    :pragma     buffered cached delay doevents flush noevents now
    :const      BLUR FILL FIT FLEX MIDDLE SCROLL
    :widgets    ComboBox filepicker prompt
    :image      bitmap bitmap2src
    :util       apply mapn trace zip
    :internal   genid object realid tag

    :all     (all exports)
    :default (same as with 'use XUL::Gui;')

    :xul    (also exported as Titlecase)
      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

    :html   (also exported as html_lowercase)
      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

constants:

    FLEX    flex => 1
    FILL    flex => 1, align =>'stretch'
    FIT     sizeToContent => 1
    SCROLL  style => 'overflow: auto'
    MIDDLE  align => 'center', pack => 'center'
    BLUR    onfocus => 'this.blur()'

    each is a function that returns its constant, prepended to its arguments,
    thus the following are both valid:

    Box FILL pack=>'end';
    Box FILL, pack=>'end';

=cut

    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);

    #for (qw/base tools pragma const widgets image util internal/) {
    #   printf "    :%-10s %s\n", $_, join ' '=> sort {
    #       lc $a cmp lc $b
    #   } @{ $EXPORT_TAGS{$_} }
    #}

    our %defaults = (
        window      => ['xmlns:html' => 'http://www.w3.org/1999/xhtml',
                         xmlns       => 'http://www.mozilla.org/keymaster/gatekeeper/there.is.only.xul',
                         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
    }


=head2 object oriented interface

if you prefer an OO interface, there are a few ways to get one:

    use XUL::Gui 'g->*';  # DYOI: draw your own interface

C< g > (which could be any empty package name) now has all of XUL::Gui's
functions as methods.  since draw your own interface does what you mean
(C< dyoidwym > ), each of the following graphic styles are equivalent:
C<< g->*, g->, ->g, install_into->g >>.

normally, installing methods into an existing package will cause a fatal error,
however you can add C to force installation into an existing package

no functions are imported into your namespace by default, but you can request
any you do want as usual:

    use XUL::Gui qw( g->* :base :pragma );

to use the OO interface:

    g->display( g->Label('hello world') );
    # is the same as
    XUL::Gui::display( XUL::Gui::Label('hello world') );

    use g->id('someid') or g->ID('someid') to access the %ID hash

    the XUL tags are also available in lc and lcfirst:
        g->label       == XUI::Gui::Label
        g->colorpicker == XUL::Gui::ColorPicker
        g->colorPicker == XUL::Gui::ColorPicker

    the HTML tags are also available in lc, unless an XUL tag
    of the same name exists

if you prefer an object (which behaves exactly the same as the package 'g'):

    use XUL::Gui ();        # or anything you do want
    my $g = XUL::Gui->oo;   # $g now has XUL::Gui's functions as methods

if you like B the OO lowercase names, but want functions, draw that:

    use XUL::Gui qw( ->main:: );  # ->:: will also export to main::
                                  #  '::' implies '!'
    display label 'hello, world';


=cut
    {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
    }}


=head1 FUNCTIONS

=head2 gui functions

=over 8

=item C< display LIST >

C< display > starts the http server, launches firefox, and waits for events.

it takes a list of gui objects, and several optional parameters:

    debug     (0) .. 6  adjust verbosity to stderr
    silent    (0) 1     disables all stderr status messages
    trusted    0 (1)    starts firefox with '-app' (requires firefox 3+)
    launch     0 (1)    launches firefox, if 0 connect to http://localhost:port
    skin       0 (1)    use the default 'chrome://global/skin' skin
    chrome     0 (1)    chrome mode disables all normal firefox gui elements,
                            setting this to 0 will turn those elements back on.
    xml       (0) 1     returns the object tree as xml, the gui is not launched
                 perl       includes deparsed perl event handlers
    delay  milliseconds delays each gui update cycle (for debugging)
    port                first port to start the server on, port++ after that
                            otherwise a random 5 digit port is used
    mozilla    0 (1)    setting this to 0 disables all mozilla specific features
                            including all XUL tags, the filepicker, and any
                            trusted mode features. (used to implement Web::Gui)

if the first object is a C< Window >, that window is created, otherwise a
default one is added. the remaining objects are then added to the window.

C< display > will not return until the the gui quits

see C< SYNOPSIS >, L, L, and the
C< examples > folder in this distribution for more details

=cut
    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 )
    }


=item C< quit >

shuts down the server (causes a call to C< display > to return at the end of the
current event cycle)

C< quit > will shut down the server, but it can only shut down the client in
trusted mode.

=cut
    sub quit {
        gui('setTimeout("quit()", 5); 0');
        $$server{run} = 0;
    }


=item C< serve PATH MIMETYPE DATA >

add a virtual file to the server

    serve '/myfile.jpg', 'text/jpeg', $jpegdata;

the paths C< qw( / /client.js /event /ping /exit /perl ) > are reserved

=cut
    sub serve {$server->serve(@_)}


=item C< object TAGNAME LIST >

creates a gui proxy object, allows run time addition of custom tags

    object('Label', value=>'hello') is the same as Label( value=>'hello' )

the C< object > function is the constructor of all proxied gui objects, and all
these objects inherit from C< [object] > which provides the following methods.

=cut
    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;
        }
    };

=item object introspection

objects and widgets inherit from a base class C< [object] > that provides the
following object inspection / extension methods. these methods operate on the
current data that XUL::Gui is holding in perl, none of them will ever call out
to the gui

    ->has('item!')      returns attributes or methods (see widget for details)
    ->attr('rows')      lvalue access to $$self{A} attributes
    ->child(2)          lvalue access to $$self{C} children
                          it only makes sense to use attr or child to set
                          values on objects before they are written to the gui
    ->can('update')     lvalue access to $$self{M} methods
    ->attributes        returns %{ $$self{A} }
    ->children          returns @{ $$self{C} }
    ->methods           returns %{ $$self{M} }
    ->widget            returns $$self{W}
    ->id                returns $$self{ID}
    ->parent            returns $$self{P}
    ->super             returns $$self{ISA}[0]
    ->super(2)          returns $$self{ISA}[2]
    ->extends(...)      sets inheritance (see widget for details)

these methods are always available for widgets, and if they end up getting in
the way of any javascript methods you want to call for gui objects:

    $object->extends(...)   # calls the perl introspection function
    $object->extends_(...)  # calls 'object.extends(...)' in the gui
    $x = $object->_extends; # fetches the 'object.extends' property
    $object->setAtribute('extends', ...); # and setting an attribute

or at runtime:

    local $XUL::Gui::EXTENDED_OBJECTS = 0; # which prevents object inheritance
                                           # in the current lexical scope
    $object->extends(...);
        # calls the real javascript 'extends' method assuming that it exists

=cut

    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'; # for DESTROY
                    croak "id '$id' contains non-word character"
                }
        } else {
            $$self{ID} = $$self{A}{id} = genid
        }
        if ($tag) {
            $self->$setup_object;
            $ID{$$self{ID}} = $self;
        }
        $self
    }


=item C< tag NAME >

returns a code ref that generates proxy objects, allows for user defined tag
functions

    *mylabel = tag 'label';
    \&mylabel == \&Label

=cut

    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;
    }


=item C< ID OBJECTID >

returns the gui object with the id C< OBJECTID >.
it is exactly the same as C< $ID{OBJECTID} > and has C< (*) > glob context so
you don't need to quote the id.

    Label( id => 'myid' )
    ...
    $ID{myid}->value = 5;
    ID(myid)->value = 5;  # same

=cut
    sub ID (*):lvalue {$ID{$_[0]}}


=item C< widget {CODE} HASH >

widgets are containers used to group tags together into common patterns.
in addition to grouping, widgets can have methods, attached data, and can
inherit from other widgets

    *MyWidget = widget {
        Hbox(
            Label( $_->has('label->value') ),
            Button( label => 'OK', $_->has('oncommand') ),
            $_->children
        )
    }   method  => sub{ ... },
        method2 => sub{ ... },
        some_data =>  [ ... ];  # unless the value is a CODE ref, each widget
                                # instance gets a new deep copy of the data

    $ID{someobject}->appendChild(
        MyWidget( label=>'widget', oncommand=>\&event_handler )
    );

inside the widget's code block, several variables are defined:

    variable   contains the passed in
       $_{A} = { attributes }
       $_{C} = [ children   ]
       $_{M} = { methods    }
       $_    = a reference to the current widget (also as $_{W})
       @_    = the unchanged runtime argument list

widgets have the following predefined (and overridable) methods that are
synonyms / syntactic sugar for the widget variables:

    $_->has('label')        ~~ exists $_{A}{label} ? (label=>$_{A}{label}) : ()
    $_->has('label->value') ~~ exists $_{A}{label} ? (value=>$_{A}{label}) : ()

    $_->has('!label !command->oncommand style')

    ->has(...) splits its arguments on whitespace and will search $_{A}, then
    $_{M} for the attribute. if an ! is attached (anywhere) to an attribute,
    it is required, and the widget will croak without it.
    in scalar context, if only one key => value pair is found, ->has() will
    return the value.  otherwise, the number of found pairs is returned

    $_->attr( STRING )     $_{A}{STRING} # lvalue
    $_->attributes         %{ $_{A} }
    $_->child( NUMBER )    $_{C}[NUMBER] # lvalue
    $_->children           @{ $_{C} }
    $_->can( STRING )      $_{M}{STRING} # lvalue
    $_->methods            %{ $_{M} }

most everything that you would want to access is available as a method of the
widget (attributes, children, instance data, methods). since there may be
namespace collisions, here is the namespace construction order:

    %widget_methods = (
        passed in attributes,
        predefined widget methods,
        widget methods and instance data,
        passed in methods
    );

widgets can inherit from other widgets using the ->extends() method:

    *MySubWidget = widget {$_->extends( &MyWidget )}
        submethod => sub {...};

more detail in L

=cut

    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; # crashes with 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;
            use strict 'refs';

            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]
        }
    }


=item C< alert STRING >

open an alert message box

=cut
    sub alert {
        gui( "alert('".&escape."')" );
        wantarray ? @_ : pop
    }


=item C< prompt STRING >

open an prompt message box

=cut
    sub prompt {
        gui( "prompt('".&escape."')" )
    }


=item C< filepicker MODE FILTER_PAIRS >

opens a filepicker dialog. modes are 'open', 'dir', or 'save'. returns the path
or undef on failure. if mode is 'open' and C< filepicker > is called in list
context, the picker can select multiple files.  the filepicker is only available
when the gui is running in 'trusted' mode.

    my @files = filepicker open =>
                    Text   => '*.txt; *.rtf',
                    Images => '*.jpg; *.gif; *.png';

=cut
    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
            : ()
    }


=item C< trace LIST >

carps C< LIST > with object details, and then returns C< LIST > unchanged

=cut
    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
    }}


=item C< function JAVASCRIPT >

create a javascript event handler, useful for mouse events that need to be very
fast, such as onmousemove or onmouseover

    Button( label=>'click me', oncommand=> function q{
        this.label = 'ouch';
        alert('hello from javascript');
        if (some_condition) {
            perl("print 'hello from perl'");
        }
    })

    $ID{myid} in perl is ID.myid in javascript

to access widget siblings by id, wrap the id with C< W{...} >

=cut
    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'
    }


=item C< interval {CODE} TIME LIST >

perl interface to javascript's C< setInterval() >. interval returns a code ref
which when called will cancel the interval. C< TIME > is in milliseconds.
C< @_ > will be set to C< LIST > when the code block is executed.

=cut
    sub interval (&$@) {
        my ($code, $time) = splice @_, 0, 2;
        my $list = \@_;
        my $id = genid;
        realid($id)= sub {$code->(@$list)};
                   # = sub {local *_ = $list; goto &$code};
        gui( qq{SET;ID.$id = setInterval( "pevt('XUL::Gui::realid(q|$id|)->()')", $time)} );
        sub {gui(qq{SET;clearInterval(ID.$id)})}
    }


=item C< timeout {CODE} TIME LIST >

perl interface to javascript's C< setTimeout() >. timeout returns a code ref
which when called will cancel the timeout. C< TIME > is in milliseconds. C< @_ >
will be set to C< LIST > when the code block is executed.

=cut
    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
    }


=item C< XUL STRING >

converts an XML XUL string to C< XUL::Gui > objects.  experimental.

this function is provided to facilitate drag and drop of XML based XUL from
tutorials for testing. the perl functional syntax for tags should be used in all
other cases

=cut
    {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 {}            '),'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$_"
        }
    }}


=item C< gui JAVASCRIPT >

executes C< JAVASCRIPT > in the gui, returns the result

=back

=cut
    {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
        }

=head2 data binding

=over 8

passing a reference to a scalar or coderef as a value in an object constructor
will create a data binding between the perl variable and its corresponding
value in the gui.

    use XUL::Gui;

    my $title = 'initial title';

    display Window title => \$title,
        Button(
            label => 'update title',
            oncommand => sub {
                $title = 'title updated via data binding';
            }
        );

a property on a previously declared object can also be bound by taking a
reference to it:

    display
        Label( id => 'lbl', value => 'initial value'),
        Button(
            label => 'update',
            oncommand => sub {
                my $label = \ID(lbl)->value;

                $$label = 'new value';
            }
        )

this is just an application of the normal bidirectional behavior of gui
accessors:

    for (ID(lbl)->value) {
        print "$_\n";  # gets the current value from the gui

        $_ = 'new';    # sets the value in the gui

        print "$_\n";  # gets the value from the gui again
    }

=back

=head2 pragmatic blocks

the following functions all apply pragmas to their CODE blocks. in some cases,
they also take a list. this list will be C< @_ > when the CODE block executes.
this is useful for sending in values from the gui, if you don't want to use a
C< now {block} >

=head3 autobuffering

this module will automatically buffer certain actions within event handlers.
autobuffering will queue setting of values in the gui until there is a get, the
event handler ends, or C< doevents > is called.  this eliminates the need for
many common applications of the C< buffered > pragma.

=over 8

=item C< flush >

flush the autobuffer

=cut
        sub flush {
            if (@setbuf) {
                $server->write('text/plain', join '' => @setbuf);
                @setbuf = ();
                $server->read_until('/res');
            }
        }

=item C< buffered {CODE} LIST >

delays sending all messages to the gui. partially deprecated (see autobuffering)

    buffered {
        $ID{$_}->value = '' for qw/a bunch of labels/
    }; # all labels are cleared at once

=cut
        sub buffered (&@) {
            $buffered++;
            &{+shift};
            unless (--$buffered) {
                gui "SET;@buffer";
                @buffer = ();
            }
            return
        }


=item C< cached {CODE} >

turns on caching of gets from the gui

=cut
        sub cached (&) {
            $cached++;
            my $ret = shift->();
            %cache  = () unless --$cached;
            $ret
        }


=item C< now {CODE} >

execute immediately, from inside a buffered or cached block, without causing a
buffer flush or cache reset. buffered and cached will not work inside a now
block.

=cut
        sub now (&) {
            my ($want, @ret) = wantarray;
            $now++;
            $want ? @ret     = shift->()
                  : $ret[0]  = shift->();
            $now--;
            $want ? @ret : $ret[0]
        }
    }


=item C< delay {CODE} LIST >

delays executing its CODE until the next gui refresh

useful for triggering widget initialization code that needs to run after the gui
objects are rendered.  the first element of C< LIST > will be in C< $_ > when
the code block is executed

=cut
    sub delay (&@) {
        my $code = shift;
        my $args = \@_;
        push @{$$server{queue}}, sub {@$args and local *_ = \$$args[0]; $code->(@$args)};
        return
    }


=item C< noevents {CODE} LIST >

disable event handling

=cut
    sub noevents (&@) {
        gui 'xul_gui.cacheEvents(false);';
        my @ret = &{+shift};
        gui 'xul_gui.cacheEvents(true);';
        @ret
    }


=item C< doevents >

force a gui update cycle before an event handler finishes

=cut
    sub doevents () {
        $server->{dispatch}{'/ping'}();
        $server->read_until('/ping');
        return
    }


=back

=head2 utility functions

=over 8

=item C< mapn {CODE} NUMBER LIST >

map over n elements at a time in C< @_ > with C< $_ == $_[0] >

    print mapn {$_ % 2 ? "@_" : " [@_] "} 3 => 1..20;
    > 1 2 3 [4 5 6] 7 8 9 [10 11 12] 13 14 15 [16 17 18] 19 20

=cut
    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
    }


=item C< zip LIST of ARRAYREF >

    %hash = zip [qw/a b c/], [1..3];

=cut
    sub zip {
        map {my $i = $_;
            map $$_[$i] => @_
        } 0 .. max map $#$_ => @_
    }


=item C< apply {CODE} LIST >

apply a function to a copy of C< LIST > and return the copy

    print join ", " => apply {s/$/ one/} "this", "and that";
    > this one, and that one

=cut
    sub apply (&@) {
        my ($sub, @ret) = @_;
        $sub->() for @ret;
        wantarray ? @ret : pop @ret
    }


=item C< toggle TARGET OPT1 OPT2 >

alternate a variable between two states

    toggle $state;          # opts default to 0, 1
    toggle $state => 'red', 'blue';

=cut
    sub toggle {
        no warnings;
        my @opt = (splice(@_, 1), 0, 1);
        $_[0] = $opt[ $_[0] eq $opt[0] or $_[0] ne $opt[1] ]
    }


=item C< bitmap WIDTH HEIGHT OCTETS >

returns a binary .bmp bitmap image. C< OCTETS > is a list of C< BGR > values

    bitmap 2, 2, qw(255 0 0 255 0 0 255 0 0 255 0 0); # 2px blue square

for efficiency, rather than a list of C< OCTETS >, you can send in a single
array reference. each element of the array reference can either be an array
reference of octets, or a packed string C<< pack "C*" => OCTETS >>

=cut
    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,         # "BM"         # file format thanks to Wikipedia
            (54 + $size),    # file size
            0x00_00,         # not used
            0x00_00,         # not used
            0x36_00_00_00,   # offset of bitmap data
            0x28_00_00_00,   # remaining bytes in header
            $width,
            $height,
            0x01_00,         # color planes
            0x18_00,         # bits/pixel (24)
            0x00_00_00_00,   # no compression
            $size,           # size of raw BMP data (after header)
            0x13_0B_00_00,   # horizontal res
            0x13_0B_00_00,   # vertical res
            0x00_00_00_00,   # not used
            0x00_00_00_00,   # not used
            reverse
              @_ > 1
                ? map {pack 'C*' => splice(@_, 0, $width*3), @pad} 1 .. $height
                : map {ref $_
                     ? pack 'C*'    => @$_, @pad
                     : pack 'a* C*' =>  $_, @pad
                } @{$_[0]}
    }


=item C< bitmap2src WIDTH HEIGHT OCTETS >

returns a packaged bitmap image that can be directly assigned to an image tag's
src attribute. arguments are the same as C< bitmap() >

    $ID{myimage}->src = bitmap2src 320, 180, @image_data;

=back

=cut
    sub bitmap2src {'data:image/bitmap;base64,' . encode_base64 &bitmap}


=head1 METHODS

    # access attributes and properties

        $object->value = 5;                   # sets the value in the gui
        print $object->value;                 # gets the value from the gui

    # the attribute is set if it exists, otherwise the property is set

        $object->_value = 7;                  # sets the property directly

    # method calls

        $object->focus;                       # void context or
        $object->appendChild( H2('title') );  # any arguments are always methods
        print $object->someAccessorMethod_;   # append _ to force interpretation
                                              # as a JS method call

in addition to mirroring all of an object's existing javascript methods /
attributes / and properties to perl (with identical spelling / capitalization),
several default methods have been added to all objects

=over 8

=cut

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; # proxy
            $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 {
                require B::Deparse;
                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};

        $MOZILLA or $tag =~ s/^html://;

        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"};
                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, "\n";
        } else {
            if ($MOZILLA) {
                push @xml, "/>\n"
            } else {
                push @xml, ">\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');}
                        : qq{NS('http://www.w3.org/1999/xhtml','$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"
    };


=item C<< ->removeChildren( LIST ) >>

removes the children in C< LIST >, or all children if none are given

=cut

    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
    }


=item C<< ->removeItems( LIST ) >>

removes the items in C< LIST >, or all items if none are given

=cut
    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
    }


=item C<< ->appendChildren( LIST ) >>

appends the children in C< LIST >

=cut

    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
    }


=item C<< ->prependChild( CHILD, [INDEX] ) >>

inserts C< CHILD > at C< INDEX > (defaults to 0) in the parent's child list

=cut
    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
    }

=item C<< ->replaceChildren( LIST ) >>

removes all children, then appends C< LIST>

=cut
    sub replaceChildren {
        my ($self, @children) = @_;
        XUL::Gui::buffered {
        XUL::Gui::noevents {
            $self->removeChildren
                 ->appendChildren( @children )
        }};
        $self
    }

=item C<< ->appendItems( LIST ) >>

append a list of items

=cut
    sub appendItems {
        my ($self, @items) = @_;
        XUL::Gui::buffered {
            (XUL::Gui::isa_object)
                ? $self->appendChild($_)
                : $self->appendItem( ref eq 'ARRAY' ? @$_ : $_ )
            for @items
        };
        $self
    }


=item C<< ->replaceItems( LIST ) >>

removes all items, then appends C< LIST>

=back

=cut
    sub replaceItems {
        my ($self, @items) = @_;
        XUL::Gui::buffered {
        XUL::Gui::noevents {
            $self->removeItems
                 ->appendItems( @items )
        }};
        $self
    }


package
    XUL::Gui::Scalar;
    use Carp;

    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;
    use Carp;
    use IO::Socket;
    use File::Find;
    use Scalar::Util qw/openhandle/;
    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;

        require Time::HiRes if $$self{delay};

        $$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->status("display server started on http://localhost:$$self{port}");

        $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{\n} .
                           (qq{\n} x!! $$self{skin});
                    $root = $$self{content}[0]{TAG} eq 'window'
                            ? shift @{$$self{content}}
                            : XUL::Gui::Window()
                } else {
                    $meta = qq{\n};
                    $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 .. $#{$$self{content}}) {
                            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;
                $$root{C} = [ XUL::Gui::Script(src=>"http://localhost:$$self{port}/client.js") ];
                $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')
                . qq{ http://localhost:$$self{port}};

            $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 {
                    require File::Spec;
                    require File::Temp;
                    $$self{dir} = File::Temp->newdir('xulgui_XXXXXX', TMPDIR => 1);

                    $$self{dir}->unlink_on_destroy(0); # for threads
                    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 ' : '')
                            . qq{"http://localhost:$$self{port}"}
                    ) . (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//$$self{port}/g;
            unless ($MOZILLA) {
                s/\bconst\b/var/g;
                s/^/if (!window.Element) window.Element = function(){};/;
            }
        } <<'' }

const xul_gui = (function () {
    var $jsid        = 0;
    var $ID          = {};
    var $noEvents    = {};
    var $cacheEvents = true;
    var $ping        = 50;
    var $host        = 'http://localhost:/';
    var $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') }
    }
});




package
    XUL::Gui;
    no warnings 'once';

=head2 widgets

=over 4

=item ComboBox

create dropdown list boxes

    items => [
        ['displayed label' => 'value'],
        'label is same as value'
        ...
    ]
    default => 'item selected if this matches its value'

    also takes: label, oncommand, editable, flex
    styles:     liststyle, popupstyle, itemstyle
    getter:     value

=cut

*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
    };

=back

=head1 CAVEATS

too many changes to count.  if anything is broken, please send in a bug report.

some options for display have been reworked from 0.36 to remove double negatives

widgets have changed quite a bit from version 0.36. they are the same under the
covers, but the external interface is cleaner. for the most part, the following
substitutions are all you need:

    $W       -->  $_ or $_{W}
    $A{...}  -->  $_{A}{...} or $_->attr(...)
    $C[...]  -->  $_{C}[...] or $_->child(...)
    $M{...}  -->  $_{M}{...} or $_->can(...)

    attribute 'label onclick'  -->  $_->has('label onclick')
    widget {extends ...}       -->  widget {$_->extends(...)}

export tags were changed a little bit from 0.36

thread safety should be better than in 0.36

currently it is not possible to open more than one window, hopefully this will
be fixed soon

the code that attempts to find firefox may not work in all cases, patches
welcome

for the TextBox object, the behaviors of the "value" and "_value" methods are
reversed. it works better that way and is more consistent with the behavior of
other tags.

=head1 AUTHOR

Eric Strom, C<<  >>

=head1 BUGS

please report any bugs or feature requests to C< bug-xul-gui at rt.cpan.org >,
or through the web interface at
L. I will be notified,
and then you'll automatically be notified of progress on your bug as I make
changes.

=head1 ACKNOWLEDGMENTS

the mozilla development team

=head1 COPYRIGHT & LICENSE

copyright 2009-2010 Eric Strom.

this program is free software; you can redistribute it and/or modify it under
the terms of either: the GNU General Public License as published by the Free
Software Foundation; or the Artistic License.

see http://dev.perl.org/licenses/ for more information.

=cut


{package
    XUL::Gui::Hash;
    use Scalar::Util qw/blessed weaken isweak/;
    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'