#!@PERL@

# Copyright (c) 1999-2009 Mikhael Goikhman
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# Filter this script to pod2man to get a man page:
#   pod2man -c "Fvwm Utilities" fvwm-menu-headlines | nroff -man | less -e

require 5.002;
use strict;
use vars qw($site_info @smonths @lmonths %smonth_hash %lmonth_hash);
use vars qw($entity_map $error_menu_content);
use Getopt::Long;
use Socket;
use POSIX qw(strftime);
use Time::Local;

my $version = "@VERSION@";

local $site_info = {
	'freshmeat' => {
		'name' => "FreshMeat",
		'host' => "freshmeat.net",
		'path' => "/backend/recentnews.txt",
		'func' => \&process_freshmeat,
		'flds' => 'headline, date, url',
	},
	'slashdot' => {
		'name' => "Slashdot",
		'host' => "slashdot.org",
		'path' => "/slashdot.xml",
		'func' => \&process_slashdot,
		'flds' => 'title, url, time, author, department, topic, comments, section, image',
	},
	'linuxtoday' => {
		'name' => "LinuxToday",
		'host' => "linuxtoday.com",
		'path' => "/lthead.txt",
		'func' => \&process_linuxtoday,
		'flds' => 'headline, url, date',
	},
	'old-segfault' => {
		'name' => "Old-Segfault (empty now)",
		'host' => "segfault.org",
		'path' => "/stories.txt",
		'func' => \&process_segfault,
		'flds' => 'headline, url, date, author_name, author_email, type',
	},
	'old-appwatch' => {
		'name' => "Old-AppWatch (closed by ZDNet)",
		'host' => "www.appwatch.com",
		'path' => "/appwatch.rdf",
		'func' => \&process_poor_rdf,
		'flds' => 'title, link, description',
	},
	'old-linuxapps' => {
		'name' => "Old-LinuxApps (moved/closed)",
		'host' => "www.linuxapps.com-closed",
		'path' => "/backend/linux_basic.txt",
		'func' => undef,
		'flds' => 'headline, date, url',
	},
	'old-justlinux' => {
		'name' => "Old-JustLinux (no headlines?)",
		'host' => "www.justlinux.com",
		'path' => "/backend/discussion.rdf",
		'func' => \&process_poor_rdf,
		'flds' => 'title, link',
	},
	'daemonnews' => {
		'name' => "DaemonNews",
		'host' => "daily.daemonnews.org",
		'path' => "/ddn.rdf.php3",
		'func' => \&process_poor_rdf,
		'flds' => 'title, link',
	},
	# this is now called FootNotes or GNOME Desktop News, was news.gnome.org
	'gnome-news' => {
		'name' => "GNOME-News",
		'host' => "www.gnomedesktop.org",
		'path' => "/backend.php",
		'func' => \&process_poor_rdf,
		'flds' => 'title, link',
	},
	'kde-news' => {
		'name' => "KDE-News",
		'host' => "news.kde.org",
		'path' => "/rdf",
		'func' => \&process_kde_news,
		'flds' => 'title, link',
	},
	'old-freekde' => {
		'name' => "Old-FreeKDE (taken off?)",
		'host' => "freekde.org",
		'path' => "/freekdeorg.rdf",
		'func' => \&process_freekde,
		'flds' => 'title, link',
	},
	'rootprompt' => {
		'name' => "RootPrompt",
		'host' => "rootprompt.org",
		'path' => "/rss/",
		'func' => \&process_rootprompt,
		'flds' => 'title, link, description',
	},
	'newsforge' => {
		'name' => "NewsForge",
		'host' => "www.newsforge.com",
		'path' => "/newsforge.xml",
		'func' => \&process_slashdot,
		'flds' => 'title, url, time, author, department, topic, comments, section, image',
	},
	'kuro5hin' => {
		'name' => "Kuro5hin",
		'host' => "www.kuro5hin.org",
		'path' => "/backend.rdf",
		'func' =>  \&process_kuro5hin,
		'flds' => 'title, link, description',
	},
	'bbspot' => {
		'name' => "BBSpot",
		'host' => "bbspot.com",
		'path' => "/bbspot.rdf",
		'func' => \&process_poor_rdf,
		'flds' => 'title, link',
	},
	'linuxfr' => {
		'name' => "LinuxFr",
		'host' => "linuxfr.org",
#		'path' => "/short.php3",
		'path' => "/backend.rss",
		'func' => \&process_linuxfr,
#		'flds' => 'headline, url, author_name, author_email, type',
		'flds' => 'title, link',
	},
	'thinkgeek' => {
		'name' => "ThinkGeek",
		'host' => "www.thinkgeek.com",
		'path' => "/thinkgeek.rdf",
		'func' => \&process_poor_rdf,
		'flds' => 'title, link',
	},
	'cnn' => {
		'name' => "CNN",
		'host' => "www.cnn.com",
		'path' => "/desktop/content.html",
		'func' => \&process_cnn,
		'flds' => 'headline, url',
	},
	# to be removed
	'bbc-world' => {
		'name' => "BBC-World (obsolete)",
		'host' => "news.bbc.co.uk",
		'path' => "/low/english/world/default.stm",
		'func' => \&process_old_bbc,
		'flds' => 'headline, url, abstract',
	},
	# to be removed
	'bbc-scitech' => {
		'name' => "BBC-SciTech (obsolete)",
		'host' => "news.bbc.co.uk",
		'path' => "/low/english/sci/tech/default.stm",
		'func' => \&process_old_bbc,
		'flds' => 'headline, url, abstract',
	},
	'bbc' => {
		'name' => "BBC",
		'host' => "news.bbc.co.uk", 'host0' => "tickers.bbc.co.uk",
		'path' => "/tickerdata/story2.dat",
		'func' => \&process_bcc,
		'flds' => 'story, headline, url',
	},
};

