view release on metacpan or  search on metacpan

lib/JaM/GUI/HTMLSurface.pm  view on Meta::CPAN

# $Id: HTMLSurface.pm,v 1.14 2001/11/02 13:46:13 joern Exp $

package JaM::GUI::HTMLSurface;

@ISA = qw ( JaM::GUI::Base );

use strict;
use Carp;
use Gtk::HTML;
use FileHandle;
use Data::Dumper;
use JaM::GUI::Base;
use File::Basename;

sub widget 	    { shift->{widget}	    }
sub image_dir 	    { shift->{image_dir}    }

sub handle	    { my $s = shift; $s->{handle}
		      = shift if @_; $s->{handle}	    }
sub image_pool	    { my $s = shift; $s->{image_pool}
		      = shift if @_; $s->{image_pool}	    }
sub url_in_focus    { my $s = shift; $s->{url_in_focus}
		      = shift if @_; $s->{url_in_focus}	    }
sub button3_callback{ my $s = shift; $s->{button3_callback}
		      = shift if @_; $s->{button3_callback} }
sub mail_link_callback { my $s = shift; $s->{mail_link_callback}
		         = shift if @_; $s->{mail_link_callback} }

sub gtk_attachment_popup    { my $s = shift; $s->{gtk_attachment_popup}
		      	      = shift if @_; $s->{gtk_attachment_popup}	    }


sub new {
	my $type = shift;
	my %par = @_;
	
	my  ($image_dir, $button3_callback, $mail_link_callback) =
	@par{'image_dir','button3_callback','mail_link_callback'};

	my $widget;
	eval {
		$widget = new Gtk::HTML;
	};
	confess ($@) if $@;
	
	my $self = bless {
		widget    => $widget,
		image_dir => $image_dir,
		button3_callback => $button3_callback,
		mail_link_callback => $mail_link_callback,
		handle    => undef,
	}, $type;
	
	$widget->signal_connect ('url_requested',    sub { $self->cb_url_requested (@_) } );
#	$widget->signal_connect ('object_requested', sub { $self->cb_object_requested (@_) } );
	$widget->signal_connect ('on_url',           sub { $self->cb_on_url (@_) } );
#	$widget->signal_connect ('link_clicked',     sub { $self->cb_link_clicked (@_) } );

	$widget->signal_connect ('button_press_event',   sub { $self->cb_button_press (@_) } );
#	$widget->signal_connect ('button_release_event', sub { print Dumper (\@_) } );

	$widget->show;

	# build popup menu for attachments
	my $popup = $self->gtk_attachment_popup (Gtk::Menu->new);
	my $item = Gtk::MenuItem->new ("Save as ...");
	$popup->append($item);
	$item->signal_connect ("activate", sub { $self->cb_save_attachment_file_dialog ( @_ ) } );
	$item->show;

	return $self;
}

sub show_eval {
	my $self = shift;
	my %par = @_;
	my ($file) = @par{'file'};

	my $base_dir = $self->image_dir;
	$file = "$base_dir/$file";
	
	open (IN, $file) or confess "can't read $file";
	my $content = join ('',<IN>);
	close IN;
	
	$content = eval 'qq{'.$content.'}';
	print $@;
	
	$self->begin;
	$self->write ($content);
	$self->end;
	
	1;
}

sub cb_on_url {
	my $self = shift;
	my ($widget, $url) = @_;
	$self->url_in_focus ( $url );
}

sub cb_button_press {
	my $self = shift;
	my ($widget, $event) = @_;
	
	my $url = $self->url_in_focus;

	if ( not $url ) {
		if ( $event->{button} == 3 ) {
			my $cb = $self->button3_callback;
			&$cb ($event);
		}
	} else {
		return $self->url_click ( event => $event );
	}
}

sub url_click {
	my $self = shift;
	my %par = @_;
	my ($event) = @par{'event'};

	my $url = $self->url_in_focus;

	if ( $url =~ /^(https?|ftp):/ ) {
		return 1 if $event->{button} != 1;
		my $browser_prog = $self->config('browser_prog');
		system ("$browser_prog -remote 'openURL($url)' >/dev/null 2>&1 &");
		return 1;
	} elsif ( $url =~ /mailto:([^\s]+)/ ) {
		my $cb = $self->mail_link_callback;
		&$cb( address => $1 );
		return 1;
	}
	
	if ( $event->{button} == 3 ) {
		$self->gtk_attachment_popup->popup (undef, undef, $event->{button}, 0);

	} elsif ( $event->{button} == 1 ) {
		$self->cb_save_attachment_file_dialog;
	}
}

sub cb_save_attachment_file_dialog {
	my $self = shift;
	my $url = $self->url_in_focus;
	return if not $url;
	
	$self->debug ("url=$url");
	
	my $filename = $url;
	if ( $filename =~ m!^pool://(.*)! ) {
		$filename = $self->image_pool->{$1}->{head}->recommended_filename;
	} else {
		$filename = "";
	}

	my $dir = $self->session_parameters->{'attachment_target_dir'};
	$dir ||= $self->config ('attachment_target_dir');

	$self->show_file_dialog (
		title	 => "Save as...",
		dir 	 => $dir,
		filename => $filename,
		confirm  => 1,
		cb 	 => sub { $self->cb_save_attachment_file_selected ( filename => $_[0], url => $url ) }
	);
	
	1;
}

sub cb_save_attachment_file_selected {
	my $self = shift;
	my %par = @_;
	my ($filename, $url) = @par{'filename','url'};

	$self->debug ("save attachment: url=$url filename=$filename");

	$self->session_parameters->{'attachment_target_dir'} = dirname $filename;

	my $image_dir = $self->image_dir;
	my $source_filename = "$image_dir/$url";
	my $target_filename = $filename;

	if ( not open (OUT, "> $target_filename") ) {
		print STDERR "Error opening $target_filename for writing!\n";
		return 1;
	}
	
	if ( $url =~ m!^pool://(.*)! ) {
		# internal image pool request
		print OUT $self->image_pool->{$1}->{body}->as_string;

	} elsif ( $url =~ m!^mail://(.*)! ) {
		# internal image pool request
		print OUT $self->image_pool->{$1}->{entity}->as_string;