ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Mozilla-Plugin/Plugin.pm
Revision: 1.12
Committed: Sat Jul 21 00:41:47 2001 UTC (23 years ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.11: +13 -13 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 =head1 NAME
2
3 Browser::Plugin - embed perl into mozilla/netscape/ie/opera.
4
5 =head1 SYNOPSIS
6
7 use Browser::Plugin;
8
9 =head1 DESCRIPTION
10
11 sorry...
12
13 =over 4
14
15 =cut
16
17 package Browser::Plugin;
18
19 use base Exporter;
20 use Storable;
21 #use XSLoader;
22
23 $VERSION = 0.01;
24 @EXPORT = qw();
25
26 #XSLoader::load __PACKAGE__, $VERSION;
27
28 my $interface; # Browser::Plugin::xxx (design weakness)
29
30 my $debug = 1;
31
32 sub NP_VERSION_MAJOR (){ 0 }
33 sub NP_VERSION_MINOR (){ 9 }
34 sub NP_EMBED (){ 1 }
35 sub NP_FULL (){ 2 }
36 sub NP_NORMAL (){ 1 }
37 sub NP_SEEK (){ 2 }
38 sub NP_ASFILE (){ 3 }
39 sub NP_ASFILEONLY (){ 4 }
40 sub NP_MAXREADY (){ 2147483647 }
41 sub NPERR_NO_ERROR (){ 0 }
42 sub NPERR_GENERIC_ERROR (){ 1 }
43 sub NPERR_INVALID_INSTANCE_ERROR (){ 2 }
44 sub NPERR_INVALID_FUNCTABLE_ERROR (){ 3 }
45 sub NPERR_MODULE_LOAD_FAILED_ERROR (){ 4 }
46 sub NPERR_OUT_OF_MEMORY_ERROR (){ 5 }
47 sub NPERR_INVALID_PLUGIN_ERROR (){ 6 }
48 sub NPERR_INVALID_PLUGIN_DIR_ERROR (){ 7 }
49 sub NPERR_INCOMPATIBLE_VERSION_ERROR (){ 8 }
50 sub NPERR_INVALID_PARAM (){ 9 }
51 sub NPERR_INVALID_URL (){ 10 }
52 sub NPERR_FILE_NOT_FOUND (){ 11 }
53 sub NPERR_NO_DATA (){ 12 }
54 sub NPERR_STREAM_NOT_SEEKABLE (){ 13 }
55 sub NPVERS_HAS_STREAMOUTPUT (){ 8 }
56 sub NPVERS_HAS_NOTIFICATION (){ 9 }
57 sub NPVERS_HAS_LIVECONNECT (){ 9 }
58 sub NPVERS_WIN16_HAS_LIVECONNECT (){ 10 }
59
60 my $data;
61
62 sub BIAS() { -2147483647 } # ugliest hack ever seen
63
64 sub snd_cmd {
65 $data = pack "NN", 0, ord($_[-1]);
66 }
67
68 sub snd_ptr {
69 $data .= $_[-1];
70 }
71
72 sub snd_u32 {
73 $data .= pack "N", $_[-1];
74 }
75
76 sub snd_i32 {
77 $data .= pack "N", $_[-1] - BIAS;
78 }
79
80 sub snd_blk {
81 $data .= pack "NA*", length($_[-1]), $_[-1];
82 }
83
84 sub snd_snd {
85 substr ($data, 0, 4) = pack "N", length $data;
86 length ($data) == syswrite FD, $data;
87 }
88
89 sub snd_dyn {
90 length ($_[-1]) == syswrite FD, $_[-1];
91 }
92
93 sub rcv_cmd {
94 shift if ref $_[0];
95 my $cmd = shift;
96 my ($buf, $rcmd, $len);
97
98 do {
99 4 == sysread FD, $buf, 4 or exit;
100 $len = unpack "N", $buf;
101 $len -= 4;
102 $len == sysread FD, $buf, $len or die;
103
104 $data = substr $buf, 4;
105
106 $rcmd = substr $buf, 3, 1;
107 if ($rcmd =~ /^[a-z]$/) {
108 die "rcv_cmd: sync error, expected '$cmd' but got '$rcmd'\n" if $cmd && $rcmd ne $cmd;
109 return $rcmd;
110 } else {
111 &_handle_event($rcmd);
112 }
113 } while ($cmd);
114 }
115
116 sub rcv_ptr {
117 my $ptr = substr $data, 0, 8;
118 $data = substr $data, 8;
119 $ptr;
120 }
121
122 sub rcv_u32 {
123 my $u32 = unpack "N", $data;
124 $data = substr $data, 4;
125 $u32;
126 }
127
128 sub rcv_i32 {
129 my $i32 = BIAS + unpack "N", $data;
130 $data = substr $data, 4;
131 $i32;
132 }
133
134 sub rcv_blk {
135 my $len = unpack "N", $data;
136 my $str = substr $data, 4, $len;
137 $data = substr $data, 4 + $len;
138 $str;
139 }
140
141 sub rcv_dyn {
142 my $buf;
143 $_[-1] == sysread FD, $buf, $_[-1] or die "rcv_dyn: $!";
144 $buf;
145 }
146
147 # command from browser to plugin usually have capital letters while
148 # commands from perl to the browser always use lowercase letters
149 sub _handle_event($) {
150 my $cmd = shift;
151
152 warn "handle_event($cmd)\n" if $debug;
153 if ($cmd eq 'I') {
154 rcv_u32 == 1 or die "protocol version mismatch\n";
155 ($IFACE, $OSNAME, $OSVERS) = (rcv_blk, rcv_blk, rcv_blk);
156
157 } elsif ($cmd eq '+') { # New
158 my ($objid, $type, $mode, $save, $argc)
159 = (rcv_ptr, rcv_blk, rcv_u32, rcv_blk, rcv_u32);
160 my %args;
161 while ($argc--) {
162 my ($argn, $argv) = (rcv_blk, rcv_blk);
163 $args{$argn} = $argv;
164 }
165
166 $_OBJ{$objid} = $interface->new(
167 instance => $objid,
168 type => $type,
169 mode => $mode,
170 save => $save,
171 args => \%args,
172 );
173
174 } elsif ($cmd eq '-') { # Destroy
175 my $objid = rcv_ptr;
176 my $save = (delete $_OBJ{$objid})->save;
177 snd_cmd "-";
178 snd_u32 length $save;
179 snd_snd and snd_dyn $save;
180
181 } elsif ($cmd eq 'X') { # SetWindow
182 my $objid = rcv_ptr;
183 my %args = (
184 id => rcv_ptr,
185 x => rcv_i32,
186 y => rcv_i32,
187 w => rcv_i32,
188 h => rcv_i32,
189 );
190 if ($IFACE eq "UNIX") {
191 $args{id} = unpack "xxxxN", $args{id};
192 $args{ws_type} = rcv_i32;
193 $args{ws_depth} = rcv_u32;
194 }
195
196 snd_cmd 'X';
197 snd_u32 $_OBJ{$objid}->set_window(\%args);
198 snd_snd;
199
200 } elsif ($cmd eq 'N') { # NewStream
201 my $obj = $_OBJ{+rcv_ptr};
202 my %args = (
203 instance => $obj,
204 mimetype => rcv_blk,
205 id => rcv_ptr,
206 url => rcv_blk,
207 end => rcv_u32,
208 lastmodified => rcv_u32,
209 notifydata => rcv_u32,
210 seekable => rcv_u32,
211 push_stream => 1,
212 );
213 my $str = $_OBJ{$args{id}} = new Browser::Stream::Receive \%args;
214
215 my ($stype, $err) = $obj->push_stream($str);
216
217 snd_cmd 'N';
218 snd_u32 $err;
219 snd_u32 $stype || NP_NORMAL;
220 snd_snd;
221
222 } elsif ($cmd eq '/') { # StreamAsFile
223 my $obj = $_OBJ{+rcv_ptr};
224 my $str = $_OBJ{+rcv_ptr};
225 my $path = rcv_blk;
226
227 $obj->stream_as_file($obj, $stream, $path);
228
229 } elsif ($cmd eq 'R') { # WriteReady
230 my $obj = $_OBJ{+rcv_ptr};
231 my $str = $_OBJ{+rcv_ptr};
232
233 snd_cmd 'R';
234 snd_u32 $obj->write_ready($obj, $str);
235 snd_snd;
236
237 } elsif ($cmd eq 'W') { # Write
238 my $obj = $_OBJ{+rcv_ptr};
239 my $str = $_OBJ{+rcv_ptr};
240 my $ofs = rcv_i32;
241 my $len = rcv_i32;
242 my $dta = rcv_dyn $len;
243
244 snd_cmd 'W';
245 snd_i32 $obj->write($str, $ofs, $len, $dta);
246 snd_snd;
247
248 } elsif ($cmd eq 'D') { # DestroyStream
249 my $obj = $_OBJ{+rcv_ptr};
250 my $str = delete $_OBJ{+rcv_ptr};
251 my $why = rcv_u32;
252
253 $obj->destroy_stream($obj, $str, $why);
254
255 } else {
256 die "unknown command '$cmd' received";
257 }
258 }
259
260 =item my $fh = server_fh
261
262 The design of this module is event-based. When the plug-in starts (there
263 is always just one interpreter) it spawns one perl interpreter which
264 will immediately go into a even loop. If you want to use your own event
265 loop (e.g. using the Gtk or Event modules) you need to register a file
266 input handler on the filehandle returned by C<server_fh> that calls
267 C<server_event> whenever there is input pending on C<server_fh>. This will
268 ensure proper operation of the plug-in.
269
270 =item server_event
271
272 Call this function whenever there is data available on the C<server_fh>. This function
273 might not return.
274
275 Due to this design (flaw?), sharing of different toolkits using this
276 plug-in is difficult at best. Spawning a new perl interpreter for every
277 plug-in is also not very viable, so in the future one might be able to
278 specify a group on the embed statement (i.e. EMBED GROUP="gtk+").
279
280 =cut
281
282 sub server_fh { \*FD }
283
284 sub server_event { rcv_cmd }
285
286 sub mainloop {
287 server_event while 1;
288 }
289
290 sub init {
291 $interface = shift;
292
293 open FD, "+<&=$_[0]"; binmode FD;
294
295 $interface->mainloop;
296 }
297
298 sub new {
299 my $class = shift;
300 my $self = bless { @_ }, $class;
301 $self->{save} = $self->{save} ne ""
302 ? Storable::thaw $self->{save}
303 : {};
304 $self;
305 }
306
307 sub set_window {
308 my $self = shift;
309 my $new = shift;
310
311 if ($self->{wininfo}) {
312 if ($self->{wininfo}{id} ne $new->{id}) {
313 $self->window_delete($self->{wininfo});
314 } elsif ($self->{wininfo}{w} != $new->{w}
315 or $self->{wininfo}{h} != $new->{h}) {
316 $self->window_resize($new->{w}, $new->{h});
317 }
318 $self->{wininfo} = $new;
319 }
320
321 unless ($self->{wininfo}) {
322 $self->{window} = $self->window_new($new) and $self->{wininfo} = $new;
323 }
324
325 ();
326 }
327
328 sub window_new { () }
329 sub window_resize {}
330
331 sub window_delete {
332 my $self = shift;
333 delete $self->{wininfo};
334 delete $self->{window};
335 }
336
337 sub save {
338 my $self = shift;
339 $self->destroy;
340 Storable::nfreeze $self->{save};
341 }
342
343 sub destroy {
344 my $self = shift;
345 $self->set_window(undef);
346 }
347
348 sub write_ready { 0xfffff }
349 sub push_stream {}
350 sub stream_as_file {}
351 sub destroy_stream {}
352
353 sub DESTROY {}
354
355 sub write {
356 my ($self) = shift;
357 shift->write(@_);
358 }
359
360 =item ($error, $stream) = new_stream $mimetype, $target
361
362 Requests the creation of a new data stream produced by the plug-in and
363 consumed by the browser.
364
365 =cut
366
367 sub new_stream {
368 my ($self, $type, $target) = @_;
369 my ($error, $stream);
370
371 snd_cmd 'n';
372 snd_blk $mimetype;
373 snd_blk $target;
374 if (snd_snd) {
375 rcv_cmd 'n';
376 $error = rcv_u32;
377 unless ($error) {
378 $stream = new Browser::Stream::Send (
379 instance => $self,
380 mimetype => $type,
381 id => rcv_ptr,
382 url => $target,
383 );
384 }
385 }
386 ($error, $stream);
387 }
388
389 =item $error = $obj->get_url $url, $target
390
391 =cut
392
393 sub get_url {
394 my ($self, $url, $target) = @_;
395 my $error;
396
397 snd_cmd 'u';
398 snd_blk $url;
399 snd_blk $target;
400 if (snd_snd) {
401 rcv_cmd 'u';
402 $error = rcv_i32;
403 }
404 $error;
405 }
406
407 sub Browser::Stream::new {
408 bless $_[1], $_[0];
409 }
410
411 sub Browser::Stream::destroy {
412 my $str = shift;
413 my $error = shift;
414 unless ($str->{destroyed}) {
415 $str->{destroyed}++;
416
417 my $obj = $str->{instance};
418 snd_cmd 'd';
419 snd_ptr $obj->{id};
420 snd_ptr $str->{id};
421 snd_u32 $error || NPERR_NO_ERROR;
422 snd_snd;
423 }
424 }
425
426 *Browser::Stream::DESTROY = \&Browser::Stream::destroy;
427
428 BEGIN {
429 @Browser::Stream::Receive::ISA = Browser::Stream;
430 }
431
432 sub Browser::Stream::Receive::write {
433 # ...
434 }
435
436 BEGIN {
437 @Browser::Stream::Send::ISA = Browser::Stream;
438 }
439
440 =item $bytes = $stream->write($data)
441
442 =cut
443
444 sub Browser::Stream::Send::write {
445 my $str = shift;
446 my $obj = $self->{instance};
447
448 snd_cmd 'w';
449 snd_ptr $obj->{id};
450 snd_ptr $str->{id};
451 snd_u32 length $_[0];
452 if (snd_snd) {
453 if (snd_dyn $_[0]) {
454 rcv_cmd 'w';
455 return rcv_i32 ();
456 }
457 }
458 return 0;
459 }
460
461 1;
462
463 =back
464
465 =head1 BUGS
466
467 =head1 SEE ALSO
468
469 L<PApp>.
470
471 =head1 AUTHOR
472
473 Marc Lehmann <pcg@goof.com>
474 http://www.goof.com/pcg/marc/
475
476 =cut
477