# Site specific parsers may use these constants to convert month to unix time.
local @smonths = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
local @lmonths = qw(January February March April May June July August September October November December);
local (%smonth_hash, %lmonth_hash) = ();
foreach (0 .. 11) { $smonth_hash{$smonths[$_]} = $_; $lmonth_hash{$lmonths[$_]} = $_; }

my $TIMEFIELDS_DATE_TIME = 1;
my $TIMEFIELDS_ONLY_DATE = 2;
my $TIMEFIELDS_NONE = 3;

my $home  = $ENV{'HOME'} || '/tmp';
my $fvwm_user_dir = $ENV{'FVWM_USERDIR'} || "$home/.fvwm";
$fvwm_user_dir = $home unless -d $fvwm_user_dir;
my $work_home = "$fvwm_user_dir/.fvwm-menu-headlines";

require "$work_home/extension.pl" if -r "$work_home/extension.pl";

my $info  = undef;
my $default_site = 'freshmeat';
my $site  = undef;
my $name  = undef;
my $title = undef;
my $itemf = '%h\t%[(%Y-%m-%d %H:%M)]';
my $execf = q(firefox '%u');
my $commf = undef;
my $icont = '';
my $iconi = '';
my $iconh = '';
my $icone = '';
my $wm_icons = 0;

my $proxy = undef;
my $port  = 80;
my $frontpage = undef;

my @time  = localtime();
my $menu_filename = undef;
my $fake_filename = undef;
my $timeout = 20;
my $endl = "\r\n";  # this is preferable for http sockets to "\n"

GetOptions(
	"help|h|?"  => \&show_help,
	"version|V" => \&show_version,
	"info:s"    => \$info,
	"site=s"    => \$site,
	"name=s"    => \$name,
	"title=s"   => \$title,
	"item=s"    => \$itemf,
	"exec=s"    => \$execf,
	"command=s"    => \$commf,
	"icon-title=s" => \$icont,
	"icon-item=s"  => \$iconi,
	"icon-home=s"  => \$iconh,
	"icon-error=s" => \$icone,
	"wm-icons"  => \$wm_icons,
	"proxy=s"   => \$proxy,
	"frontpage:s" => \$frontpage,
	"file:s"    => \$menu_filename,
	"fake:s"    => \$fake_filename,
	"timeout=i" => \$timeout,
) || wrong_usage();
wrong_usage() if @ARGV;

if (defined $info) {
	if ($info) {
		my $_info = $site_info->{lc($info)};
		die "Unsupported site '$info'; try --info.\n" unless $_info;
		my $host0 = $_info->{'host0'} || $_info->{'host'};
		print
			"Site Name:\n\t$_info->{'name'}\n",
			"Home Page:\n\thttp://$_info->{'host'}/\n",
			"Headlines:\n\thttp://$host0$_info->{'path'}\n",
			"Headline fields:\n\t$_info->{'flds'}\n";
	} else {
		print "All supported sites:\n\t", join(", ", &get_all_site_names()),
			"\n\nSpecify a site name after --info to get a site headlines info.\n";
	}
	exit(0);
}

$site  ||= $default_site; $site = lc($site);
die "Unsupported site '$site'; try --info.\n" unless exists $site_info->{$site};
#$name ||= "MenuHeadlines$site_info->{$site}->{'name'}";
$name  ||= $site;
$title ||= "$site_info->{$site}->{'name'} Headlines";

my $site_name = $site_info->{$site}->{'name'};
my $site_host = $site_info->{$site}->{'host'};
my $site_path = $site_info->{$site}->{'path'};
my $site_func = $site_info->{$site}->{'func'};

$commf ||= "Exec $execf";

$title =~ s/\\t/\t/g;
$itemf =~ s/\\t/\t/g;
$commf =~ s/\\t/\t/g;

if ($wm_icons) {
	$icont ||= "";
	$iconi ||= "menu/information.xpm";
	$iconh ||= "menu/home.xpm";
	$icone ||= "menu/choice-no.xpm";
}

my $icont_str = $icont ? "%$icont%" : "";
my $iconi_str = $iconi ? "%$iconi%" : "";
my $iconh_str = $iconh ? "%$iconh%" : "";
my $icone_str = $icone ? "%$icone%" : "";

if (defined $proxy && $proxy =~ /^(.+):(\d+)$/) {
	$proxy = $1;
	$port = $2;
}

# Three cases:
#   1) no --file option or value '-' specified (STDOUT is used)
#   2) no or empty menu file in --file specified (the default name is used)
#   3) non-empty menu file specified (use it)
$menu_filename = undef if defined $menu_filename && $menu_filename eq '-';
if ($menu_filename) {
	$menu_filename =~ s:^~(/|$):$home$1:;
	$menu_filename =~ m:^(.+)/[^/]+$:; $work_home = $1 || ".";
} elsif (defined $menu_filename) {
	$menu_filename = "$work_home/$site.menu";
}

my $content = "";

