Context Navigation

ten_website @ 418

Revision 418, 29.1 kB (checked in by lincoln, 6 years ago)
ten_website prototype
Property svn:executable set to ``*

Line
1	#!/usr/bin/perl -w
2
3	# network TEN au_tv guide grabber - runs from "Shepherd" master grabber
4	# * grabs data from the network TEN website (http://www.ten.com.au)
5	# for channel TEN only
6	# * this does NOT use any config file - all settings are passed in from shepherd
7	# * idea based on OCR::PerfectCR CPAN module
8
9	use strict;
10
11	my $progname = "ten_website";
12	my $version = "0.01";
13
14	use LWP::UserAgent;
15	use LWP::ConnCache;
16	use XMLTV;
17	use POSIX qw(strftime mktime);
18	use Getopt::Long;
19	use HTML::TreeBuilder;
20	use Data::Dumper;
21	use Compress::Zlib;
22	use GD;
23	use Digest::MD5;
24
25	#
26	# global variables and settings
27	#
28
29	$\| = 1;
30	my $script_start_time = time;
31	my %stats;
32	my $channels, my $opt_channels;
33	my $data_cache;
34	my $writer;
35	my $ua;
36	my $conn_cache;
37	my $prev_url;
38	my $d;
39	my $opt;
40	my %charset;
41
42	#
43	# parse command line
44	#
45
46	$opt->{days} = 7; # default
47	$opt->{outputfile} = "output.xmltv"; # default
48	$opt->{cache_file} = $progname.".cache"; # default
49	$opt->{lang} = "en";
50	$opt->{region} = 94;
51
52	GetOptions(
53	'log-http' => \$opt->{log_http},
54	'region=i' => \$opt->{region},
55	'days=i' => \$opt->{days},
56	'offset=i' => \$opt->{offset},
57	'timezone=s' => \$opt->{timezone},
58	'channels_file=s' => \$opt->{channels_file},
59	'output=s' => \$opt->{outputfile},
60	'cache-file=s' => \$opt->{cache_file},
61	'fast' => \$opt->{fast},
62	'no-cache' => \$opt->{no_cache},
63	'no-details' => \$opt->{no_details},
64	'debug+' => \$opt->{debug},
65	'warper' => \$opt->{warper},
66	'lang=s' => \$opt->{lang},
67	'obfuscate' => \$opt->{obfuscate},
68	'anonsocks=s' => \$opt->{anon_socks},
69
70	'ocr-learn-mode' => \$opt->{ocr_learn_mode},
71
72	'help' => \$opt->{help},
73	'verbose' => \$opt->{help},
74	'version' => \$opt->{version},
75	'ready' => \$opt->{version},
76	'v' => \$opt->{help});
77
78	&help if ($opt->{help});
79
80	if ($opt->{version}) {
81	printf "%s %s\n",$progname,$version;
82	exit(0);
83	}
84
85	die "no channel file specified, see --help for instructions\n", if (!$opt->{channels_file});
86	$opt->{days} = 7 if ($opt->{days} > 7); # limit to a max of 7 days
87
88	#
89	# go go go!
90	#
91
92	&log(sprintf "going to grab %d days%s of data into %s (%s%s%s%s%s)",
93	$opt->{days},
94	(defined $opt->{offset} ? " (skipping first $opt->{offset} days)" : ""),
95	$opt->{outputfile},
96	(defined $opt->{fast} ? "with haste" : "slowly"),
97	(defined $opt->{anon_socks} ? ", via multiple endpoints" : ""),
98	(defined $opt->{warper} ? ", anonymously" : ""),
99	(defined $opt->{no_details} ? ", without details" : ", with details"),
100	(defined $opt->{no_cache} ? ", without caching" : ", with caching"));
101
102	# read channels file
103	if (-r $opt->{channels_file}) {
104	local (@ARGV, $/) = ($opt->{channels_file});
105	no warnings 'all'; eval <>; die "$@" if $@;
106	} else {
107	die "WARNING: channels file $opt->{channels_file} could not be read\n";
108	}
109
110	die "TEN not listed as a channel in ".$opt->{channels_file}.", nothing to do!\n" if (!defined $channels->{TEN});
111
112	&read_cache unless (defined $opt->{no_cache});
113
114	&set_ua;
115	&setup_charset;
116	&setup_socks if (defined $opt->{anon_socks});
117
118	&set_region;
119	&start_writing_xmltv;
120
121	&get_summary_pages;
122
123	&write_cache unless (defined $opt->{no_cache});
124	$writer->end();
125
126	&print_stats;
127	exit(0);
128
129	##############################################################################
130	# help
131
132	sub help
133	{
134	print<<EOF
135	$progname $version
136
137	options are as follows:
138	--help show these help options
139	--days=N fetch 'n' days of data (default: $opt->{days})
140	--output=file send xml output to file (default: "$opt->{outputfile}")
141	--no-cache don't use a cache to optimize (reduce) number of web queries
142	--no-details don't fetch detailed descriptions (default: do)
143	--cache-file=file where to store cache (default "$opt->{cache_file}")
144	--fast don't run slow - get data as quick as you can - not recommended
145	--anonsocks=(ip:port) use SOCKS4A server at (ip):(port) (for Tor: recommended)
146
147	--debug increase debug level
148	--warper fetch data using WebWarper web anonymizer service
149	--obfuscate pretend to be a proxy servicing multiple clients
150	--lang=[s] set language of xmltv output data (default $opt->{lang})
151
152	--region=N set region for where to collect data from (default: $opt->{region})
153	--channels_file=file where to get channel data from
154
155	--ocr-learn-mode put $progname into OCR learning mode to learn the text
156	EOF
157	;
158
159	exit(0);
160	}
161
162	##############################################################################
163	# populate cache
164
165	sub read_cache
166	{
167	if (-r $opt->{cache_file}) {
168	local (@ARGV, $/) = ($opt->{cache_file});
169	no warnings 'all'; eval <>; die "$@" if $@;
170
171	my $cache_items = 0;
172	foreach (keys %{$data_cache}) {
173	$cache_items++;
174	}
175	&log("$cache_items programmes loaded from cache.");
176	} else {
177	printf "WARNING: no programme cache $opt->{cache_file} - have to fetch all details\n";
178
179	# try to write to it - if directory doesn't exist this will then cause an error
180	&write_cache;
181	}
182	}
183
184	##############################################################################
185	# write out updated cache
186
187	sub write_cache
188	{
189	if (!(open(F,">$opt->{cache_file}"))) {
190	printf "ERROR: could not write cache file $opt->{cache_file}: $!\n";
191	printf "Please fix this in order to reduce the number of queries for data!\n";
192	exit 1;
193	} else {
194	# cleanup old entries from cache
195	for my $cache_key (keys %{$data_cache}) {
196	my ($starttime, @rest) = split(/:/,$cache_key);
197	if ($starttime < (time-86400)) {
198	delete $data_cache->{$cache_key};
199	$stats{expired_from_cache}++;
200	}
201	}
202	print F Data::Dumper->Dump([$data_cache], ["data_cache"]);
203	close F;
204	}
205	}
206
207	##############################################################################
208	# logic to fetch a page via http
209	# retries up to $retrycount times to get a page with 10 second pauses inbetween
210
211	sub get_url
212	{
213	my ($url,$retrycount,$referer,$reqtype,$postvars) = @_;
214	my $request;
215	my $response;
216	my $attempts = 0;
217	my ($raw, $page, $base);
218
219	$reqtype = "GET" if (!defined $reqtype);
220
221	$retrycount = 5 if ($retrycount == 0);
222	$url =~ s#^http://#http://webwarper.net/ww/# if (defined $opt->{warper});
223
224	if ($reqtype eq "GET") {
225	$request = HTTP::Request->new(GET => $url);
226	} elsif ($reqtype eq "POST") {
227	$request = HTTP::Request->new(POST => $url);
228	$request->header('Content-type' => 'application/x-www-form-urlencoded');
229	$request->add_content($postvars);
230	}
231
232	if (defined $referer) {
233	$request->header('Referer' => $referer);
234	} else {
235	$request->header('Referer' => $prev_url) if (defined $prev_url);
236	}
237	$prev_url = $url;
238
239	$request->header('Accept-Encoding' => 'gzip');
240
241	if ($opt->{obfuscate}) {
242	my $randomaddr = sprintf "203.%d.%d.%d",rand(255),rand(255),(rand(254)+1);
243	$request->header('Via' => '1.0 proxy:81 (Squid/2.3.STABLE3)');
244	$request->header('X-Forwarded-For' => $randomaddr);
245	}
246
247	my $status;
248	for (1..$retrycount) {
249	$response = $ua->request($request);
250
251	if ((defined $opt->{log_http}) && (open(F,">>http_log.txt"))) {
252	printf F "\n----------------------------------------------------\n";
253	printf F "request: %s %s %s\n",$reqtype,$url,(defined $postvars ? $postvars : "");
254	printf F "referer: %s\n", ($request->header('Referer') ? $request->header('Referer') : "(none)");
255	printf F "response: %s\n",$response->status_line;
256	print F $response->content;
257	close F;
258	}
259
260	if ($response->is_success) {
261	if ($response->content =~ /we are unable to process your request/) {
262	$status = "fail: 999: Service unavailable"; # CPAN's LWP lied to us
263	} else {
264	$status = "good";
265	last;
266	}
267	} else {
268	$status = "fail: ".$response->status_line;
269	}
270
271	$stats{http_failed_requests}++;
272	$attempts++;
273
274	my $sleep_for = 60;
275	$sleep_for = 10 if (defined $opt->{anon_socks});
276
277	&log("attempt $attempts of $retrycount failed to fetch $url, sleeping for $sleep_for secs: $status");
278
279	$stats{slept_for} += $sleep_for;
280	sleep $sleep_for;
281	}
282	if ($status !~ /^good/) {
283	&log("aborting after $attempts attempts to fetch url $url");
284	return undef;
285	}
286
287	$prev_url = $response->base;
288	$prev_url =~ s#^http://webwarper.net/ww/#http://# if (defined $opt->{warper});
289
290	$stats{bytes_fetched} += do {use bytes; length($response->content)};
291	$stats{http_successful_requests}++;
292
293	if ((!defined $opt->{fast}) && (!defined $opt->{anon_socks})) {
294	my $sleeptimer = int(rand(6)) + 17; # sleep anywhere from 17 to 23 seconds
295	$stats{slept_for} += $sleeptimer;
296	sleep $sleeptimer;
297	}
298
299	if ($response->header('Content-Encoding') &&
300	$response->header('Content-Encoding') eq 'gzip') {
301	$stats{compressed_pages} += do {use bytes; length($response->content)};
302	$response->content(Compress::Zlib::memGunzip($response->content));
303	}
304	return $response->content;
305	}
306
307	##############################################################################
308
309	sub log
310	{
311	my ($entry) = @_;
312	printf "%s [%d] %s\n",$progname,time,$entry;
313	}
314
315	##############################################################################
316
317	sub print_stats
318	{
319	printf "STATS: %s v%s completed in %d seconds",$progname, $version, time-$script_start_time;
320	foreach my $key (sort keys %stats) {
321	printf ", %d %s",$stats{$key},$key;
322	}
323	printf "\n";
324	}
325
326	##############################################################################
327	# descend a structure and clean up various things, including stripping
328	# leading/trailing spaces in strings, translations of html stuff etc
329	# -- taken & modified from Michael 'Immir' Smith's excellent tv_grab_au
330
331	my %amp;
332	BEGIN { %amp = ( nbsp => ' ', qw{ amp & lt < gt > apos ' quot " } ) }
333
334	sub cleanup {
335	my $x = shift;
336	if (ref $x eq "REF") { cleanup($_) }
337	elsif (ref $x eq "HASH") { cleanup(\$_) for values %$x }
338	elsif (ref $x eq "ARRAY") { cleanup(\$_) for @$x }
339	elsif (defined $$x) {
340	$$x =~ s/&(#(\d+)\|(.*?));/ $2 ? chr($2) : $amp{$3}\|\|' ' /eg;
341	$$x =~ s/[^\x20-\x7f]/ /g;
342	$$x =~ s/(^\s+\|\s+$)//g;
343	}
344	}
345
346	##############################################################################
347
348	sub start_writing_xmltv
349	{
350	my %writer_args = ( encoding => 'ISO-8859-1' );
351	if ($opt->{outputfile}) {
352	my $fh = new IO::File(">$opt->{outputfile}") \|\| die "can't open $opt->{outputfile}: $!";
353	$writer_args{OUTPUT} = $fh;
354	}
355
356	$writer = new XMLTV::Writer(%writer_args);
357
358	$writer->start
359	( { 'source-info-name' => "$progname $version",
360	'generator-info-name' => "$progname $version"} );
361
362	for my $channel (sort keys %{$channels}) {
363	$writer->write_channel( {
364	'display-name' => [[ $channel, $opt->{lang} ]],
365	'id' => $channels->{$channel}
366	} );
367	}
368	}
369
370	##############################################################################
371
372	sub set_ua
373	{
374	my @agent_list = (
375	'Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)',
376	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
377	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; FunWebProducts)',
378	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322)',
379	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)',
380	'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; Q312466)',
381	'Mozilla/4.0 (compatible; MSIE 6.0; Windows XP)',
382	'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85.8.5 (KHTML, like Gecko) Safari/85.8.1',
383	'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.4) Gecko/20060508 Firefox/1.5.0.4',
384	'Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.7.6) Gecko/20050512 Firefox',
385	'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.8.0.8) Gecko/20061025 Firefox/1.5.0.8',
386	'Mozilla/5.0 (Windows; U; Windows NT 5.1; de; rv:1.8.1) Gecko/20061010 Firefox/2.0',
387	'Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)',
388	'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/412 (KHTML, like Gecko) Safari/412',
389	'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-us) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
390	'Mozilla/5.0 (Macintosh; U; Intel Mac OS X; fr) AppleWebKit/418.9 (KHTML, like Gecko) Safari/419.3',
391	'Opera/9.00 (Windows NT 5.1; U; en)');
392
393	$ua = undef;
394	$conn_cache = LWP::ConnCache->new;
395	$ua = LWP::UserAgent->new('conn_cache' => $conn_cache, 'timeout' => 30, 'agent' => $agent_list[(int(rand($#agent_list+1)))] );
396	$ua->env_proxy;
397	$ua->cookie_jar({ });
398
399
400	$prev_url = undef; # reset referer
401	}
402
403	##############################################################################
404
405	sub urlify
406	{
407	my $str = shift;
408	$str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
409	$str =~ s/%20/+/g;
410	$str =~ s/%2D/-/g;
411	return $str;
412	}
413
414	##############################################################################
415
416	sub translate_category
417	{
418	my $genre = shift;
419	my %translation = (
420	'Sport' => 'sports',
421	'Soap Opera' => 'Soap',
422	'Science and Technology' => 'Science/Nature',
423	'Real Life' => 'Reality',
424	'Cartoon' => 'Animation',
425	'Family' => 'Children',
426	'Murder' => 'Crime' );
427
428	return $translation{$genre} if defined $translation{$genre};
429	return $genre;
430	}
431
432	##############################################################################
433
434	sub set_region
435	{
436	&log("setting region");
437
438	my $url = sprintf "http://www.ten.com.au/citySelect.aspx?change=true";
439	my $data = &get_url($url,5);
440	if (!$data) {
441	&log("CRITICAL ERROR: Could not set region because of error fetching '$url'");
442	exit(1);
443	}
444
445	my $tree = HTML::TreeBuilder->new_from_content($data);
446	if (!$tree) {
447	&log("CRITICAL ERROR: url '$url' doesn't seem to contain any valid HTML: has the format changed?");
448	exit(1);
449	}
450
451	$opt->{viewstate} = $_->attr('value') if ($_ = $tree->look_down('_tag' => 'input', 'type' => 'hidden', 'name' => '__VIEWSTATE'));
452	if (!defined $opt->{viewstate}) {
453	&log(" has the format changed? could not find 'viewstate'...");
454	$stats{viewstate_not_found}++;
455	$opt->{viewstate} = "";
456	}
457
458	my $reg = 1; # sydney
459	$reg = 2 if ($opt->{region} =~ /^9/); # melbourne
460	$reg = 3 if ($opt->{region} =~ /(75\|78\|79\|114\|74\|108)/); # brisbane
461	$reg = 4 if ($opt->{region} =~ /(101\|102)/); # perth
462	$reg = 5 if ($opt->{region} =~ /(81\|82\|83\|85\|86\|107)/); # adelaide
463
464	my $postvars = "__VIEWSTATE=".urlify($opt->{viewstate})."&new_site_id=".$reg."&_ctl1.x=0&_ctl1.y=0";
465	$data = &get_url($url, 5, undef, "POST", $postvars);
466	}
467
468	##############################################################################
469
470	sub get_summary_pages
471	{
472	my $starttime = time;
473	my $day_num = 0;
474	my $skip_days = 0;
475
476	$skip_days = $opt->{offset} if (defined $opt->{offset});
477	while ($day_num < $opt->{days}) {
478	my $currtime = $starttime + (606024 * $day_num);
479	$day_num++;
480
481	# skip if --offset applies against this day
482	if ($skip_days > 0) {
483	$skip_days--;
484	next;
485	}
486
487	my @timeattr = localtime($currtime); # 0=sec,1=min,2=hour,3=day,4=month,5=year,6=wday,7=yday,8=isdst
488	$timeattr[0] = 0; # zero sec
489	$timeattr[1] = 0; # zero min
490	$timeattr[2] = 6; # 6am
491	my $day_start = mktime(@timeattr);
492
493	&log("fetching day $day_num summary page");
494	&parse_summary_page($day_start, $day_num);
495	}
496	}
497
498	##############################################################################
499
500	sub parse_summary_page
501	{
502	my ($day_start, $day_num) = @_;
503
504	my $url = "http://www.ten.com.au/programGuide.aspx?section=programGuide";
505	my $postvars = "__VIEWSTATE=".urlify($opt->{viewstate}).
506	"&newDate=".urlify(POSIX::strftime("%Y-%m-%d %H:%M:%S",localtime($day_start))).".000".
507	"&newTime=&newGenre=&newKeyword=&filterButton.x=0&filterButton.y=0&sq=";
508	$postvars .= "&storeDate=".urlify($opt->{storedate}) if (defined $opt->{storedate});
509
510	# &log("parse_summary_page debug: day_start $day_start day_num $day_num POST $postvars") if (defined $opt->{debug});
511
512	my $data = &get_url($url, 5, undef, "POST", $postvars);
513	if (!$data) {
514	&log("url '$url' (POST $postvars) doesn't seem to contain any valid response.");
515	$stats{bad_response}++;
516	return;
517	}
518
519	my $tree = HTML::TreeBuilder->new_from_content($data);
520	if (!$tree) {
521	&log("url '$url' (POST $postvars) doesn't seem to contain any valid HTML: has the format changed?");
522	$stats{bad_html}++;
523	return;
524	}
525
526	if (my $viewstate_field = $tree->look_down('_tag' => 'input', 'type' => 'hidden', 'name' => '__VIEWSTATE')) {
527	my $new_viewstate = $viewstate_field->attr('value');
528	$opt->{viewstate} = $new_viewstate if (defined $new_viewstate);
529	}
530
531	if (my $storedate_field = $tree->look_down('_tag' => 'input', 'type' => 'hidden', 'name' => 'storeDate')) {
532	my $page_date = $storedate_field->attr('value');
533	$opt->{storedate} = $page_date if (defined $page_date);
534	}
535
536	$stats{programmes} = 0 if (!defined $stats{programmes});
537	my $progs_in_day = 0;
538
539	for my $tree_pg ($tree->look_down('_tag' => 'tr')) {
540	my $yellow_row_count = 0;
541	my $prog_bg;
542	my $prog_fg;
543	my $prog_details;
544	my $prog_rating;
545	my $prog_cc;
546	my $prog_hd;
547
548	foreach my $prog_td ($tree_pg->look_down('_tag' => 'td')) {
549	my $prog_td_class = $prog_td->attr('class');
550	if ((defined $prog_td_class) && ($prog_td_class eq "pgimgcell")) {
551	if (my $style_tag = $prog_td->attr('style')) {
552	$prog_bg = $1 if ($style_tag =~ /^background:url$(.*)$ /);
553	}
554
555	if (my $img_tag = $prog_td->look_down('_tag' => 'img', 'class' => 'pgimg')) {
556	$prog_fg = $img_tag->attr('src');
557	}
558
559	if (my $link_tag = $prog_td->look_down('_tag' => 'a', 'href' => '#')) {
560	my $link_url = $link_tag->attr('onClick');
561	$prog_details = $1 if ($link_url =~ /^window\.open\('(.+?)'/);
562	}
563	} elsif ((defined $prog_td_class) && ($prog_td_class eq "yellow")) {
564	$yellow_row_count++;
565	if ($yellow_row_count == 1) { # HD flag
566	$prog_hd = 1 if ($prog_td->as_text() =~ /HD/);
567	} elsif ($yellow_row_count == 2) { # CC flag
568	$prog_cc = 1 if ($prog_td->as_text() =~ /Y/);
569	} elsif ($yellow_row_count == 3) { # rating
570	$prog_rating = $prog_td->as_text();
571	}
572	}
573	}
574
575	if ((defined $prog_fg) && (defined $prog_bg) && (defined $prog_details)) {
576	$progs_in_day++;
577	$stats{programmes}++;
578	&parse_one_summary_prog($day_start, $day_num, $progs_in_day, $prog_fg, $prog_bg, $prog_details, $prog_rating, $prog_hd, $prog_cc);
579	}
580	}
581
582	&log("WARNING: Only $progs_in_day programmes seen on day $day_num in '$url' (POST $postvars). ".
583	"Data may be bad.") if ($progs_in_day < 10);
584	}
585
586	##############################################################################
587	# given a summary-line of a programme, turn it into a prog entry
588
589	sub parse_one_summary_prog
590	{
591	my ($day_start, $day_num, $progs_in_day, $prog_fg, $prog_bg, $prog_details, $prog_rating, $prog_hd, $prog_cc) = @_;
592
593	my $id;
594	$id = $1 if ($prog_bg =~ /id=(\d+)$/);
595
596	my $s;
597
598	if (!defined $data_cache->{$id}) {
599	my $fg_gif_image = &get_url("http://www.ten.com.au".$prog_fg,3);
600	my $bg_gif_image = &get_url("http://www.ten.com.au".$prog_bg,3);
601
602	my $fg_image = GD::Image->newFromGifData($fg_gif_image);
603	my $bg_image = GD::Image->newFromPngData($bg_gif_image);
604
605	$bg_image->copyMerge($fg_image, 0, 0, 0, 0, $fg_image->width, $fg_image->height, 100);
606
607	# remove underline
608	my $white = $bg_image->colorExact(255,255,255);
609	$bg_image->filledRectangle(0, 14, $fg_image->width, $fg_image->height, $white);
610
611	$s = &parse_characters($id, $bg_image,($day_num == 1 ? 6 : 14));
612	$data_cache->{$id}->{ocr_text} = $s;
613	} else {
614	$s = $data_cache->{$id}->{ocr_text};
615	}
616
617	&log("parse_one_summary_prog: d".$day_num."p".$progs_in_day." ".$prog_details.": ".$s) if (defined $opt->{debug});
618
619	}
620
621	##############################################################################
622
623	sub parse_characters
624	{
625	my ($imgname,$i,$space_threshold) = @_;
626
627	my ($width, $height) = $i->getBounds;
628	my $bg = $i->getPixel(0,0);
629
630	# flatten image colours
631	my @bgcolour;
632	foreach my $index (0..$i->colorsTotal) {
633	my @r = $i->rgb($index);
634	my $total = $r[0]+$r[1]+$r[2];
635
636	if ($total > (240*3)) {
637	$bgcolour[$index] = 1;
638	} else {
639	$bgcolour[$index] = 0;
640	}
641	}
642
643	# scan right until
644	my $char_x1 = 0;
645	my $char_x2 = 0;
646	my $last_char_x = 0;
647	my $done = 0;
648	my $charnum = 0;
649	my $s = "";
650
651	while (!$done) {
652	$char_x2++;
653	$done = 1 if ($char_x2 >= ($width-1));
654
655	my $blank_line = 1; # until proven otherwise
656	my $char_y = 0;
657	while (($char_y < ($height-1)) && ($blank_line)) {
658	my $index = $i->getPixel($char_x2,$char_y);
659	$blank_line = 0 if ($bgcolour[($i->getPixel($char_x2,$char_y))] == 0);
660	$char_y++;
661	}
662
663	if (($blank_line) \|\| ($char_x2 == ($width-1))) {
664	if (($char_x2 - $char_x1) == 1) {
665	$char_x1 = $char_x2 + 1;
666	$char_x2++;
667	next;
668	}
669
670	if (($char_x1 - $last_char_x) >= 3) {
671	if (($charnum > $space_threshold) \|\| (($char_x1 - $last_char_x) >= 4)) {
672	$s .= " ";
673	$charnum++;
674	}
675	}
676	$last_char_x = $char_x2;
677
678	my $str = pack('N',($char_x2-$char_x1));
679	foreach my $x ($char_x1..$char_x2) {
680	foreach my $y (0..($height-1)) {
681	$str .= pack('N', $bgcolour[($i->getPixel($x, $y))]);
682	}
683	}
684	my $md5 = Digest::MD5::md5_hex($str);
685	$charnum++;
686
687	if ((!defined $charset{$md5}) \|\| ($charset{$md5} eq "?")) {
688	if (defined $opt->{ocr_learn_mode}) {
689	$charset{$md5} = "[".$md5."]";
690	$s .= "[".$md5."]";
691	} else {
692	$s .= "?";
693	}
694	} else {
695	$s .= $charset{$md5};
696	}
697
698	$char_x1 = $char_x2+1;
699	$char_x2++;
700	}
701	}
702
703	return $s;
704	}
705
706	##############################################################################
707
708	sub setup_charset
709	{
710	$charset{"87b7de3dbbeda572e883253803f73a78"}="e";
711	$charset{"caa8c600dd0aecf49f445753963e97b5"}=":";
712	$charset{"46854a6efed48426f1018828cca41ac2"}="o";
713	$charset{"f64db65ec25ba73bdced42fcf01be00a"}="r";
714	$charset{"d0ec43eddec59827259b46c460386ae0"}="l";
715	$charset{"d4fb05e2702c4199a73794b5def96ec2"}="G";
716	$charset{"ca1cbc6861523c4608f19365cac6dde0"}="0";
717	$charset{"a49667c09e9d4be0b595578d51eeb60d"}="M";
718	$charset{"1a9de7fb6f1c93f3ffaa15816549e43a"}="6";
719	$charset{"fbec6375cab7ff5b9d4b4783c7aab13b"}="s";
720	$charset{"b1465cc2781264fff5a55a9e9b3d8064"}="A";
721	$charset{"b61b8c026407890a23276d41125d7e98"}="h";
722	$charset{"8e2a682942360201f924e694dc70fa43"}="T";
723	$charset{"c1e402fec1d35694b1898b1f1dbb16bb"}="w";
724	$charset{"bed2eaba5e16b7246bb1f5b94d44b61c"}="h";
725	$charset{"c0107f886a27e42ce8fd2eca63a5ebcc"}="D";
726	$charset{"8300a291d7dae2e876126878c98af6d1"}="S";
727	$charset{"7edd9f81d7da6577d57da07f93f95b87"}="E";
728	$charset{"ec5d1b2140213fdbbf3c837400b2d3c5"}="e";
729	$charset{"14e3c224bd590504ffa95a1987ac3fbc"}="n";
730	$charset{"55ced8bf6a2a2482f578bc988b60b5ed"}="a";
731	$charset{"51bc70bfed877b2bf7300a5023a88634"}="o";
732	$charset{"5ae0c7cc64eb457ed198ee008fcd52f9"}="d";
733	$charset{"8769704a7c47684c74d841673664f942"}="V";
734	$charset{"763602fa61fe36273a3492f3fbae0ff8"}="t";
735	$charset{"0efb2ccf6c4e8b3084e56da89ad6629b"}="7";
736	$charset{"70dddd8427594526c8fd308b6151d673"}="i";
737	$charset{"75419c36d52e0f29143d4ecf3c5fd2fd"}="W";
738	$charset{"592559bccc3f515e5d2a93622320a1a2"}="m";
739	$charset{"4e4073891b344c07deceee07cd6ba348"}="g";
740	$charset{"9e2f28787475e105da5221e20eb7a137"}="r";
741	$charset{"f7e8dade3df2070be62dd206ef0cc8f1"}="5";
742	$charset{"62982338ad7a6b499056bac67f840d83"}="N";
743	$charset{"97fd0fdcedad187e8bf877adc5d580c5"}="2";
744	$charset{"35f9e067a546f3ae0057065223fe4c33"}="3";
745	$charset{"97f15e1d2ad1cb232147d0b6f01c8022"}="O";
746	$charset{"4c52033ce6a724d184d9c8d23a960d6e"}="P";
747	$charset{"9fbd3153eb8e55a0a1f453ee33e6bafd"}="i";
748	$charset{"e7a5cbb21f17f35f2f141e63f37a45fb"}="c";
749	$charset{"f7e8dade3df2070be62dd206ef0cc8f1"}="5";
750	$charset{"646db1d6726727e809ed1eb7ea11f545"}="8";
751	$charset{"c5ed676c18b62bc6885e34bf527e66af"}="Y";
752	$charset{"99bea8c75f15219ca16a7229b3938665"}="u";
753	$charset{"a9ea989899145834e84daf0abc5964f0"}="!";
754	$charset{"8113592ffa186852672d458f5bd86135"}="k";
755	$charset{"fec8880342772dd7e83ca9ffeed0e216"}="l";
756	$charset{"185a57d42d98c6cbd85135d9e8295501"}="D";
757	$charset{"606bf5428471cfd5de3434374c281334"}="y";
758	$charset{"50692dc12cde0fae151d9a0c2563c81d"}="J";
759	$charset{"f3045893d14fbb5f20e215a38617aee4"}="0";
760	$charset{"cf78a362c08ef3b9284ade8113e670d7"}="R";
761	$charset{"0de173cf09ded97fff935aa24f7f8bfe"}="z";
762	$charset{"cf63706b1f8eaa1c9120e1f9794918c3"}="T";
763	$charset{"f9f2e0d23af08cb6fbeacb686992f633"}="v";
764	$charset{"c1777c45a7d53a5d557c5da145bea080"}="'";
765	$charset{"88f4902f74cf89846318c96003466835"}="p";
766	$charset{"2b821839a93b75e470d04a5e2c1971b3"}="J";
767	$charset{"120cfb2dcf74d7900dc22d44bea9db09"}="H";
768	$charset{"298b488eb21a879c4cf9007c05283a15"}="s";
769	$charset{"08021ebe5ef72c0ed41b438fd794e71e"}="tt";
770	$charset{"b24415f6bccb3a9ad482156a524dbf1e"}="y";
771	$charset{"6c27fb8ed1d2d451785d957138ca0902"}="u";
772	$charset{"5a6e6307a1b18b409618616556a327e5"}="E";
773	$charset{"8d4430c7857a01d4805b4666c54fe114"}="b";
774	$charset{"cf9c23550ff1fde3b19b593966fdd391"}="S";
775	$charset{"97986e54d74ef7047eebc1169134564f"}="B";
776	$charset{"561fda757040c25038687752394d39a8"}="M";
777	$charset{"8015f8d4c3d6574c9ec73b412ece2013"}="L";
778	$charset{"7fdc4d50db244ad00f11d7c362f10b8f"}="9";
779	$charset{"73f0455d71b4156ab2bbebb7fac004ca"}="4";
780	$charset{"401ccf9844fe6399f13597cb458abedb"}="a";
781	$charset{"28de7104f0f94e161104c407071a5e91"}="m";
782	$charset{"cc282e429660787afc4a292a6e35cb2a"}="F";
783	$charset{"449bb458f502dbb10cf71673d1bd7ac4"}="5";
784	$charset{"eb6c72d1cb3b32bfcf646e2c5dafc4d2"}="N";
785	$charset{"aa364cab095bc5f46f855c9772619f5e"}="1";
786	$charset{"6aadacaa0e0b622fe755be8615f67f87"}="2";
787	$charset{"0f87f473885da54c2a7c886ae92f0ddd"}="R";
788	$charset{"17d10978ffc796cc024c68afa3fb463c"}="I";
789	$charset{"70b21817f2611845e464f8b551c73b71"}="1";
790	$charset{"f5a215139fdc4921b4fad687e0899fdc"}="H";
791	$charset{"8b9e1cc11d23773ca68afaea3064902a"}="A";
792	$charset{"6adf28b9140e9b236394bd6956638630"}="9";
793	$charset{"0d2eeea7b20edb640d5556ea8528ba67"}="K";
794	$charset{"3503cdc59df22be3b6242db35cfe3482"}="f";
795	$charset{"b5856240a388696d55ea99fad53166ce"}="W";
796	$charset{"4b8e08032dde00ced51e8435820be5e1"}="n";
797	$charset{"38b1c7da79cbbac219c590129f40cca1"}="k";
798	$charset{"1697c04376dac187f028f240cb0ccc9a"}="C";
799	$charset{"2e03a06a91a1993a5c6e15b43784e5c3"}="3";
800	$charset{"840e43645d65217fd0d57914321db2bf"}=":";
801	$charset{"5e871ec322ade9e74d44285c3ddad972"}="L";
802	$charset{"e3bcb0065109e004bc6b18b1403fb810"}="rt";
803	$charset{"9f32b9cd5083733eead4380bb6551ac5"}="B";
804	$charset{"148cafcb02f1a203866f583dbdb253af"}="&";
805	$charset{"519cc9d317d1a6db113c0da6e5560e71"}="d";
806	$charset{"40ec9716cfe72fe54201dae866e70ec5"}="V";
807	$charset{"ace17452c10518e97caba9493898c910"}="U";
808	$charset{"d244b3a33602a55c1ee8cf9c570dced9"}="-";
809	$charset{"25ee9123a9fdb7c164b29dfaa50d10b7"}="6";
810	$charset{"a87bc5bc8b3e5df44df2e2405561dd83"}=".";
811	$charset{"f6e64e873007d53c7bf7873d639f4678"}=".";
812	$charset{"de8b17aa3cf358a1e8b9496dd99e20f1"}="7";
813	$charset{"21e73997781a1af8c506eded30c6143f"}="4";
814	$charset{"4518bf9cb085588761164be21442aa5d"}="F";
815	$charset{"c38b4e845130be00f1a27a023241a500"}="!";
816	$charset{"f5a9cba4badf510bbde66e1012647c8c"}="O";
817	$charset{"c67d0abf9dd1bf2352613c243de4649b"}="P";
818	$charset{"453b59cf0cb2813958d5518fc668639c"}="Z";
819	$charset{"3dad6dcdedabfbb99ef2067f38d6bd67"}="B";
820	$charset{"b2da7f7ca8c9be23ca445a7df954a4f2"}="8";
821	$charset{"8a3bf2c9eb10c811e50c91759e6e57cc"}="G";
822	$charset{"f9e0333c0725c22b198bc0c3a7aa4a51"}="x";
823	$charset{"61ea6df7256f910d1cb031979d7d1eda"}="C";
824	$charset{"588b076556aa1b58810fe1f97fa77371"}="Y";
825	$charset{"8a3bf2c9eb10c811e50c91759e6e57cc"}="G";
826	$charset{"61ea6df7256f910d1cb031979d7d1eda"}="C";
827	}
828
829	##############################################################################
830
831	sub setup_socks
832	{
833	use LWP::Protocol::http;
834	my $orig_new_socket = \&LWP::Protocol::http::_new_socket;
835
836	# override LWP::Protocol::http's _new_socket method with our own
837	local($^W) = 0;
838	*LWP::Protocol::http::_new_socket = \&socks_new_socket;
839
840	# test that it works
841	&log("configured to use Tor, testing that it works by connecting to www.google.com ...");
842	my $data = &get_url("http://www.google.com/",10);
843	if (($data) && ($data =~ /Google/i)) {
844	&log("success. Tor appears to be working!");
845	return;
846	}
847
848	&log("ERROR: Could not connect to www.google.com via Tor, disabling Tor.");
849	&log(" DATA FETCHING WILL BE VERY SLOW.");
850	&log(" DISABLING DETAILS-FETCHING BECAUSE OF THIS - SIGNIFICANTLY LOWER DATA QUALITY!!");
851
852	$opt->{no_details} = 1;
853	delete $opt->{anon_socks};
854	$stats{fallback_to_non_tor}++;
855
856	*LWP::Protocol::http::_new_socket = $orig_new_socket;
857	}
858
859	##############################################################################
860	# our own SOCKS4Aified version of LWP::Protocol::http::_new_socket
861
862	sub socks_new_socket
863	{
864	my($self, $host, $port, $timeout) = @_;
865
866	my ($socks_ip,$socks_port) = split(/:/,$opt->{anon_socks});
867	$socks_ip = "127.0.0.1" if (!defined $socks_ip);
868	$socks_port = "9050" if (!defined $socks_port);
869
870	local($^W) = 0; # IO::Socket::INET can be noisy
871	my $sock = $self->socket_class->new(
872	PeerAddr => $socks_ip,
873	PeerPort => $socks_port,
874	Proto => 'tcp');
875
876	unless ($sock) {
877	# IO::Socket::INET leaves additional error messages in $@
878	$@ =~ s/^.*?: //;
879	&log("Can't connect to $host:$port ($@)");
880	return undef;
881	}
882
883	# perl 5.005's IO::Socket does not have the blocking method.
884	eval { $sock->blocking(0); };
885
886	# establish connectivity with socks server - SOCKS4A protocol
887	print { $sock } pack("CCnN", 0x04, 0x01, $port, 1) .
888	(pack 'x') .
889	$host . (pack 'x');
890
891	my $received = "";
892	my $timeout_time = time + $timeout;
893	while ($sock->sysread($received, 8) && (length($received) < 8) ) {
894	select(undef, undef, undef, 0.25);
895	last if ($timeout_time < time);
896	}
897
898	if ($timeout_time < time) {
899	&log("Timeout ($timeout) while connecting via SOCKS server");
900	return $sock;
901	}
902
903	my ($null_byte, $req_status, $port_num, $ip_addr) = unpack('CCnN',$received);
904	&log("Connection via SOCKS4A server rejected or failed") if ($req_status == 0x5b);
905	&log("Connection via SOCKS4A server because client is not running identd") if ($req_status == 0x5c);
906	&log("Connection via SOCKS4A server because client's identd could not confirm the user") if ($req_status == 0x5d);
907
908	$sock;
909	}
910
911	##############################################################################

Note: See TracBrowser for help on using the browser.

Context Navigation

root/grabbers/ten_website @ 418

Download in other formats: