BBBikeMail.pm

# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 1998,2000,2003,2013 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://bbbike.de
#

package BBBikeMail;
use strict;
use vars qw($top @popup_style
	    $can_send_mail $can_send_mail_via_Mail_Mailer
	    $cannot_send_mail_via_Mail_Mailer
	    $cannot_send_mail_reason);

*top = \$main::top;
*redisplay_top  = \&main::redisplay_top;
*status_message = \&main::status_message;

sub enter_send_mail {
    enter_send_anything('mail', @_);
}

sub enter_send_anything {
    my($type, $subject, %args) = @_;
    my $data = $args{-data};
    my $to   = $args{-to};
    my $typename = ($type eq 'mail' ? 'Mail' : die "unhandled type $type");

    capabilities();

    if ($type eq 'mail' && !$can_send_mail) {
	my $reason = $cannot_send_mail_reason;
	$top->messageBox
	    (-icon => "error",
	     -message => "Kann keine Mails versenden" .
	     (defined $reason && $reason ne '' ?
	      ". Grund: $reason" : ""),
	    );
	return;
    }

    if ($type eq 'mail' && $args{-to}) {
	# Note that send_mail_via_browser does not always work very
	# well if -to is missing.
 	if ($^O eq 'MSWin32' || !$can_send_mail_via_Mail_Mailer) {
 	    send_mail_via_browser($args{-to}, $subject, $args{-data});
 	    return;
 	}
    }

    my $t = redisplay_top($top, $type, -title => $typename);
    return if !defined $t;
    my $row = 0;
    $t->Label(-text => "$typename an:")->grid(-row => $row,
					      -column => 0,
					      -sticky => "e");
    my $e;
    if ($type eq 'mail') {
	my $mail_alias;
	eval {
	    require Mail::Alias;
	    require Tk::BrowseEntry;
	    $mail_alias = new Mail::Alias::Ucbmail;
	    $mail_alias->read("$ENV{HOME}/.mailrc");
	};
	if (!$@ && $mail_alias) {
	    $e = $t->BrowseEntry(-textvariable => \$to);
	    my @alias;
	    while(my($k,$v) = each %$mail_alias) {
		foreach (@$v) {
		    push @alias, @{ $mail_alias->expand($_) }
		}
	    }
	    $e->insert("end", sort { lc($a) cmp lc($b) } @alias);
	}
    }
    if (!$e) {
	$e = $t->Entry(-textvariable => \$to);
    }
    $e->grid(-row => $row,  -column => 1, -sticky => "w");
    $e->tabFocus;
    $row++;
    my $comment_txt;
    if ($type eq 'mail') {
	$t->Label(-text => "Subject")->grid(-row => $row,
					    -column => 0,
					    -sticky => "e");
	$t->Entry(-textvariable => \$subject)->grid(-row => $row,
						    -column => 1,
						    -sticky => "w");

	$row++;
	$t->Label(-text => "zusätzlicher Text:")->grid(-row => $row,
						       -column => 0,
						       -sticky => "ne");
	$comment_txt = $t->Scrolled('Text', -scrollbars => "osoe",
				    -width => 40,
				    -height => 5,
				   )->grid(-row => $row,
					   -column => 1);
    }
    my $close_window = sub { $t->destroy;};
    my $apply_window = sub {
	if ($type eq 'mail') {
	    if (defined $to && $to ne '' &&
		defined $subject && $subject ne '') {
		if ($comment_txt) {
		    $data = $data . "\n" . $comment_txt->get("1.0", "end");
		}
		send_mail($to, $subject, $data);
		return 1; # usually cannot check send_mail success
	    } else {
		main::status_message("Bitte Empfänger und Subject angeben!", "err");
		return 0;
	    }
	} else {
	    die "Handling type $type NYI";
	}
    };
    my $ok_window    = sub {
	my $success = &$apply_window;
	&$close_window if $success;
    };
    $row++;
    my $bf = $t->Frame->grid(-row => $row, -column => 0,
			     -columnspan => 2);
    my $okb = $bf->Button
      (Name => 'ok',
       -command => $ok_window)->grid(-row => 0, -column => 0,
				     -sticky => 'ew');
    if ($Tk::VERSION >= 800) {
	$okb->configure(-default => "disabled");
    }
    my $cb = $bf->Button
      (Name => 'cancel',
       -command => $close_window)->grid(-row => 0, -column => 1,
					-sticky => 'ew');

    ## No! Otherwise it's not possible to use <Return> in the
    ## text field!
    #$t->bind('<Return>' => sub { $okb->invoke });
    $t->bind('<Escape>' => sub { $cb->invoke });

    $t->Popup(@popup_style);
}

sub send_mail {
    my(@args) = @_;
    capabilities();
    if ($^O eq 'MSWin32' || !$can_send_mail_via_Mail_Mailer) {
	send_mail_via_browser(@args);
    } else {
	send_mail_via_Mail_Mailer(@args);
    }
}

sub send_mail_via_Mail_Mailer {
    my($to, $subject, $data, %args) = @_;
    my $cc = delete $args{CC};
    warn "Extra arguments: " . join(" ", %args) if %args;
    eval {
	require Mail::Send;
	require Mail::Mailer;
	Mail::Mailer->VERSION(1.53);
	my $msg = new Mail::Send Subject => $subject, To => $to;
	$msg->add("MIME-Version", "1.0");
	$msg->add("Content-Type", "text/plain; charset=ISO-8859-1");
	$msg->add("Content-Transfer-Enconding", "8bit");
	$msg->add("CC", $cc) if $cc;
	$msg->add("Comments", "generated by BBBikeMail.pm BBBike/$BBBike::VERSION"
		  . " (OS=$^O)"
		 );
	my $fh = $msg->open;
	print $fh $data;
	$fh->close;
    };
    if ($@) {
	$top->bell;
	status_message("Fehler: $@\nMöglicherweise ist kein Mailprogramm vorhanden.\nFür das Versenden von Mails ist das Modul Mail::Send erforderlich.\n", 'error');
    }
}

sub send_mail_via_browser {
    my($to, $subject, $data, %args) = @_;

    my $url = create_mailto_url($to, $subject, $data, %args);

    require WWWBrowser;
    $main::devel_host = $main::devel_host if 0; # cease -w
    if ($main::devel_host) {
	warn "Sende URL <$url> zum Browser...\n";
    }
    WWWBrowser::start_browser($url);
}

sub create_mailto_url {
    # Tested with linux-mozilla 1.7 and FreeBSD's seamonkey 1.0.5
    # On modern systems data should probably be utf8-encoded
    # (checked with Mozilla Thunderbird on Windows)
    my($to, $subject, $data, %args) = @_;

    for ($to, $subject, $data, $args{CC}) {
	if ($_) {
	    require Encode;
	    $_ = Encode::encode("utf-8", $_);
	}
    }

    require CGI;
    CGI->import('-oldstyle_urls');
    my $url = "mailto:";
    $url .= $to if defined $to && $to !~ m{^\s*$};
    $url .= "?" . CGI->new({subject=>$subject,
			    body=>$data,
			    ($args{CC} ? (cc=>$args{CC}) : ()),
			   })->query_string;

    $url;
}

sub capabilities {
    if ($^O eq 'MSWin32') {
	# XXX Sending mail is currently disabled completely on
	# windows. Reason: the method creating a mailto URL and using
	# it with WWWBrowser::start_browser only works for short
	# content (less than 2000 bytes). This is usually too less for
	# route texts. An alternative is not yet found.
	$can_send_mail = 0;
	# Shortcut early, don't try Mail::Send or Mail::Mailer.
	# Usually this does not work out-of-the-box, as the smtp host
	# needs to be configured somewhere.
	return;
    } else {
	$can_send_mail = 1; # via browser
    }
    eval {
	die "Specified to not use Mail::Mailer via variable \$cannot_send_mail_via_Mail_Mailer"
	    if $cannot_send_mail_via_Mail_Mailer;
	require Mail::Send;
	require Mail::Mailer;
	Mail::Mailer->VERSION(1.53); # previous versions were unreliable
	$can_send_mail_via_Mail_Mailer = 1;
    };
    if (!$can_send_mail) {
	$cannot_send_mail_reason = $@;
    }
}

# peacify -w
$main::top = $main::top if 0;

1;