$content .= qq(DestroyMenu $name\n);
$content .= qq(AddToMenu $name "$icont_str$title" Title\n);
local $error_menu_content = $content;

my $frontpage_entry = "";
if (defined $frontpage) {
	my $cmd = &expand_all_width_specifiers($commf, {'u' => "http://$site_host/"});
	$frontpage_entry = qq(+ "$iconh_str$site_name Frontpage" $cmd\n);
	$error_menu_content .= qq($frontpage_entry\n+ "" Nop\n);
}

$error_menu_content .= "+ `$icone_str<msg>` DestroyMenu $name\n";

if (defined $frontpage && $frontpage !~ /^b/) {
	$content .= qq($frontpage_entry\n+ "" Nop\n);
}

unless (defined $fake_filename) {
	$site_host = $site_info->{$site}->{'host0'}
		if defined $site_info->{$site}->{'host0'};
	my $redirect_depth = 0;

HTTP_CONNECTION:
	my $host = $proxy || $site_host;
	my $iaddr = inet_aton($host) || &die_net("Can't resolve host $host");
	my $paddr = sockaddr_in($port, $iaddr);
	my $proto = getprotobyname('tcp');

	local $SIG{ALRM} = sub { die "timeout\n"; };
	alarm($timeout);
	eval {
		socket(SOCK, PF_INET, SOCK_STREAM, $proto) &&
		connect(SOCK, $paddr)
	} || &die_net("Can't connect host $host");
	alarm(0);
	select(SOCK); $| = 1; select(STDOUT);

	# do http request
	my $http_headers = "$endl" .
		"Host: $site_host$endl" .
		"Connection: close$endl" .
		"User-Agent: fvwm-menu-headlines/$version$endl" .
		"Pragma: no-cache$endl" .
		"$endl";
	if (defined $proxy) {
		print SOCK "GET http://$site_host$site_path HTTP/1.1$http_headers";
	} else {
		print SOCK "GET $site_path HTTP/1.1$http_headers";
	}

	unless (read_line() =~ m{HTTP/1\.\d (\d+) \w+}) {
		&die_net("Invalid HTTP response from http://$site_host$site_path", 0);
	}
	my $status = $1;
	if ($status =~ /^301|302$/ && ++$redirect_depth < 5) {
		# redirection
		while (1) {
			my $line = read_line();
			$line =~ s/[\n\r]+$//s;
			last unless $line;
			if ($line =~ m{Location: http://([^/]+)(/.*)}i) {
				$site_host = $1;
				$site_path = $2;
				goto HTTP_CONNECTION;
			}
		}
	}
	&die_net("Unexpected HTTP response $status from http://$site_host$site_path", 0)
		unless $status eq "200";

	# skip http response headers
	while (read_line() !~ /^\r?\n?$/s) {}
} else {
	if ($fake_filename) {
		$fake_filename =~ s:^~(/|$):$home$1:;
	} else {
		$fake_filename = "$work_home/$site.in";
	}
	open(SOCK, "<$fake_filename") || &die_sys("Can't open $fake_filename");
}

my $entries = &$site_func;

close(SOCK) || &die_net("Error closing socket");

foreach (@$entries) {
	my $text = &expand_all_width_specifiers($itemf, $_);
	my $comm = &expand_all_width_specifiers($commf, $_);
	$text =~ s/"/\\"/g;
	$content .= qq(+ "$iconi_str$text" $comm\n);
}

if (defined $frontpage && $frontpage =~ /^b/) {
	$content .= qq(+ "" Nop\n$frontpage_entry);
}

if (defined $menu_filename) {
	unless (-d $work_home) {
		mkdir($work_home, 0775) || &die_sys("Can't create $work_home");
	}
	open(MENU_FILE, ">$menu_filename") || &die_sys("Can't open $menu_filename");
	print MENU_FILE $content;
	close(MENU_FILE) || &die_sys("Can't close $menu_filename");
} else {
	print $content;
}

exit();

# ---------------------------------------------------------------------------

sub read_line {
	local $SIG{ALRM} = sub { die "timeout\n"; };
	alarm($timeout);
	my $line = eval { <SOCK> };
	if ($@) {
		&die_net("Timeout of $timeout seconds reached") if $@ eq "timeout\n";
		&die_net($@);
	}
	alarm(0);
	print STDERR $line if $ENV{"DEBUG_DUMP_RESPONSE"};
	return $line;
}

sub read_all_lines {
	local $SIG{ALRM} = sub { die "timeout\n"; };
	alarm($timeout * 2);
	my $lines = eval { join('', <SOCK>) };
	if ($@) {
		&die_net("Timeout of $timeout seconds reached") if $@ eq "timeout\n";
		&die_net($@);
	}
	alarm(0);
	print STDERR $lines if $ENV{"DEBUG_DUMP_RESPONSE"};
	return $lines;
}

# make unix time from year (2001 or 101), mon (0..11), day, hour, min, sec
sub make_time {  # ($$$$$$$)
	my ($h_offset, $year, $mon, $day, $hour, $min, $sec) = @_;
	$h_offset ||= 0;
	my $type = $TIMEFIELDS_DATE_TIME;

	unless (defined $hour || defined $min) {
		unless ($year || $day) {
			$type = $TIMEFIELDS_NONE;
			return [ 0, $type ];
		} else {
			$type = $TIMEFIELDS_ONLY_DATE;
		}
	}

	$year = 1973 unless $year && $year > 0;  # it's my year :-)
	$mon  = 0 unless $mon && $mon > 0 && $mon <= 11;
	$day  = 1 unless $day && $day > 0 && $day <= 31;
	$hour = 12 unless $hour && $hour >= 0 && $hour < 24;
	$min  = 0 unless $min && $min >= 0 && $min < 60;
	$sec  = 0 unless $sec && $sec >= 0 && $sec < 60;

	return [
		timegm($sec, $min, $hour, $day, $mon, $year) - $h_offset * 60 * 60,
		$type
	];
}

sub set_entry_aliases_and_time ($$$$) {
	my $entry = shift;
	my $aliases = shift;
	my $time_func = shift;
	my $h_offset = shift;

	my ($alias, $orig);
	while (($alias, $orig) = each %$aliases) {
		$entry->{$alias} = !$orig ? "" :
			ref($orig) eq 'CODE' ? &{$orig}($entry) : $entry->{$orig};
		$entry->{$alias} = "" unless defined $entry->{$alias};
	}

	$entry->{'_'} = make_time($h_offset, &{$time_func}($entry->{'d'}));
}

BEGIN {
	$entity_map = {
		'gt'    => '>',
		'lt'    => '<',
		'quot'  => '"',
		'amp'   => '&',
	};
}

sub process_xml ($$$$) {
	my $entry_tag = shift;
	my $aliases = shift;
	my $time_func = shift;
	my $h_offset = shift;
	my @entries = ();

	my $doc = read_all_lines();

	ENTRY:
	foreach ($doc =~ m!<$entry_tag\b[^>]*>(.*?)</$entry_tag>!sg) {
		s/&amp;quot;/"/g;  # fix buggy html in some backends
		# replace &#039; with single quote and &quot; with double quote
		s/&(?:(\w+)|#(\d{2,})|#x([\da-fA-F]{2,4}));/
			$1 ? $entity_map->{$1} || "{$1}" : chr($2 || hex($3))
		/ge;

		my $entry = {};

		foreach (m!(<.*?>.*?</.*?>)!sg) {
			m!<(.*?)>\s*(.*?)\s*</(.*?)>!s;
			# ignore incorect fields or throw error?
			next unless $1 && $2 && $3;
			next if $1 ne $3;
			$entry->{$1} = $2;
		}

		set_entry_aliases_and_time($entry, $aliases, $time_func, $h_offset);
		push @entries, $entry;
	}
	return \@entries;
}

sub process_text ($$$$) {
	my $fields = shift;
	my $aliases = shift;
	my $time_func = shift;
	my $h_offset = shift;
	my @entries = ();

	ENTRY:
	while (1) {
		my $entry = {};
		foreach (@$fields) {
			my $line = read_line();
			last ENTRY unless defined $line;
			next if $_ eq '_ignore_';

			chomp($line);
			$line =~ s/"/\\"/g;
#			$line =~ s/<.*?>//g;
#			$line =~ s/&\w{1,5}?;/ /g;
			$entry->{$_} = $line;
		}

		set_entry_aliases_and_time($entry, $aliases, $time_func, $h_offset);
		push @entries, $entry;
	}
	return \@entries;
}

sub process_slashdot () {
	return process_xml(
		'story',
		{ 'h' => 'title', 'u' => 'url', 'd' => 'time' },
		sub ($) {
			$_[0] =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
			($1, ($2 || 0) - 1, $3, $4, $5, $6);
		}, +0,
	);
}

sub process_freshmeat () {
	return process_text(
		[ qw( headline date url ) ],
		{ 'h' => 'headline', 'u' => 'url', 'd' => 'date' },
		sub ($) {
			$_[0] =~ /^(?:\w+, )?(\w+) (\d+)\w* (\d+),? (\d+):(\d+)/;
			($3, $lmonth_hash{$1}, $2, $4, $5, 0);
		}, -5 + (abs((localtime())[4] - 5.5) < 3),
	);
}

sub process_linuxtoday () {
	my $line;
	while ($line = read_line()) {
		last if $line =~ /linuxtoday.com/;          # skip the text note
		last if $line =~ /&&/ and read_line() x 3;  # if it was replaced
	}
	return process_text(
		[ qw( _ignore_ headline url date ) ],
		{ 'h' => 'headline', 'u' => 'url', 'd' => 'date' },
		sub ($) {
			$_[0] =~ /(\w+) (\d+), (\d+), (\d+):(\d+):(\d+)/;
			($3, $smonth_hash{$1}, $2, $4, $5, $6);
		}, +0,
	);
}

sub process_segfault () {
	my $line;
	while ($line = read_line()) {
		last if $line =~ /^%%/;  # skip the text note
	}
	return process_text(
		[ qw( headline url date author_name author_email type _ignore_ ) ],
		{ 'h' => 'headline', 'u' => 'url', 'd' => 'date' },
		sub ($) {
			$_[0] =~ /(\d+) (\w+) (\d+):(\d+):(\d+) (\d+)/;
			($6, $smonth_hash{$2}, $1, $3, $4, $5);
		}, -8 + (abs((localtime())[4] - 5.5) < 3),
	);
}

sub process_poor_rdf () {
	return process_xml(
		'item',
		{ 'h' => 'title', 'u' => 'link', 'd' => undef },
		sub ($) {
			# this site's rdf does not supply the time, how weird...
			#(gmtime())[5,4,3,2,1,0];
			()
		}, +0,
	);
}

sub process_linuxapps_old () {
	return process_text(
		[ qw( headline date url ) ],
		{ 'h' => 'headline', 'u' => 'url', 'd' => 'date' },
		sub ($) {
			$_[0] =~ /(\w+) (\d+) (\d+):(\d+):(\d+) \w+ (\d+)/;
			($6, $smonth_hash{$1}, $2, $3, $4, $5);
		}, -5,
	);
}

sub process_kde_news () {
	my $link_to_time = sub ($) { $_[0]->{'link'} =~ m|/(\d+)/?$|; $1; };
	return process_xml(
		'item',
		{ 'h' => 'title', 'u' => 'link', 'd' => $link_to_time },
		sub ($) {
			(gmtime($_[0]))[5,4,3,2,1,0];
		}, +0,
	);
}

sub process_freekde () {
	my $link_to_date = sub ($) {
		$_[0]->{'link'} =~ m|/(\d\d/\d\d/\d\d)/|; $1 ? "20$1" : '';
	};
	return process_xml(
		'item',
		{ 'h' => 'title', 'u' => 'link', 'd' => $link_to_date },
		sub ($) {
			$_[0] =~ m|(\d+)/(\d+)/(\d+)|;
			($1, ($2 || 0) - 1, $3);
		}, +0,
	);
}

sub process_rootprompt () {
	my $title_stripped = sub ($) {
		$_[0]->{'title'} =~ /(.*) \([^\(\)]+\)$/ ? $1 : $_[0]->{'title'};
	};
	my $title_to_date = sub ($) {
		$_[0]->{'title'} =~ / \((\d+ \w{3} \d{4})\)$/; $1;
	};
	return process_xml(
		'item',
		{ 'h' => $title_stripped, 'u' => 'link', 'd' => $title_to_date },
		sub ($) {
			$_[0] =~ /(\d+) (\w+) (\d+)/;
			($3, $smonth_hash{$2}, $1);
		}, +0,
	);
}

sub process_kuro5hin () {
	my $link_to_date = sub ($) {
		$_[0]->{'link'} =~ m|/(\d\d\d\d/\d{1,2}/\d{1,2})/|; $1;
	};
	return process_xml(
		'item',
		{ 'h' => 'title', 'u' => 'link', 'd' => $link_to_date },
		sub ($) {
			$_[0] =~ m|(\d+)/(\d+)/(\d+)|;
			($1, ($2 || 0) - 1, $3);
		}, +0,
	);
}

sub process_linuxfr () {
	my $link_to_date = sub ($) {
		$_[0]->{'link'} =~ m|/(\d\d\d\d/\d\d/\d\d)/|; $1;
	};
	my $hack_for_url = sub ($) {
		# hack for mozilla -remote openURL
		my $u = $_[0]->{'link'};
		$u =~ s|,|\%2c|g; $u;
	};
	return process_xml(
		'item',
		{ 'h' => 'title', 'u' => $hack_for_url, 'd' => $link_to_date },
		sub ($) {
			$_[0] =~ m|(\d+)/(\d+)/(\d+)|;
			($1, ($2 || 0) - 1, $3);
		}, +0,
	);
}

sub process_linuxfr_old () {
	my $link_to_date = sub ($) {
		$_[0]->{'url'} =~ m|/(\d\d\d\d/\d\d/\d\d)/|; $1;
	};
	my $hack_for_url = sub ($) {
		# hack for mozilla -remote openURL
		my $u = $_[0]->{'url'};
		$u =~ s|,|\%2c|g; $u;
	};
	my $line;
	while ($line = read_line()) {
		last if $line =~ /^%%/;  # skip the text note
	}
	return process_text(
		[ qw( headline url author_name author_email type _ignore_ ) ],
		{ 'h' => 'headline', 'u' => $hack_for_url, 'd' => $link_to_date },
		sub ($) {
			$_[0] =~ m|(\d+)/(\d+)/(\d+)|;
			($1, ($2 || 0) - 1, $3);
		}, +0,
	);
}

sub process_cnn () {
	my $contents = read_all_lines();
	my @entries = ();

	my $link_to_date = sub ($) {
		$_[0]->{'url'} =~ m|/(\d\d\d\d).*?(/\d\d/\d\d)/|; "$1$2";
	};

	$contents =~ s{<a href="(/.*?)".*?>(.*?)</a>}{
		my $entry = {};
		$entry->{'url'} = "http://www.cnn.com$1";
		$entry->{'headline'} = $2;
		set_entry_aliases_and_time(
			$entry,
			{ 'h' => 'headline', 'u' => 'url', 'd' => $link_to_date },
			sub ($) {
				$_[0] =~ m|(\d+)/(\d+)/(\d+)|
					? ($1, ($2 || 0) - 1, $3)
					: ();
			}, -5,
		);
		push @entries, $entry;
		""
	}sige;

	return \@entries;
}

sub process_old_bbc () {
	my $contents = read_all_lines();
	$contents =~ s!\r\n...\r\n!!sg;  # they insert this randomly!
	$contents =~ s!\s*<(br|/h3|h3|span[^>]*|/span|img [^>]+)>[ \t\r]*\n?!!sig;
	my @entries = ();

	$contents =~ s{\s+<a href="(/[^"]+?)">\s*([^\s][^<]+?)\s*</a>\s*([^<]+?)\s*(?:\n|<br )}{
		my $entry = {};
		my $path = $1;
		$entry->{'headline'} = $2;
		$entry->{'abstract'} = $3;
		$path =~ s|^(/\d+)?/low/|$1/hi/|;
		$entry->{'url'} = "http://news.bbc.co.uk$path";
		set_entry_aliases_and_time(
			$entry,
			{ 'h' => 'headline', 'u' => 'url', 'd' => undef },
			sub ($) {
				();  # no time...
			}, +0,
		);
		push @entries, $entry;
		""
	}sige;

	return \@entries;
}

