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 $interface; # Mozilla::Plugin::xxx (design weakness)

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

      $_OBJ{$objid} = $interface->new(
         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;
      }

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

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

sub mainloop {
   server_event while 1;
}

sub init {
   $interface = shift;

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

   $interface->mainloop;
}

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

sub set_window {
   my $self = shift;
   my $new = shift;
      print "window set calling with $new->{window}, $new->{w}, $new->{h} ($self->{window}\n";#d#
   if ($self->{window}) {
      if ($self->{window}{window} ne $new->{window}) {
         $self->window_delete($self->{window});
      } elsif ($self->{window}{w} != $new->{w}
               or $self->{window}{h} != $new->{h}) {
         $self->window_resize($new->{window}, $new->{w}, $new->{h});
      }
      $self->{window} = $new;
   }

   unless ($self->{window}) {
      $self->{window} = $new;
      print "window new calling with $new->{window}, $new->{w}, $new->{h}\n";#d#
      $self->window_new($new->{window}, $new->{w}, $new->{h});
   }
}

sub window_new    {}
sub window_resize {}

sub window_delete {
   my $self = shift;
   delete $self->{window};
}

sub save {
   my $self = shift;
   $self->set_window(undef);
   Storable::nfreeze $self->{save};
}

sub DESTROY {
   #warn "DESTROY";#d#
}

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