cvsroot/Mozilla-Plugin/Plugin.pm

=head1 NAME

Mozilla::Plugin - embed perl into mozilla/netscape.

=head1 SYNOPSIS

 use Mozilla::Plugin;

=head1 DESCRIPTION

sorry...

=over 4

=cut

package Mozilla::Plugin;

use base Exporter;
use Storable;
#use XSLoader;

$VERSION = 0.01;
@EXPORT = qw();

#XSLoader::load __PACKAGE__, $VERSION;
use Data::Dumper;#d#

my $data;

sub BIAS() { -2000000000 } # ugliest hack ever seen

sub snd_cmd($) {
   $data = pack "NN", 0, ord($_[0]);
}

sub snd_ptr($) {
   $data .= $_[0];
}

sub snd_u32($) {
   $data .= pack "N", $_[0];
}

sub snd_i32($) {
   $data .= pack "N", $_[0] - BIAS;
}

sub snd_blk($) {
   $data .= pack "NA*", length($_[0]), $_[0];
}

sub snd_snd() {
   substr ($data, 0, 4) = pack "N", length $data;
   length ($data) == syswrite FD, $data;
}

sub snd_dyn($) {
   length ($_[0]) == syswrite FD, $_[0];
}

sub rcv_cmd() {
   my $buf;
   4 == sysread FD, $buf, 4 or exit;
   my $len = unpack "N", $buf;
   $len -= 4;
   $len == sysread FD, $buf, $len or die;

   $data = substr $buf, 4;

   substr $buf, 3, 1;
}

sub rcv_ptr() {
   my $ptr = substr $data, 0, 8;
   $data = substr $data, 8;
   $ptr;
}

sub rcv_u32() {
   my $u32 = unpack "N", $data;
   $data = substr $data, 4;
   $u32;
}

sub rcv_i32() {
   my $i32 = BIAS + unpack "N", $data;
   $data = substr $data, 4;
   $i32;
}

sub rcv_blk() {
   my $len = unpack "N", $data;
   my $str = substr $data, 4, $len;
   $data = substr $data, 4 + $len;
   $str;
}

=item my $fh = server_fh

The design of this module is event-based. When the plug-in starts (there
is always just one interpreter) it spawns one perl interpreter which
will immediately go into a even loop. If you want to use your own event
loop (e.g. using the Gtk or Event modules) you need to register a file
input handler on the filehandle returned by C<server_fh> that calls
C<server_event> whenever there is input pending on C<server_fh>. This will
ensure proper operation of the plug-in.

=item server_event

Call this function whenever there is data available on the C<server_fh>. This function
might not return.

Due to this design (flaw?), sharing of different toolkits using this
plug-in is difficult at best. Spawning a new perl interpreter for every
plug-in is also not very viable, so in the future one might be able to
specify a group on the embed statement (i.e. EMBED GROUP="gtk+").

=cut

sub server_fh() { *FD }

sub server_event() {
   my $cmd = rcv_cmd;

   warn "cmd<$cmd>\n";#d#

   if ($cmd eq "I") {
      rcv_u32 == 1 or die "protocol version mismatch\n";
      ($IFACE, $OSNAME, $OSVERS) = (rcv_blk, rcv_blk, rcv_blk);

   } elsif ($cmd eq "+") {
      my ($objid, $type, $mode, $save, $argc)
         = (rcv_ptr, rcv_blk, rcv_u32, rcv_blk, rcv_u32);
      my %args;
      while ($argc--) {
         my ($argn, $argv) = (rcv_blk, rcv_blk);
         $args{$argn} = $argv;
      }

      warn "new obj $objid\n";#d#
      $_OBJ{$objid} = new Mozilla::Plugin
         objid => $objid,
         type  => $type,
         mode  => $mode,
         save  => $save,
         args  => \%args;

   } elsif ($cmd eq "-") {
      my $objid = rcv_ptr;
      my $save = (delete $_OBJ{$objid})->save;
      snd_cmd "-";
      snd_u32 length $save;
      snd_snd and snd_dyn $save;

   } elsif ($cmd eq "W") {
      my $objid = rcv_ptr;
      my %args = (
            window => rcv_ptr,
            x      => rcv_i32,
            y      => rcv_i32,
            w      => rcv_i32,
            h      => rcv_i32,
      );
      if ($IFACE eq "UNIX") {
         $args{window}   = unpack "xxxxN", $args{window};
         $args{ws_type}  = rcv_i32;
         $args{ws_depth} = rcv_u32;
      }
      warn Dumper([$objid,\%args]);

      $_OBJ{$objid}->set_window(\%args);

   } else {
      die "unknown command '$cmd' received";
   }
}

sub mainloop {
   server_event while 1;
}

sub init {
   $IN_MOZILLA = 1;

   open FD, "+<&=$_[1]"; binmode $FD;

   warn "init: ".Dumper(@_);
   mainloop;
}

sub new {
   my $class = shift;
   my $self = bless { @_ }, $class;
   $self->{save} = $self->{save} ne ""
                   ? Storable::thaw $self->{save}
                   : {};
   warn "new: ".Dumper($self);
   $self;
}

sub set_window {
   my $self = shift;
   my $new = shift;
   if ($self->{window}) {
      if ($self->{window}{window} ne $new->{window}) {
         $self->window_delete($self->{window});
      } else {
         $self->window_resize($new->{window}, $new->{w}, $new->{h});
      }
      $self->{window} = $new;
   } else {
      $self->{window} = $new;
      $self->window_new($new->{window}, $new->{w}, $new->{h});
   }
   warn "set_window: ".Dumper($self);
}

sub window_new    {}
sub window_resize {}
sub window_delete {}

sub save {
   $_[0]->{save}{test} = ['t1',5,7];
   Storable::nfreeze $_[0]->{save};
}

sub DESTROY {
   warn "DESTROY";
}

1;

=back

=head1 BUGS

=head1 SEE ALSO

L<PApp>.

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut

Revision:	1.3
Committed:	Fri Feb 23 20:00:30 2001 UTC (25 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.2:	+100 -35 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			Mozilla::Plugin - embed perl into mozilla/netscape.
4
5			=head1 SYNOPSIS
6
7			use Mozilla::Plugin;
8
9			=head1 DESCRIPTION
10
11	root	1.2	sorry...
12
13	root	1.1	=over 4
14
15			=cut
16
17			package Mozilla::Plugin;
18
19			use base Exporter;
20	root	1.3	use Storable;
21	root	1.1	#use XSLoader;
22
23	root	1.3	$VERSION = 0.01;
24	root	1.1	@EXPORT = qw();
25
26			#XSLoader::load __PACKAGE__, $VERSION;
27	root	1.3	use Data::Dumper;#d#
28	root	1.1
29			my $data;
30
31	root	1.3	sub BIAS() { -2000000000 } # ugliest hack ever seen
32
33	root	1.1	sub snd_cmd($) {
34			$data = pack "NN", 0, ord($_[0]);
35			}
36
37	root	1.3	sub snd_ptr($) {
38			$data .= $_[0];
39			}
40
41			sub snd_u32($) {
42			$data .= pack "N", $_[0];
43			}
44
45	root	1.1	sub snd_i32($) {
46	root	1.3	$data .= pack "N", $_[0] - BIAS;
47	root	1.1	}
48
49			sub snd_blk($) {
50			$data .= pack "NA*", length($_[0]), $_[0];
51			}
52
53	root	1.3	sub snd_snd() {
54	root	1.1	substr ($data, 0, 4) = pack "N", length $data;
55	root	1.3	length ($data) == syswrite FD, $data;
56	root	1.2	}
57
58	root	1.3	sub snd_dyn($) {
59			length ($_[0]) == syswrite FD, $_[0];
60	root	1.1	}
61
62	root	1.3	sub rcv_cmd() {
63	root	1.1	my $buf;
64	root	1.3	4 == sysread FD, $buf, 4 or exit;
65	root	1.1	my $len = unpack "N", $buf;
66			$len -= 4;
67	root	1.3	$len == sysread FD, $buf, $len or die;
68	root	1.1
69			$data = substr $buf, 4;
70
71			substr $buf, 3, 1;
72			}
73
74	root	1.3	sub rcv_ptr() {
75			my $ptr = substr $data, 0, 8;
76			$data = substr $data, 8;
77			$ptr;
78			}
79
80			sub rcv_u32() {
81			my $u32 = unpack "N", $data;
82			$data = substr $data, 4;
83			$u32;
84			}
85
86	root	1.1	sub rcv_i32() {
87	root	1.3	my $i32 = BIAS + unpack "N", $data;
88	root	1.1	$data = substr $data, 4;
89			$i32;
90			}
91
92			sub rcv_blk() {
93			my $len = unpack "N", $data;
94			my $str = substr $data, 4, $len;
95			$data = substr $data, 4 + $len;
96			$str;
97			}
98
99	root	1.2	=item my $fh = server_fh
100
101			The design of this module is event-based. When the plug-in starts (there
102			is always just one interpreter) it spawns one perl interpreter which
103			will immediately go into a even loop. If you want to use your own event
104			loop (e.g. using the Gtk or Event modules) you need to register a file
105			input handler on the filehandle returned by C<server_fh> that calls
106			C<server_event> whenever there is input pending on C<server_fh>. This will
107			ensure proper operation of the plug-in.
108
109			=item server_event
110
111			Call this function whenever there is data available on the C<server_fh>. This function
112			might not return.
113
114			Due to this design (flaw?), sharing of different toolkits using this
115			plug-in is difficult at best. Spawning a new perl interpreter for every
116			plug-in is also not very viable, so in the future one might be able to
117			specify a group on the embed statement (i.e. EMBED GROUP="gtk+").
118
119			=cut
120
121	root	1.3	sub server_fh() { *FD }
122	root	1.2
123			sub server_event() {
124	root	1.3	my $cmd = rcv_cmd;
125
126			warn "cmd<$cmd>\n";#d#
127	root	1.1
128			if ($cmd eq "I") {
129	root	1.3	rcv_u32 == 1 or die "protocol version mismatch\n";
130	root	1.1	($IFACE, $OSNAME, $OSVERS) = (rcv_blk, rcv_blk, rcv_blk);
131	root	1.3
132	root	1.1	} elsif ($cmd eq "+") {
133			my ($objid, $type, $mode, $save, $argc)
134	root	1.3	= (rcv_ptr, rcv_blk, rcv_u32, rcv_blk, rcv_u32);
135	root	1.1	my %args;
136	root	1.2	while ($argc--) {
137			my ($argn, $argv) = (rcv_blk, rcv_blk);
138			$args{$argn} = $argv;
139			}
140	root	1.1
141	root	1.3	warn "new obj $objid\n";#d#
142	root	1.1	$_OBJ{$objid} = new Mozilla::Plugin
143	root	1.3	objid => $objid,
144			type => $type,
145			mode => $mode,
146			save => $save,
147			args => \%args;
148	root	1.1
149			} elsif ($cmd eq "-") {
150	root	1.3	my $objid = rcv_ptr;
151			my $save = (delete $_OBJ{$objid})->save;
152	root	1.2	snd_cmd "-";
153	root	1.3	snd_u32 length $save;
154			snd_snd and snd_dyn $save;
155
156			} elsif ($cmd eq "W") {
157			my $objid = rcv_ptr;
158			my %args = (
159			window => rcv_ptr,
160			x => rcv_i32,
161			y => rcv_i32,
162			w => rcv_i32,
163			h => rcv_i32,
164			);
165			if ($IFACE eq "UNIX") {
166			$args{window} = unpack "xxxxN", $args{window};
167			$args{ws_type} = rcv_i32;
168			$args{ws_depth} = rcv_u32;
169			}
170			warn Dumper([$objid,\%args]);
171
172			$_OBJ{$objid}->set_window(\%args);
173
174	root	1.1	} else {
175			die "unknown command '$cmd' received";
176			}
177			}
178
179			sub mainloop {
180	root	1.2	server_event while 1;
181	root	1.1	}
182
183	root	1.3	sub init {
184	root	1.1	$IN_MOZILLA = 1;
185
186	root	1.3	open FD, "+<&=$_[1]"; binmode $FD;
187
188			warn "init: ".Dumper(@_);
189	root	1.1	mainloop;
190			}
191
192			sub new {
193	root	1.2	my $class = shift;
194	root	1.3	my $self = bless { @_ }, $class;
195			$self->{save} = $self->{save} ne ""
196			? Storable::thaw $self->{save}
197			: {};
198			warn "new: ".Dumper($self);
199			$self;
200	root	1.1	}
201
202			sub set_window {
203	root	1.3	my $self = shift;
204			my $new = shift;
205			if ($self->{window}) {
206			if ($self->{window}{window} ne $new->{window}) {
207			$self->window_delete($self->{window});
208			} else {
209			$self->window_resize($new->{window}, $new->{w}, $new->{h});
210			}
211			$self->{window} = $new;
212			} else {
213			$self->{window} = $new;
214			$self->window_new($new->{window}, $new->{w}, $new->{h});
215			}
216			warn "set_window: ".Dumper($self);
217	root	1.1	}
218
219	root	1.3	sub window_new {}
220			sub window_resize {}
221			sub window_delete {}
222
223	root	1.1	sub save {
224	root	1.3	$_[0]->{save}{test} = ['t1',5,7];
225			Storable::nfreeze $_[0]->{save};
226	root	1.1	}
227
228			sub DESTROY {
229			warn "DESTROY";
230			}
231
232			1;
233
234			=back
235
236			=head1 BUGS
237
238			=head1 SEE ALSO
239
240			L<PApp>.
241
242			=head1 AUTHOR
243
244			Marc Lehmann <pcg@goof.com>
245			http://www.goof.com/pcg/marc/
246
247			=cut
248