sub process_bcc () {
	read_all_lines() =~ /STORY 1\nHEADLINE Last update at (\d+:\d+)\nURL \n(.*)$/s;
	my ($time, $contents) = ($1, $2);
	die_net("Parse error. Did BBC site change format?", "") unless defined $time;
	my @entries = ();

	$contents =~ s{STORY (\d+)\nHEADLINE (.*?)\nURL (.*?)\n}{
		my $entry = {};
		my $date = undef;
		$entry->{'story'} = $1;
		my $headline = $2;
		my $url = $3;
		if ($headline =~ /^(.+?)  (\d+ \w+ \d+)$/) {
			$headline = $1;
			$date = $2 . " $time";
		}
		$entry->{'headline'} = $headline;
		$url =~ s|^(http://.*?/).*/-/(.*)$|$1$2|;
		$url = "http://news.bbc.co.uk/" if $url eq "";
		$entry->{'url'} = $url;
		$entry->{'date'} = $date;
		set_entry_aliases_and_time(
			$entry,
			{ 'h' => 'headline', 'u' => 'url', 'd' => 'date' },
			sub ($) {
				return () unless defined $_[0] &&
	         $_[0] =~ /^(\d+) (\w+) (\d+) (\d+):(\d+)/;
	         ($3, $lmonth_hash{$2}, $1, $4, $5);
			}, +0,
		);
		push @entries, $entry;
		""
	}sige;

	return \@entries;
}

# ---------------------------------------------------------------------------

sub die_sys ($) {
	my $msg = shift;
	$msg = "$0: $msg: [$!]\n";

	print STDERR $msg
#		# be quiet in non interactive shells?
#		if ($ENV{'SHLVL'} || 0) == 1 || defined($ENV{'PS1'})
		;
	exit(-1);
}

sub die_net ($;$) {
	my $msg = shift;
	my $check_network_msg = @_ ? "" : "; check network connection";

	#die_sys($msg);
	$error_menu_content =~ s/<msg>/$msg$check_network_msg/;
	print $error_menu_content;
	exit(-1);
}

# like strftime, but gets unix time, instead of sec/min/hour/day/mon/year.
sub format_time ($$) {
	my ($fmt, $time_pair) = @_;

	$time_pair = [] unless ref($time_pair) eq 'ARRAY';
	my ($time, $type) = @$time_pair;
	$time ||= time();
	$type ||= $TIMEFIELDS_NONE;

	if ($type == $TIMEFIELDS_NONE) {
		return "";
	} elsif ($type == $TIMEFIELDS_ONLY_DATE) {
		$fmt =~ s/[:\. -]?%[HIklMprSTX][:\. -]?//g;
		$fmt =~ s/%c/%a %b %d %Z %Y/g;
	}

	return strftime($fmt, localtime($time));
}

# Substitutes all %N1*N2x in $name by properly stripped and justified $values.
# $name example: %[%d %b %y %H:%M], %*-7(some text), %-32*30h, %{url}.
# $values is a hash of named values to substitute.
sub expand_all_width_specifiers ($$) {
	my ($name, $values) = @_;
	$name =~ s/%(-?\d+)?(\*(-?)(\d+))?(\w|{\w+}|\(.*?\)|\[.*?\])/
		my $tag = substr($5, 0, 1);
		my $arg = length($5) == 1 ? $5 : substr($5, 1, -1);
		my $value =
			$tag eq '(' ? $arg :
			$tag eq '[' ? format_time($arg, $values->{'_'}) :
			$values->{$arg};
		$value = "(%$5 is not defined)" unless defined $value;
		$value = !$2 || $4 <= 3 || $4 > length($value) ? $value : $3?
			"..." . substr($value, -$4 + 3, $4 - 3):
			substr($value, 0, $4 - 3) . "...";
		$1 ? sprintf("%$1s", $value) : $value;
	/ge;
	return $name;
}

sub get_all_site_names () {
	return sort map { $site_info->{$_}->{'name'} } keys %$site_info;
}

sub show_help {
	$site  ||= $default_site;
	#$name ||= "MenuHeadlines$site_info->{$site}->{'name'}";
	$name  ||= $site;
	$title ||= "$site_info->{$site}->{'name'} Headlines";

	print "A perl script which builds headlines menu for fvwm.\n";
	print "Supported sites: ", join(', ', get_all_site_names()), "\n\n";
	print "Usage: $0 [OPTIONS]\n";
	print "Options:\n";
	print "\t--help           show this help and exit\n";
	print "\t--version        show the version and exit\n";
	print "\t--info=[NAME]    information about a site\n";
	print "\t--site=NAME      headlines site, default is $site\n";
	print "\t--name=NAME      menu name,  default is '$name'\n";
	print "\t--title=NAME     menu title, default is '$title'\n";
	print "\t--item=FORMAT    menu item format, default is '$itemf'\n";
	print "\t--exec=FORMAT    exec command, default is {$execf}\n";
	print "\t--command=FORMAT fvwm command, default is no\n";
	print "\t--icon-title=XPM menu title icon, default is no\n";
	print "\t--icon-item=XPM  menu item  icon, default is no\n";
	print "\t--icon-home=XPM  menu home  icon, default is no\n";
	print "\t--icon-error=XPM menu error icon, default is no\n";
	print "\t--wm-icons       define icon names to use with wm-icons\n";
	print "\t--frontpage[=V]  show frontpage item; values: top, bottom\n";
	print "\t--proxy=host[:port] specify proxy host and port (80)\n";
	print "\t--file[=FILE]    menu file, default is $work_home/$site.menu\n";
	print "\t--fake[=FILE]    don't connect, read input from file\n";
	print "\t--timeout=SECS   timeout for a line reading from a socket\n";
	print "Short options are ok if not ambiguous: -h, -t.\n";
	exit 0;
}

sub show_version {
	print "$version\n";
	exit 0;
}

sub wrong_usage {
	print STDERR "Try '$0 --help' for more information.\n";
	exit -1;
}

__END__

# ---------------------------------------------------------------------------

=head1 NAME

fvwm-menu-headlines - builds headlines menu definition for fvwm

=head1 SYNOPSIS

B<fvwm-menu-headlines>
[ B<--help>|B<-h>|B<-?> ]
[ B<--version>|B<-V> ]
[ B<--info> [site] ]
[ B<--site>|B<-s> site ]
[ B<--name>|B<-n> name ]
[ B<--title>|B<-t> title ]
[ B<--item> item ]
[ B<--exec>|B<-e> exec-command ]
[ B<--command>|B<-e> fvwm-command ]
[ B<--icon-title> icon ]
[ B<--icon-item> icon ]
[ B<--icon-home> icon ]
[ B<--icon-error> icon ]
[ B<--wm-icons> ]
[ B<--frontpage> [where] ]
[ B<--proxy>|B<-p> host:port ]
[ B<--file> [file] ]
[ B<--fake> [file] ]
[ B<--timeout> seconds ]

=head1 DESCRIPTION

This configurable perl script builds an fvwm menu definition for headlines
of popular news web sites: FreshMeat, Slashdot, LinuxToday,
DaemonNews, GNOME-News, KDE-News, RootPrompt, LinuxFr, ThinkGeek,
CNN, BBC and more.

It is possible to specify a customized menu item format, change a command
(usually launching a browser) and add menu icons (there is a support for
the wm-icons package).

=head1 OPTIONS

=over 4

=item B<--help>

show the help and exit

=item B<--version>

show the version and exit

=item B<--info> [site]

if site name is given print the site specific info,
otherwise print all site names

=item B<--site> site

defile a web site, headlines of which to show, this option
also can be used together with --help to get new defaults.
Default site: freshmeat.

=item B<--name> name

define menu name (default is "MenuHeadlinesFreshmeat")

=item B<--title> title

define menu title (default is "Freshmeat Headlines").

=item B<--item> label-format

=item B<--exec> command-format

define format for menu item or command (what is shown and what is
executed when the item is chosen).
Default label is '%h\t%[(%Y-%m-%d %H:%M)]'.
TAB can be specified as '\t', but in .fvwm2rc you should specify a double
backslash or a real TAB.

Format specifiers for a headline format:

  %h - headline
  %u - url
  %d - date in the native format (that site backend supplied)
  %[strftime-argument-string] - date/time, see strftime(3)
    the date/time is represented according to the local time;
    date and/or time fields that can't be guessed are stripped
    Example: %[|%d %B %Y| %H:%M %S]
      If site supplied only date - this becomes %[|%d %B %Y|],
      if site supplied no date - this becomes an empty string.
  %{name} - site specific named value, like %{comments}
  %(text) - arbitrary text, good for escaping or aligning

These specifiers can receive an optional integer size, positive for right
adjusted string or negative for left adjusted, example: %8x; and optional
*num or *-num, which means to leave only the first or last (if minus) num of
chars, the num must be greater than 3, since the striped part is replaced
with "...", example: %*30x. Both can be combined: %-10*-20x, this instructs to
get only the 20 last characters, but if the length is less then 10 - to fill
with up to 10 spaces on the right.

Example:

  --exec "iceweasel -remote 'openURL(%u, new-window)' || iceweasel '%u'"

=item B<--command> command-format

like B<--exec> above, but enables to specify any fvwm command,
for example, "Function FuncFvwmShowURL '%u'" not only Exec.

In fact, --exec="mozilla '%u'" is equivalent
to --command="Exec mozilla '%u'"

=item B<--icon-title> icon

=item B<--icon-item> icon

=item B<--icon-home> icon

=item B<--icon-error> icon

define menu icon for title, regular item, frontpage item and error item
respectively. Default is no menu icons (equivalent to an empty icon argument).

=item B<--wm-icons>

define icon names suitable for use with wm-icons package.
Currently this is equivalent to: --icon-title '' --icon-item
menu/information.xpm --icon-home menu/home.xpm --icon-error menu/choice-no.xpm.

=item B<--frontpage> [where]

add the site frontpage item to the menu.
Optional value can be used to specify where this item will be placed in
the menu - 'top' or 't', 'bottom' or 'b'.

=item B<--proxy> host[:port]

define a proxy to use.
Example: --proxy proxy.inter.net:3128

=item B<--file> [file]

write the menu output to specified file. If no filename is
given with this option (or empty filename), the default filename
WORK_HOME/SITE.menu is used. Without this option or with '-'
filename, the menu output is written to standard output.

=item B<--fake> [file]

don't connect to the host using HTTP protocol, instead,
read from WORK_HOME/SITE.in file. The following reads input from
freshmeat.in (downloaded http://freshmeat.net/backend/recentnews.txt) and
saves output to segfault.menu (both files are in WORK_HOME):
  fvwm-menu-headlines --site freshmeat --fake --file

=item B<--timeout> seconds

limit a line reading from a socket to this timeout,
the default timeout is 20 seconds.

=back

WORK_HOME of this script is ~/.fvwm/.fvwm-menu-headlines.
It is created if needed.

Option parameters can be specified either using '=' or in the next argument.
Short options are ok if not ambiguous: C<-h>, C<-t>; but be careful with
short options, what is now unambiguous, can become ambiguous in the next
versions.

=head1 USAGE

1. One of the ways to use this script is to define a crontab
entry to run the script every hour or so for every monitored site:

  0,30 * * * * fvwm-menu-headlines --file --site freshmeat
  1,31 * * * * fvwm-menu-headlines --file --site linuxtoday
  2,32 * * * * fvwm-menu-headlines --file --site slashdot

Then add these lines to your fvwm configuration file:

  DestroyFunc FuncFvwmMenuHeadlines
  AddToFunc   FuncFvwmMenuHeadlines
  + I Read "$HOME/.fvwm/.fvwm-menu-headlines/$0.menu"

  DestroyMenu MenuHeadlines
  AddToMenu   MenuHeadlines "Headlines" Title
  + MissingSubmenuFunction FuncFvwmMenuHeadlines
  + "FreshMeat"  Popup freshmeat
  + "LinuxToday" Popup linuxtoday
  + "Slashdot"   Popup slashdot

2. Another way to use this script (only if you have fast network/proxy) is to
run it every time you want to open your Headlines submenus.
(Note, the submenu that is once created is not reloaded, use "Reset all".)

In this case your fvwm configuration lines could be:

  DestroyFunc FuncFvwmMenuHeadlines
  AddToFunc   FuncFvwmMenuHeadlines
  + I PipeRead "fvwm-menu-headlines --site $0"
  #+ I Schedule 900000 DestroyMenu $0  # reset generated menu in 15 minutes

  DestroyMenu MenuHeadlines
  AddToMenu   MenuHeadlines "Headlines" Title
  + MissingSubmenuFunction FuncFvwmMenuHeadlines
  + "FreshMeat"  Popup freshmeat
  + "Slashdot"   Popup slashdot
  + "LinuxToday" Popup linuxtoday
  + "GNOME News" Popup gnome-news
  + "KDE News"   Popup kde-news
  + "" Nop
  + "Reset all"  FuncResetHeadlines

  DestroyFunc FuncResetHeadlines
  AddToFunc   FuncResetHeadlines
  + I DestroyMenu freshmeat
  + I DestroyMenu linuxtoday
  + I DestroyMenu slashdot
  + I DestroyMenu gnome-news
  + I DestroyMenu kde-news

And finally, add "Popup MenuHeadlines" somewhere.

3. Here is a usual usage. Use FvwmConsole or FvwmCommand to run fvwm commands
from a shell script. Every time you want headlines from some site, execute
(give any additional options if you want):

  PipeRead "fvwm-menu-headlines --site newsforge --name MenuHeadlinesNewsForge"
  # this may take several seconds, you may use: BusyCursor Read true
  Popup MenuHeadlinesNewsForge

=head1 HOW TO ADD SITE HEADLINES

It is possible to add user defined site headlines without touching the script
itself. Put your perl extensions to the file WORK_HOME/extension.pl.
For each site add something similar to:

  $site_info->{'myslashdot'} = {
    'name' => "MySlashdot",
    'host' => "myslashdot.org",
    'path' => "/myslashdot.xml",
    'func' => \&process_my_slashdot,
    # the following string is only used in --info
    'flds' => 'time, title, department, topic, author, url',
  };

  sub process_my_slashdot () {
    return process_xml(
      'story',
      # mandatory 'h', 'u' and 'd' aliases or undef
      { 'h' => 'title', 'u' => 'url', 'd' => 'time' },
      sub ($) {  # convert 'd' string to (y, m, d, H, M, S)
        $_[0] =~ /(\d+)-(\d+)-(\d+) (\d+):(\d+):(\d+)/;
        ($1, ($2 || 0) - 1, $3, $4, $5, $6);
      }, +0,  # timezone offset; already in UTC
    );
  }

  1;

=head1 AUTHORS

This script is inspired by WMHeadlines v1.3 by:

  Jeff Meininger <jeffm@boxybutgood.com>
  (http://rive.boxybutgood.com/WMHeadlines/).

Reimplemented for fvwm and heavily enhanced by:

  Mikhael Goikhman <migo@homemail.com>, 16 Dec 1999.

=head1 COPYING

The script is distributed by the same terms as fvwm itself.
See GNU General Public License for details.

=head1 BUGS

I try to keep all supported site info up to date, but sites often go down,
change their backend formats, change their httpd responses, just stop to
post news and so on; the script in the latest cvs may be more up to date.

The headline times may be off by one hour or more, since the time is
displayed for your local time zone, and the time zone of the original time
in the site backend output is often guessed (sometimes incorrectly);
similarly it is guessed whether to apply the daylight saving correction.

Report bugs to fvwm-bug@fvwm.org.

=cut

# ===========================================================================