Context Navigation

shepherd @ 293

Revision 293, 35.2 kB (checked in by lincoln, 7 years ago)
begin seperation of admin_status from operational status (laststatus)
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	my $myprogname = 'shepherd';
4	my $progname = 'shepherd';
5	my $version = '0.3.30';
6
7	# tv_grab_au
8	# "Shepherd"
9	# A wrapper for various Aussie TV guide data grabbers
10	#
11	# Use --help for command-line options.
12	#
13	# Shepherd is an attempt to reconcile many different tv_grab_au scripts and
14	# make one cohesive reliable data set. It works by calling a series of
15	# scripts that grab data from a large variety of sources, and then
16	# analysing the resulting XML data sets and determining which of the many
17	# is the most reliable.
18
19	# Shepherd runs in 4 passes:
20	# pass 1: (app/shepherd) Checks that all components are up-to-date, auto-
21	# updates if not.
22	# Passes control onto shepherd
23	# pass 2: (engine/dog) calls grabbers to fill in missing data
24	# pass 3: (engine/dog) calls reconciler to reconcile overlapping data
25	# and normalize programme titles to our preferred title
26	# pass 4: (engine/dog) calls postprocessors to postprocess data
27	# (e.g. flag HDTV programmes, augment with IMDb etc.)
28
29	# Changelog:
30	# 0.2.31 : split tv_grab_au (install/test/upgrade/enable/disable) from
31	# shepherd (grab/reconcile/postprocess). Previous changelog history
32	# is in shepherd
33	# 0.3.0 : This split deserves a real version bump, Linc! :)
34	# 0.3.1 : honour $option_ready
35	# 0.3.10 : split out into apps directory, renamed back to 'shepherd' with
36	# an auto symlink to tv_grab_au
37	# logging to logs/ directory
38
39	BEGIN { *CORE::GLOBAL::die = \&my_die; }
40
41	use strict;
42	no strict 'refs';
43
44	# ---------------------------------------------------------------------------
45	# --- required perl modules
46	# ---------------------------------------------------------------------------
47
48	&require_module("Cwd", qw(realpath));
49	&require_module("LWP::UserAgent");
50	&require_module("Getopt::Long");
51	&require_module("Data::Dumper");
52	&require_module("XMLTV::Ask");
53	&require_module("POSIX", qw(strftime mktime getcwd));
54	&require_module("Compress::Zlib");
55
56	# ---------------------------------------------------------------------------
57	# --- Global Variables
58	# ---------------------------------------------------------------------------
59
60	my $HOME = 'http://www.whuffy.com/shepherd';
61
62	# By default, Shepherd runs from ~/.shepherd/. If it's not run as a user,
63	# it will try /opt/shepherd/ instead.
64	my $CWD = ($ENV{HOME} ? $ENV{HOME} . "/." : "/opt/") . $progname;
65	-d $CWD or mkdir $CWD or die "Cannot create directory $CWD: $!";
66	chdir($CWD);
67
68	my $ARCHIVE_DIR = "$CWD/archive";
69	my $LOG_DIR = "$CWD/log";
70
71	my @options;
72	my $opt = {};
73	my $pref_title_source;
74	my $mirror_site;
75	my $debug = 0;
76	my $components = { };
77	my $components_pending_install = { };
78	my $region;
79	my $channels;
80	my $opt_channels;
81	my $config_file = "$CWD/$progname.conf";
82	my $channels_file = "$CWD/channels.conf";
83	my $log_file = "$progname.log";
84
85	my $invoked = get_full_path($0);
86
87	# OBSOLETE: will be removed
88	my $preferred;
89	my $title_translation_table;
90	my $pref_order;
91
92	# ---------------------------------------------------------------------------
93	# --- Setup
94	# ---------------------------------------------------------------------------
95
96	&get_command_line_options;
97
98	&capabilities if ($opt->{capabilities});
99	&description if ($opt->{description});
100
101	$\| = 1;
102	print "$myprogname v$version\n\n";
103
104	exit if ($opt->{version});
105	&help if ($opt->{help});
106
107	&check_user;
108
109	&read_config_file;
110	&read_channels_file;
111	&open_logfile unless ($opt->{nolog});
112
113	if ($opt->{status})
114	{
115	&status;
116	exit;
117	}
118
119	if ($opt->{'show-config'})
120	{
121	&show_config;
122	exit;
123	}
124
125	if ($opt->{'show-channels'})
126	{
127	&show_channels;
128	exit;
129	}
130
131	&process_setup_commands;
132
133	# ---------------------------------------------------------------------------
134	# --- Update
135	# ---------------------------------------------------------------------------
136
137	unless ($opt->{noupdate})
138	{
139	if (&update())
140	{
141	&write_config_file;
142	}
143	}
144
145	if ($opt->{configure})
146	{
147	&configure;
148	}
149
150	# ---------------------------------------------------------------------------
151	# --- Go!
152	# ---------------------------------------------------------------------------
153
154	unless ($opt->{update})
155	{
156	write_config_file();
157	my $shepexec = query_filename('dog', 'engine'); # really shouldn't hardcode 'dog'..
158	&log("Passing control to Engine: $shepexec @options\n");
159
160	call_prog("$shepexec @options",0);
161	}
162
163	&log("Done.\n");
164	&close_logfile() unless $opt->{nolog};
165
166	# ---------------------------------------------------------------------------
167	# --- Subroutines
168	# ---------------------------------------------------------------------------
169
170	# -----------------------------------------
171	# Subs: Updates & Installations
172	# -----------------------------------------
173
174	sub update
175	{
176	my $wanted_prog = get_full_path(query_filename('shepherd','application'));
177	if (($invoked ne $wanted_prog) && (!$opt->{configure}))
178	{
179	if (-e $wanted_prog)
180	{
181	&log("\n* Restarting ($invoked invoked, $wanted_prog wanted) *\n\n");
182	&close_logfile unless $opt->{nolog};
183	$ENV{shepherd_restart} = $invoked;
184	exec("$wanted_prog @options");
185	# This exits.
186	exit(0);
187	}
188
189	&log("\nWARNING: you should really be running ".ucfirst($progname)."\n".
190	" as '".query_filename('shepherd','application')."'\n".
191	" rather than '$invoked'!\n".
192	" Auto-update has been disabled until you fix this!\n\n");
193	&countdown();
194	&log("\nSkipped auto-update.\n\n");
195	return 0;
196	}
197
198	&log("\nChecking for updates:\n\n");
199
200	my $data = fetch_shepherd_file("status");
201
202	return 0 unless ($data);
203
204	my $made_changes = 0;
205	my %clist = %$components;
206
207	while ($data =~ /(\S+)\s+(\S+)\s+(\S+)/g)
208	{
209	my ($progtype, $proggy, $latestversion) = ($1,$2,$3);
210	if (update_component($proggy, $latestversion, $progtype))
211	{
212	$made_changes = 1;
213	}
214	delete $clist{$proggy};
215	}
216
217	# work out what components disappeared (if any)
218	foreach (keys %clist) {
219	unless ($components->{$_}->{disabled}) {
220	&log("\nDeleted component: $_.\n");
221	disable($_, 2);
222	$made_changes = 1;
223	}
224	}
225	$made_changes;
226	}
227
228	sub update_component
229	{
230	my ($proggy, $latestversion, $progtype) = @_;
231
232	my $ver = 0;
233	$ver = $components->{$proggy}->{ver} if (defined $components->{$proggy} and -e query_filename($proggy,$progtype));
234
235	my $result = versioncmp($ver, $latestversion);
236	my $action = $result == -1 ? ($ver ? "UPGRADING" : "NEW") :
237	$result == 1 ? "DOWNGRADING" :
238	"up to date";
239	&log(sprintf "* %-55s%16s\n",
240	ucfirst($progtype) . " $proggy" .
241	($ver ? " v$ver" : '') . "...",
242	$action);
243	return 0 unless ($result);
244	install($proggy, $latestversion, $progtype, $ver);
245	return 1;
246	}
247
248	sub install
249	{
250	my ($proggy, $latestversion, $progtype, $oldver) = @_;
251	my $config;
252
253	my $rdir = "";
254	my $basedir = $CWD."/".$progtype."s";
255	my $ldir = query_ldir($proggy, $progtype);
256
257	-d $basedir or mkdir $basedir or die "Cannot create directory $basedir: $!\n";
258	-d $ldir or mkdir $ldir or die "Cannot create directory $ldir: $!\n";
259	my $newfile = "$ldir/$proggy-$latestversion";
260
261	$rdir = $progtype . 's';
262	my $rfile = "$rdir/$proggy";
263
264	# have we previously downloaded it but haven't been able to install it
265	# (due to a failed test or failed dependencies or something like that)?
266	if ((-e "$newfile") && (-s "$newfile") && (defined $components_pending_install->{$proggy})) {
267	&log("Appear to have previously downloaded $proggy v$latestversion.\n");
268	$config = $components_pending_install->{$proggy}->{config};
269	} else {
270	&log("Downloading $proggy v$latestversion.\n");
271	return unless (fetch_shepherd_file($rfile, $newfile));
272
273	# Make component executable
274	chmod 0755,$newfile;
275	}
276
277	$rfile .= ".conf";
278	$config = fetch_shepherd_file($rfile) if (!defined $config);
279	return unless ($config); # everyone MUST have config files
280
281	eval $config;
282	if ($@) {
283	&log("Config file $rfile was invalid, not updating this component: $@\n");
284	return;
285	}
286
287	# test that the component works BEFORE we install it
288	my $ready_test = test_proggy("$proggy", $progtype, $latestversion);
289	if (!$ready_test) {
290	&log("$proggy v$latestversion failed ready test - marking as a pending update.\n");
291	$components_pending_install->{$proggy}->{config} = $config;
292	$components_pending_install->{$proggy}->{updated} = time;
293
294	if (defined $components->{$proggy}) {
295	$components->{$proggy}->{admin_status} = sprintf "update to version %s pending: %s",
296	$latestversion, $components_pending_install->{$proggy}->{admin_status};
297	}
298
299	return;
300	}
301
302	$components->{$proggy}->{ready} = $ready_test;
303
304	-d $ARCHIVE_DIR or mkdir $ARCHIVE_DIR or die "Cannot create directory $ARCHIVE_DIR: $!\n";
305
306	rename("$ldir/$proggy", "$ARCHIVE_DIR/$proggy-$oldver") if (-e "$ldir/$proggy");
307	rename($newfile, "$ldir/$proggy");
308
309	&log("Installed $proggy v$latestversion.\n") if ($debug);
310
311	$components->{$proggy}->{type} = $progtype;
312	$components->{$proggy}->{ver} = $latestversion;
313	$components->{$proggy}->{config} = $config;
314	$components->{$proggy}->{updated} = time;
315	$components->{$proggy}->{admin_status} = sprintf "updated from %s to %s", $oldver, $latestversion;
316	delete $components_pending_install->{$proggy} if (defined $components_pending_install->{$proggy});
317
318	# if the update was for the main app, restart it
319	if ($proggy eq $myprogname) {
320	&write_config_file;
321
322	# special case for main app - we create a symlink also
323	unlink("$CWD/tv_grab_au","$CWD/shepherd");
324	eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/tv_grab_au"); 1 };
325	eval { symlink($progtype.'s/'.$proggy.'/'.$proggy,"$CWD/shepherd"); 1 };
326
327	&log("\n* Restarting *\n\n");
328	&close_logfile unless $opt->{nolog};
329	$ENV{shepherd_restart} = $invoked;
330	exec("$ldir/$proggy @options"); # this exits
331	exit(0);
332	}
333
334	# If this component was disabled automatically, re-enable it.
335	# But if it was disabled manually, leave it off.
336	my $d = $components->{$proggy}->{disabled};
337	if ($d and $d == 2)
338	{
339	enable($proggy);
340	}
341	}
342
343	sub fetch_shepherd_file
344	{
345	my ($fn, $store) = @_;
346
347	my $sites = "";
348	$sites = "$mirror_site," if ($mirror_site);
349	$sites .= $HOME;
350
351	my $ret;
352	foreach my $site (split(/,/,$sites))
353	{
354	$ret = fetch_file("$site/$fn", $store, 1);
355	return $ret if ($ret);
356	}
357	return undef;
358	}
359
360	sub test_proggy
361	{
362	my ($proggy, $progtype, $specific_version) = @_;
363
364	&log("Testing $proggy...\n");
365
366	my $ldir = query_ldir($proggy, $progtype);
367	my $progname = query_filename($proggy, $progtype);
368	$progname .= "-".$specific_version if ((defined $specific_version) && ($specific_version ne ""));
369
370	my $opt_ready = query_config($proggy, 'option_ready');
371	$opt_ready \|\|= '--version';
372
373	chdir($ldir);
374	my ($result,$test_output) = call_prog($progname . " $opt_ready" . " 2>&1",1);
375	chdir ($CWD);
376
377	&log("Return value: $result\n") if ($debug);
378
379	my $statusmsg;
380
381	if ($result)
382	{
383	&log("\n" . ucfirst($progtype) . " $proggy did not exit cleanly!\n" .
384	"It may require configuration.\n");
385
386	# set proggy status accordingly
387	$statusmsg = sprintf "FAILED (return code %d) on %s", $result, POSIX::strftime("%a%d%b%y", localtime(time));
388
389	# can we give any more details on why it failed?
390	if ($test_output =~ /Can't locate (.*) in \@INC/) {
391	my $modname = $1;
392	$modname =~ s#/#::#g; # turn / into ::
393	$modname =~ s#\.pm##g; # remove .pm suffix
394	$statusmsg .= ": missing '".$modname."' module.";
395
396	&log("Probably failued due to dependency on missing module '".$modname."'\n");
397	}
398
399	&log("\n");
400	}
401	else
402	{
403	&log("OK.\n");
404
405	# mark as successful but only if previously unsuccessful
406	# (we only mark it if it was previously unsuccessful otherwise a --check
407	# will result in clearing out all of the admin_status fields)
408	$statusmsg = sprintf "tested successfully on %s", POSIX::strftime("%a%d%b%y", localtime(time))
409	if ((defined $components->{$proggy}->{ready}) && (!$components->{$proggy}->{ready}));
410	}
411
412	# update status message
413	if ((defined $statusmsg) && ($statusmsg ne "")) {
414	if ((defined $specific_version) && ($specific_version ne "")) {
415	$components_pending_install->{$proggy}->{admin_status} = $statusmsg;
416	} else {
417	$components->{$proggy}->{admin_status} = $statusmsg;
418	}
419	}
420
421	return !$result;
422	}
423
424	sub enable
425	{
426	my $proggy = shift;
427
428	# confirm it exists first
429	if (!$components->{$proggy}) {
430	&log("No such component: \"$proggy\".\n");
431	return;
432	}
433
434	&log("Enabling $proggy.\n");
435
436	delete $components->{$proggy}->{disabled};
437	$components->{$proggy}->{admin_status} = sprintf "enabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
438	}
439
440	sub disable
441	{
442	my ($proggy, $n) = @_;
443
444	# confirm it exists first
445	if (!$components->{$proggy}) {
446	&log("No such component: \"$proggy\".\n");
447	return;
448	}
449
450	if (($components->{$proggy}->{type} eq "application") \|\| ($components->{$proggy}->{type} eq "engine")) {
451	&log("Can't disable component: \"$proggy\".\n");
452	return;
453	}
454
455	&log("Disabling $proggy.\n");
456
457	$n \|\|= 1;
458	$components->{$proggy}->{disabled} = $n;
459	$components->{$proggy}->{admin_status} = sprintf "manually disabled on %s",POSIX::strftime("%a%d%b%y", localtime(time));
460	}
461
462	sub check
463	{
464	my $result;
465
466	foreach my $proggy (keys %$components) {
467	my $progtype = $components->{$proggy}->{type};
468	my $try_count = 0;
469
470	RETRY:
471	$try_count++;
472	$result = test_proggy($proggy, $components->{$proggy}->{type});
473	$components->{$proggy}->{ready} = $result;
474
475	if ((!$result) && ($try_count < 2) && (query_config($proggy, 'option_config'))) {
476	&log("Trying to configure '$proggy'\n");
477
478	chdir(query_ldir($proggy, $progtype));
479	system(query_filename($proggy, $progtype) . " ". query_config($proggy, 'option_config') . " 2>&1");
480	chdir ($CWD);
481
482	goto RETRY;
483	}
484	}
485	}
486	# -----------------------------------------
487	# Subs: Utilities
488	# -----------------------------------------
489	#
490
491	# versioncmp from Sort::Versions by Kenneth J. Albanowski
492	sub versioncmp( $$ ) {
493	my @A = ($_[0] =~ /([-.]\|\d+\|[^-.\d]+)/g);
494	my @B = ($_[1] =~ /([-.]\|\d+\|[^-.\d]+)/g);
495
496	my ($A, $B);
497	while (@A and @B) {
498	$A = shift @A;
499	$B = shift @B;
500	if ($A eq '-' and $B eq '-') {
501	next;
502	} elsif ( $A eq '-' ) {
503	return -1;
504	} elsif ( $B eq '-') {
505	return 1;
506	} elsif ($A eq '.' and $B eq '.') {
507	next;
508	} elsif ( $A eq '.' ) {
509	return -1;
510	} elsif ( $B eq '.' ) {
511	return 1;
512	} elsif ($A =~ /^\d+$/ and $B =~ /^\d+$/) {
513	if ($A =~ /^0/ \|\| $B =~ /^0/) {
514	return $A cmp $B if $A cmp $B;
515	} else {
516	return $A <=> $B if $A <=> $B;
517	}
518	} else {
519	$A = uc $A;
520	$B = uc $B;
521	return $A cmp $B if $A cmp $B;
522	}
523	}
524	@A <=> @B;
525	}
526
527	sub get_full_path
528	{
529	my $path = shift;
530	my $real = realpath($path);
531	return $path if (!$real);
532	return $real;
533	}
534
535	sub require_module
536	{
537	my ($mod, @imports) = @_;
538
539	my $modname = $mod.".pm";
540	$modname =~ s/::/\//g;
541
542	eval { require $modname; };
543	if ($@) {
544	printf STDERR "\nERROR:\nMandatory module '%s' not found.\n\n",$mod;
545	printf STDERR "Please see the Wiki at http://svn.whuffy.com/index.fcgi/wiki/Installation\n";
546	printf STDERR "for details on how to install this module.\n";
547	exit(1);
548	}
549
550	import $mod @imports;
551	}
552
553	# check that user isn't root, warn them if they are!
554	sub check_user
555	{
556	if ($< == 0) {
557	printf STDERR "WARNING:\n You are running ".ucfirst($progname).
558	" as 'root' super-user.\n".
559	" It is HIGHLY RECOMMENDED that you set your system to run ".
560	ucfirst($progname)."\n from within a normal user account!\n\n".
561	"You may wish to CTRL-C and fix this.\n".
562	"Continuing in: ";
563	foreach (1 .. 10)
564	{
565	printf STDERR " " . (11 - $_);
566	sleep 1;
567	}
568	printf STDERR "\n";
569	}
570	}
571
572	sub query_grabbers
573	{
574	my ($conf, $val) = @_;
575	return query_component_type('grabber',$conf,$val);
576	}
577
578	sub query_reconcilers
579	{
580	return query_component_type('reconciler');
581	}
582
583	sub query_postprocessors
584	{
585	return query_component_type('postprocessor');
586	}
587
588	sub query_component_type
589	{
590	my ($progtype,$conf,$val) = @_;
591
592	my @ret = ();
593	foreach (keys %$components)
594	{
595	if ($components->{$_}->{type} eq $progtype) {
596	if (defined $conf) {
597	push (@ret, $_) if (query_config($_,$conf) eq $val);
598	} else {
599	push (@ret, $_);
600	}
601	}
602	}
603	return @ret;
604	}
605
606	sub query_name
607	{
608	my $str = shift;
609	if ($str =~ /(.*) \[cache\]/)
610	{
611	return $1;
612	}
613	return $str;
614	}
615
616	sub query_filename
617	{
618	my ($proggy, $progtype) = @_;
619	return query_ldir($proggy,$progtype).'/'.$proggy;
620	}
621
622	sub query_ldir
623	{
624	my ($proggy, $progtype) = @_;
625	return $CWD.'/'.$progtype.'s/'.$proggy;
626	}
627
628	sub query_config
629	{
630	my ($grabber, $key) = @_;
631
632	$grabber = query_name($grabber);
633	return undef unless ($components->{$grabber});
634	return $components->{$grabber}->{config}->{$key};
635	}
636
637	sub countdown
638	{
639	my $n = shift;
640
641	$n \|\|= 10;
642	print "You may wish to CTRL-C and fix this.\n\nContinuing anyway in:";
643	foreach (1 .. $n)
644	{
645	print " " . ($n + 1 - $_);
646	sleep 1;
647	}
648	print "\n";
649	}
650
651	sub rotate_logfiles
652	{
653	# keep last 10 log files
654	my $num;
655	for ($num = 10; $num > 0; $num--) {
656	my $f1 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num;
657	my $f2 = sprintf "%s/%s.%d.gz",$LOG_DIR,$log_file,$num+1;
658	unlink($f2);
659	rename($f1,$f2);
660	}
661
662	my $f1 = sprintf "%s/%s",$LOG_DIR,$log_file;
663	my $f2 = sprintf "%s/%s.1",$LOG_DIR,$log_file;
664	rename($f1,$f2);
665	}
666
667	sub compress_file
668	{
669	my $infile = shift;
670	my $outfile = sprintf "%s.gz",$infile;
671	my $gz;
672
673	if (!(open(INFILE,"<$infile"))) {
674	warn "could not open file $infile for reading: $!\n";
675	return;
676	}
677
678	if (!($gz = gzopen($outfile,"wb"))) {
679	warn "could not open file $outfile for writing: $!\n";
680	return;
681	}
682
683	while (<INFILE>) {
684	my $byteswritten = $gz->gzwrite($_);
685	warn "error writing to compressed file: error $gz->gzerror"
686	if ($byteswritten == 0);
687	}
688	close(INFILE);
689	$gz->gzclose();
690	unlink($infile);
691	}
692
693	sub open_logfile
694	{
695	-d $LOG_DIR or mkdir $LOG_DIR or die "Cannot create directory $LOG_DIR: $!";
696
697	&rotate_logfiles;
698	printf "Logging to $log_file.\n";
699	open(LOG_FILE,">>$LOG_DIR/$log_file") \|\| die "can't open log file $LOG_DIR/$log_file for writing: $!\n";
700
701	my $now = localtime(time);
702	printf LOG_FILE "$myprogname v$version started at $now\n";
703	printf LOG_FILE "Invoked with: '$invoked ".join(" ",@options)."'\n\n";
704	compress_file($LOG_DIR."/".$log_file.".1");
705	}
706
707	sub close_logfile
708	{
709	close(LOG_FILE);
710	}
711
712	sub log
713	{
714	my $entry = shift;
715	print $entry unless $opt->{quiet};
716	print LOG_FILE $entry unless $opt->{nolog};
717	}
718
719	sub call_prog
720	{
721	my ($prog,$want_output) = @_;
722	my $prog_output = "";
723	$want_output = 0 if (!defined $want_output);
724
725	if (!(open(PROG,"$prog \|"))) {
726	&log("warning: couldn't exec \"$prog\": $!\n");
727	return -1;
728	}
729	while(<PROG>) {
730	&log($_);
731	$prog_output .= $_ if ($want_output);
732	}
733	close(PROG);
734
735	if ($? == -1) {
736	&log("Failed to execute prog: $!\n");
737	return (-1,$prog_output);
738	} elsif ($? & 127) {
739	&log((sprintf "prog died with signal %d, %s coredump\n",
740	($? & 127), ($? & 128) ? "with" : "without"));
741	return ($?,$prog_output);
742	} else {
743	&log((sprintf "prog exited with value %d\n", $? >> 8)) if ($debug or $?);
744	return (($? >> 8),$prog_output);
745	}
746	}
747
748	sub fetch_file
749	{
750	my ($url, $store, $id_self) = @_;
751
752	&log("Fetching $url.\n");
753
754	my $ua = LWP::UserAgent->new();
755	if ($id_self)
756	{
757	$ua->agent(ucfirst("$progname/$version"));
758	}
759	else
760	{
761	$ua->agent('Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; .NET CLR 1.1.4322')
762	}
763
764	my $response = $ua->get($url);
765	if ($response->is_success())
766	{
767	if ($store)
768	{
769	open (FILE, ">$store")
770	or (&log("ERROR: Unable to open $store for writing.\n") and return undef);
771	print FILE $response->content();
772	close FILE;
773	return 1;
774	}
775	else
776	{
777	return $response->content();
778	}
779	}
780	&log("Failed to retrieve $url!\n" . $response->status_line() . "\n");
781	return undef;
782	}
783
784	# -----------------------------------------
785	# Subs: Setup
786	# -----------------------------------------
787
788	sub read_config_file
789	{
790	read_file($config_file, 'configuration');
791	}
792
793	sub read_channels_file
794	{
795	read_file($channels_file, 'channels');
796	}
797
798	sub read_file
799	{
800	my $fn = shift;
801	my $name = shift;
802
803	print "Reading $name file: $fn\n";
804	unless (-r $fn)
805	{
806	unless ($opt->{configure})
807	{
808	print "\nNo $name file found.\n" .
809	ucfirst($progname) . " must be configured: " .
810	"configuring now.\n\n";
811	$opt->{'configure'} = 1;
812	$opt->{'nolog'} = 1;
813	}
814	return;
815	}
816	local (@ARGV, $/) = ($fn);
817	no warnings 'all';
818	eval <>;
819	if ($@ and !$opt->{configure})
820	{
821	warn "\nERROR in $name file! Details:\n$@";
822	&countdown();
823	}
824	}
825
826	sub write_config_file
827	{
828	write_file($config_file, 'configuration',
829	[$region, $pref_title_source, $mirror_site, $components, $components_pending_install ],
830	["region", "pref_title_source", "mirror_site", "components", "components_pending_install" ]);
831	}
832
833	sub write_channels_file
834	{
835	write_file($channels_file, 'channels',
836	[ $channels, $opt_channels ],
837	[ 'channels', 'opt_channels' ]);
838	}
839
840	sub write_file
841	{
842	my ($fn, $name, $vars, $varnames) = @_;
843	open (FN, ">$fn") or die "Can't write to $name file $fn: $!";
844	print FN Data::Dumper->Dump($vars, $varnames);
845	close FN;
846	&log("Wrote $name file $fn.\n") if ($debug);
847	}
848
849	sub get_command_line_options
850	{
851	# Record so we can pass the unmodified args to components later
852	@options = @ARGV; # Record so we can pass the unmodified args to components later
853	push (@options,"") if ($#options == -1); # silence warnings if none
854
855	# filter what options we don't pass on ..
856	foreach (0..$#options) {
857	next if (!$options[$_]);
858
859	splice(@options,$_,2) if ($options[$_] =~ /^--config-file/); # don't pass on "--config-file (file)"
860	splice(@options,$_,1) if ($options[$_] =~ /^--quiet/); # never be quiet
861	}
862
863	Getopt::Long::Configure(qw/pass_through/);
864
865	GetOptions($opt, qw( config-file=s
866	help
867	configure
868	setmirror=s
869	setpreftitle=s
870	clearpreftitle
871	capabilities
872	description
873	quiet
874	version
875	debug
876	status
877	show-config
878	show-channels
879	update
880	noupdate
881	disable=s
882	enable=s
883	nolog
884	check
885	reset
886	));
887	$debug = $opt->{debug};
888	}
889
890	sub process_setup_commands
891	{
892	my @opts = qw( enable disable setorder check \
893	setpreftitle clearpreftitle setmirror reset );
894
895	my $run = 0;
896	foreach (@opts)
897	{
898	if ($opt->{$_})
899	{
900	$run = 1;
901	&$_($opt->{$_});
902	}
903	}
904	return unless ($run);
905	write_config_file();
906	status();
907	exit;
908	}
909
910	# if a preferred title source has been specified, add it to our config
911	sub setpreftitle
912	{
913	my $arg = shift;
914	$pref_title_source = $arg;
915	&log("Added preferred title source: $pref_title_source\n");
916	1;
917	}
918
919	# if requesting to clear preferred title and we have one, remove it
920	sub clearpreftitle
921	{
922	$pref_title_source = undef;
923	&log("Removed preferred title source $pref_title_source\n");
924	1;
925	}
926
927	# if a mirror has been specified, add it into our config
928	sub setmirror
929	{
930	my $arg = shift;
931	$mirror_site = $arg;
932	&log("Setting mirror site(s): $mirror_site\n");
933	}
934
935	sub reset
936	{
937	&log( "\nWARNING! The --reset argument will remove your established\n" .
938	"title translation data. This may cause Shepherd to lose the\n" .
939	"ability to keep show titles consistent with what you have seen\n" .
940	"in the past!\n\n");
941	&countdown(20);
942	my @r = query_component_type('reconciler');
943	foreach (@r) # Not that there should be more than one...
944	{
945	my $fn = query_ldir($_, 'reconciler') . '/' . $_ . '.config';
946	&log("Removing $fn.\n");
947	unlink($fn) or &log("Failed to remove file! $!\n");
948	}
949	}
950
951	# -----------------------------------------
952	# Subs: Configuration
953	# -----------------------------------------
954
955	sub configure
956	{
957	my $REGIONS = {
958	"ACT" => 126,
959	"NSW: Sydney" => 73,
960	"NSW: Newcastle" => 184,
961	"NSW: Central Coast" => 66,
962	"NSW: Griffith" => 67,
963	"NSW: Broken Hill" => 63,
964	"NSW: Northern NSW" => 69,
965	"NSW: Southern NSW" => 71,
966	"NSW: Remote and Central" => 106,
967	"NT: Darwin" => 74,
968	"NT: Remote & Central" => 108,
969	"QLD: Brisbane" => 75,
970	"QLD: Gold Coast" => 78,
971	"QLD: Regional" => 79,
972	"QLD: Remote & Central" => 114,
973	"SA: Adelaide" => 81,
974	"SA: Renmark" => 82,
975	"SA: Riverland" => 83,
976	"SA: South East SA" => 85,
977	"SA: Spencer Gulf" => 86,
978	"SA: Remote & Central" => 107,
979	"Tasmania" => 88,
980	"VIC: Melbourne" => 94,
981	"VIC: Geelong" => 93,
982	"VIC: Eastern Victoria" => 90,
983	"VIC: Mildura/Sunraysia" => 95,
984	"VIC: Western Victoria" => 98,
985	"WA: Perth" => 101,
986	"WA: Regional" => 102
987	};
988
989	print "\nConfiguring.\n\n" .
990	"Select your region:\n";
991	foreach (sort keys %$REGIONS)
992	{
993	printf(" (%3d) %s\n", $REGIONS->{$_}, $_);
994	}
995	$region = ask_choice("Enter region code:", "94", values %$REGIONS);
996
997	print "\nFetching channel information... ";
998
999	my @channellist = get_channels();
1000
1001	print "done.\n\n" .
1002	"For each channel you want guide data for, enter an XMLTV id\n" .
1003	"of your choice (e.g. \"seven.free.au\"). If you don't need\n" .
1004	"guide data for this channel, just press Enter.\n\n" .
1005	"Please don't subscribe to unneeded channels.\n\nChannels:\n";
1006	$channels = {};
1007	my $line;
1008	foreach (@channellist)
1009	{
1010	$line = ask(" \"$_\"? ");
1011	$channels->{$_} = $line if ($line);
1012	}
1013
1014	print "\nHigh Definition TV (HDTV)\n".
1015	"Most Australian TV networks broadcast at least some\n".
1016	"programmes in HDTV each week, but for the most part\n".
1017	"either upsample SD to HD or play a rolling demonstration\n".
1018	"HD clip when they don't have the programme in HD format.\n\n".
1019	"If you have a HDTV capable system and are interested in\n".
1020	"having Shepherd's postprocessors populate HDTV content\n".
1021	"then Shepherd will need to know the XMLTV IDs for the HD\n".
1022	"channels also.\n";
1023	if (ask_boolean("\nDo you wish to include HDTV channels?")) {
1024	print "\nFor each channel you want guide data for, enter an XMLTV id\n" .
1025	"of your choice (e.g. \"sevenhd.free.au\"). If you don't need\n" .
1026	"guide data for this channel, just press Enter.\n\n";
1027
1028	$opt_channels = {};
1029	foreach (@channellist)
1030	{
1031	next if (($_ =~ /ABC2/i) \|\| ($_ =~ /SBS News/i) \|\| ($_ =~ /31/));
1032	$_ .= "HD";
1033	$line = ask(" \"$_\"? ");
1034	$opt_channels->{$_} = $line if ($line);
1035	}
1036	}
1037
1038
1039	print "\nWould you like to transition seamlessly from your current grabber?\n\n".
1040	"Different data sources can have different names for the same show. For\n".
1041	"example, one grabber might call a show \"Spicks & Specks\" while another\n".
1042	"calls it \"Spicks and Specks\". These differences can make MythTV think\n".
1043	"they're actually different shows.\n\n".
1044	ucfirst($progname) . " is able to merge these differences so that it always\n".
1045	"presents shows with a consistent name, no matter where it actually sourced\n".
1046	"show data from. If you'd like, it can also rename shows so they're consistent\n".
1047	"with whichever grabber you've been using until now.\n\n".
1048	"The advantage of this is that you should get a smoother transition to\n".
1049	ucfirst($progname) . ", with no shows changing names and no need to re-create\n".
1050	"any recording rules. The main disadvantage is that if your previous grabber\n".
1051	"used an inferior data source -- i.e. it sometimes has typos or less\n".
1052	"informative program names -- then you'll continue to see these.\n\n".
1053	"If you were using one of the following grabbers previously AND you want\n".
1054	ucfirst($progname) . " to use that grabber's program names, select it here.\n\n";
1055
1056	my $def = "Do not transition; just use best quality titles";
1057	my %transition = ( "ltd (aka tv_grab_au, versions 1,30, 1.40 or 1.41)" => "yahoo7widget,abc2_website",
1058	"OzTivo" => 'oztivo',
1059	"Rex" => 'rex',
1060	"JRobbo" => 'jrobbo' );
1061	my $pref = ask_choice("Transition from grabber?", $def,
1062	$def, keys %transition);
1063	$pref_title_source = $transition{$pref};
1064
1065	print "\n";
1066	show_channels();
1067	unless(ask_boolean("\nCreate configuration file?"))
1068	{
1069	print "Aborting configuration.\n";
1070	exit 0;
1071	}
1072
1073	write_config_file();
1074	write_channels_file();
1075
1076	print "Checking if any components require configuration.\n\n";
1077	&check;
1078
1079	print "Finished configuring.\n\n";
1080
1081	status();
1082
1083	print "\nShepherd is installed into $CWD.\n\n" .
1084	"Run it as: $CWD/shepherd\n\n".
1085	"MythTV users may wish to create the following symlink, by " .
1086	"doing this (as root):\n" .
1087	" \"ln -s $CWD/$myprogname /usr/bin/tv_grab_au\".\n\n";
1088
1089	if ($invoked ne get_full_path(query_filename('shepherd','application')))
1090	{
1091	print "You may safely delete $invoked.\n\n";
1092	}
1093	elsif ((defined $ENV{shepherd_restart}) && ($ENV{shepherd_restart} ne $invoked))
1094	{
1095	print "You may safely delete $ENV{shepherd_restart}.\n\n";
1096	}
1097
1098	unless (ask_boolean("\nGrab data now?"))
1099	{
1100	exit 0;
1101	}
1102	}
1103
1104	sub get_channels
1105	{
1106	my @date = localtime;
1107	my $page = fetch_file(
1108	"http://au.tv.yahoo.com/results.html?rg=$region&dt=" .
1109	($date[5] + 1900) . "-$date[4]-$date[3]");
1110	my @channellist;
1111	while ($page =~ /<tr class=rtb><td class=rth><a .?>(.?)<\/a>/g)
1112	{
1113	push @channellist, $1;
1114	}
1115	return @channellist;
1116	}
1117
1118	# -----------------------------------------
1119	# Subs: Status & Help
1120	# -----------------------------------------
1121
1122	sub show_config
1123	{
1124	&log("\nConfiguration\n".
1125	"-------------\n" .
1126	"Config file: $config_file\n" .
1127	"Debug mode : " . is_set($debug) . "\n" .
1128	"Output file: " . ($opt->{output} ? $opt->{output} : "None") . "\n" .
1129	"Region ID : $region\n");
1130	show_channels();
1131	&log("\n");
1132	status();
1133	&log("\n");
1134	}
1135
1136	sub show_channels
1137	{
1138	&log("Subscribed channels:\n");
1139	&log(" $_ -> $channels->{$_}\n") for sort keys %$channels;
1140	&log("Optional (HDTV) channels:\n");
1141	&log(" $_ -> $opt_channels->{$_}\n") for sort keys %$opt_channels;
1142	}
1143
1144	sub is_set
1145	{
1146	my $arg = shift;
1147	return $arg ? "Yes" : "No";
1148	}
1149
1150	sub pretty_print
1151	{
1152	my ($p, $len) = @_;
1153	my $spaces = ' ' x (79-$len);
1154	my $ret = "";
1155
1156	while (length($p) > 0) {
1157	if (length($p) <= $len) {
1158	$ret .= $p;
1159	$p = "";
1160	} else {
1161	# find a space to the left of cutoff
1162	my $len2 = $len;
1163	while ((substr($p,$len2,1) ne ' ') && ($len2 > 0)) {
1164	$len2--;
1165	}
1166	if ($len2 == 0) {
1167	# no space - just print it with cutoff
1168	$ret .= substr($p,0,$len);
1169	$p = substr($p,$len,(length($p)-$len));
1170	} else {
1171	# print up to space
1172	$ret .= substr($p,0,$len2);
1173	$p = substr($p,($len2+1),(length($p)-$len2+1));
1174	}
1175	# print whitespace
1176	$ret .= "\n".$spaces;
1177	}
1178	}
1179	return $ret;
1180	}
1181
1182	sub status
1183	{
1184	&log("\nThe following plugins are known:\n",
1185	" Type Name Version Description\n".
1186	" -------- -------------- ------- ----------------------------------------------\n");
1187
1188	foreach (sort { $components->{$a}->{type} cmp $components->{$b}->{type} } keys %{$components}) {
1189	&log((sprintf " %-8s %-15s%7s %46s\n",
1190	substr($components->{$_}->{type},0,8),
1191	length($_) > 15 ? substr($_,0,13).".." : $_,
1192	($components->{$_}->{ver} ? substr($components->{$_}->{ver},0,7) : "unknown"),
1193	(defined $components->{$_}->{config}->{desc} ?
1194	pretty_print($components->{$_}->{config}->{desc},46) : "")));
1195	}
1196	&log("\n");
1197
1198	&log("Grabbers, listed in order of quality:\n".
1199	" Enabled/\n".
1200	" Grabber Qual Ready Last Run Status\n" .
1201	" -------------- ---- ----- ---------- -----------------------------------------\n");
1202	my %qual_table = ( 3 => "Best", 2 => "Good", 1 => "Avg" );
1203	foreach (sort { $components->{$b}->{config}->{quality} <=> $components->{$a}->{config}->{quality} } query_grabbers()) {
1204	my $h = $components->{$_};
1205	&log((sprintf " %-15s%-4s %1s/%1s %11s %s\n",
1206	length($_) > 15 ? substr($_,0,13).".." : $_,
1207	$qual_table{($h->{config}->{quality})},
1208	$h->{disabled} ? 'N' : 'Y',
1209	$h->{ready} ? 'Y' : 'N',
1210	$h->{lastdata} ? POSIX::strftime("%a%d%b%y", localtime($h->{lastdata})) : 'never',
1211	$h->{laststatus} ? pretty_print($h->{laststatus},41) : ''));
1212	}
1213
1214	&log("\n".
1215	" Enabled/\n".
1216	" Reconciler Ready Last Run Status\n" .
1217	" -------------- ----- ---------- ----------------------------------------------\n");
1218	foreach (sort { $components->{$a} <=> $components->{$b} } query_reconcilers()) {
1219	my $h = $components->{$_};
1220	&log((sprintf " %-15s %1s/%1s %11s %s\n",
1221	length($_) > 15 ? substr($_,0,13).".." : $_,
1222	$h->{disabled} ? 'N' : 'Y',
1223	$h->{ready} ? 'Y' : 'N',
1224	$h->{lastdata} ? POSIX::strftime("%a%d%b%y", localtime($h->{lastdata})) : 'never',
1225	$h->{laststatus} ? pretty_print($h->{laststatus},46) : ''));
1226	}
1227
1228	&log("\n".
1229	" Enabled/\n".
1230	" Postprocessor Ready Last Run Status\n" .
1231	" -------------- ----- ---------- ----------------------------------------------\n");
1232	foreach (sort { $components->{$a} <=> $components->{$b} } query_postprocessors()) {
1233	my $h = $components->{$_};
1234	&log((sprintf " %-15s %1s/%1s %11s %s\n",
1235	length($_) > 15 ? substr($_,0,13).".." : $_,
1236	$h->{disabled} ? 'N' : 'Y',
1237	$h->{ready} ? 'Y' : 'N',
1238	$h->{lastdata} ? POSIX::strftime("%a%d%b%y", localtime($h->{lastdata})) : 'never',
1239	$h->{laststatus} ? pretty_print($h->{laststatus},46) : ''));
1240	}
1241	&log("\nPreferred titles from grabber '$pref_title_source'\n") if ($pref_title_source);
1242	&log("\n");
1243	}
1244
1245	sub capabilities
1246	{
1247	print "baseline\nmanualconfig\n";
1248	exit 0;
1249	}
1250
1251	sub description
1252	{
1253	print "Australia\n";
1254	exit 0;
1255	}
1256
1257	sub help
1258	{
1259	print q{Command-line options:
1260	--help Display this message
1261	--version Display version
1262	--status Display status of various components
1263
1264	--configure Setup
1265	--show-config Display setup details
1266	--show-channels Display subscribed channels
1267
1268	--disable <s> Don't ever use grabber/postprocessor <s>
1269	--enable <s> Okay, use it again then
1270	--uninstall <s> Remove a disabled grabber/postprocessor
1271
1272	--noupdate Don't update; just grab data
1273	--update Update only; don't grab data
1274
1275	--check Check status of all components, configure if necessary
1276
1277	--debug Print lots of debugging messages
1278	--quiet Don't print anything except errors
1279	--nolog Don't write a logfile
1280
1281	--setmirror <s> Set URL <s> as primary location to check for updates
1282	--setpreftitle <s> Set preferred 'title' source as grabber <s>
1283	--clearpreftitle Clear preferred 'title' source
1284	--reset Remove all previous title translation data
1285	};
1286	exit 0;
1287	}
1288
1289	# -----------------------------------------
1290	# Subs: override handlers for standard perl.
1291	# -----------------------------------------
1292
1293	# ugly hack. please don't try this at home kids!
1294	sub my_die {
1295	my ($arg,@rest) = @_;
1296	my ($pack,$file,$line,$sub) = caller(0);
1297
1298	# check if we are in an eval()
1299	if ($^S) {
1300	printf STDERR "* Caught a die() within eval{} from file $file line $line\n";
1301	} else {
1302	printf STDERR "\nDIE: line %d in file %s\n",$line,$file;
1303	if ($arg) {
1304	CORE::die($arg,@rest);
1305	} else {
1306	CORE::die(join("",@rest));
1307	}
1308	}
1309	}

Note: See TracBrowser for help on using the browser.

Context Navigation

root/applications/shepherd @ 293

Download in other formats: