1# -*- perl -*-
2
3#
4# Author: Slaven Rezic
5#
6# Copyright (C) 1998,2001,2003,2005,2006,2007,2012,2013 Slaven Rezic. All rights reserved.
7# This package is free software; you can redistribute it and/or
8# modify it under the same terms as Perl itself.
9#
10# Mail: slaven@rezic.de
11# WWW:  http://bbbike.sourceforge.net
12#
13
14package Update;
15
16use strict;
17use vars qw($verbose $tmpdir $proxy $VERSION);
18
19use File::Basename;
20use BBBikeUtil qw(is_in_path);
21use BBBikeVar;
22use FindBin;
23
24sub update_http {
25    my(%args) = @_;
26    my $root = delete $args{-root} || die "No root";
27    my(@files) = @{$args{-files}};
28    my $dest = delete $args{-dest} || die "No destination";
29    my(%modified) = %{$args{-modified}};
30    my $ua;
31    eval {
32	require LWP::UserAgent;
33	$main::public_test = $main::public_test; # peacify -w
34	$main::os = $main::os; # peacify -w
35	if ($main::public_test) {
36	    if ($main::os ne 'win') {
37		warn "Force using Http.pm for -public on non-Windows systems\n";
38		die;
39	    }
40	}
41	require BBBikeHeavy;
42	$ua = BBBikeHeavy::get_uncached_user_agent();
43	die "Can't get default user agent" if !$ua;
44	$ua->timeout(180);
45    };
46    if ($@ || !$ua) {
47	undef $ua;
48	require Http;
49	Http->VERSION(3.15); # correct handling of Host: ...
50	$Http::user_agent = $Http::user_agent if 0; # peacify -w
51	$main::progname = $main::progname if 0; # peacify -w
52	$Http::user_agent = "$main::progname/$main::VERSION (Http/$Http::VERSION) ($^O)";
53    }
54    $main::c = $main::c; # peacify -w
55    $main::progress->Init(-dependents => $main::c,
56			  -label => "Aktualisierung via Internet");
57    my @errors;
58    my $i = 0;
59    foreach my $file (@files) {
60	my $src_file  = $root . "/" . $file;
61	$main::progress->Update($i++/$#files, # / help emacs
62				-label => "Aktualisiere " . basename($src_file));
63	my $dest_file = $dest . "/" . $file . "~";
64	my $real_dest_file = $dest . "/" . $file;
65	my $h;
66	if ($ua) {
67	    $h = new HTTP::Headers;
68	    if (exists $modified{$file} && -f $real_dest_file) {
69		$h->if_modified_since($modified{$file});
70	    }
71	} else {
72	    if (exists $modified{$file} && -f $real_dest_file) {
73		$h = {'time' => $modified{$file}};
74	    } else {
75		$h = {};
76	    }
77	}
78	if ($main::verbose) {
79	    print STDERR "$src_file => $dest_file...";
80	}
81	my($res, $success, $modified);
82	my $code;
83	if ($ua) {
84	    $res = $ua->request(new HTTP::Request('GET', $src_file, $h),
85				$dest_file);
86	    $code = $res->code;
87	    $success = $res->is_success;
88	    if ($code == 200) {
89		$modified = 1;
90	    }
91	} else {
92	    my(%res) = Http::get('url' => $src_file,
93				 %$h,
94				);
95	    $code = $res{'error'};
96	    $success = ($code <  400); # OK or Not-modified
97	    $modified = ($code == 200); # OK
98	    if ($modified) { # OK
99		eval {
100		    open(OUT, ">$dest_file~") or die $!;
101		    print OUT $res{'content'} or die $!;
102		    close OUT or die $!;
103		};
104		if ($@) {
105		    print STDERR "Can't write to $dest_file: $@\n";
106		    $success = 0;
107		} else {
108		    rename "$dest_file~", $dest_file
109			or do {
110			    warn "Can't rename to $dest_file: $!";
111			    $success = 0;
112			};
113		}
114	    }
115	}
116	my $fatal = $code >= 500;
117	if ($modified) {
118	    my $tmp = $dest_file . "~~";
119	    rename $real_dest_file, $tmp;
120	    rename $dest_file, $real_dest_file;
121	    unlink $tmp;
122	    if ($main::verbose) {
123		print STDERR " aktualisiert\n";
124	    }
125	} else {
126	    if ($ua) {
127		if ($res->is_error) {
128		    print STDERR "\n", $res->as_string;
129		    my $text = $res->error_as_HTML;
130		    eval {
131			require HTML::FormatText;
132			require HTML::TreeBuilder;
133			my $tree = HTML::TreeBuilder->new->parse($text);
134			$text = HTML::FormatText->new(leftmargin => 0, rightmargin => 50)->format($tree);
135		    };
136		    warn $@ if $@;
137		    push @errors, "Fehler beim �bertragen der Datei $src_file:\n" . $text . "\n";
138		} else {
139		    print STDERR " keine �nderung\n" if $main::verbose;
140		}
141	    } else {
142		if (!$success) {
143		    push @errors, "Fehler beim �bertragen der Datei $src_file";
144		}
145	    }
146	}
147	last if $fatal;
148	unlink $dest_file;
149    }
150    #main::finish_progress();
151    $main::progress->Finish;
152    if (@errors) {
153	main::status_message(join("\n", @errors), "warn");
154    }
155}
156
157sub create_modified_devel {
158    my(%args) = @_;
159    my $rootdir = "..";
160    my $datadir = $ENV{BBBIKE_DATADIR} || $rootdir . "/data";
161    if (!-f "$rootdir/bbbike" || !-d $datadir || !-f "$rootdir/MANIFEST") {
162	die "Probably wrong rootdir: $rootdir from `pwd`";
163    }
164
165    require Digest::MD5;
166
167    my %old_files;
168    if (open my $fh, "$datadir/.modified") {
169	while(<$fh>) {
170	    chomp;
171	    my($file, $timestamp, $md5) = split /\t/;
172	    $old_files{$file} = {timestamp => $timestamp, md5 => $md5};
173	}
174    } else {
175	warn "WARN: Cannot load $datadir/.modified: $!";
176    }
177
178    open my $ofh, ">", "$datadir/.modified~"
179	or die "Can't write to .modified~: $!";
180
181    open my $manifh, "$rootdir/MANIFEST"
182	or die "Can't open MANIFEST: $!";
183    while(<$manifh>) {
184	if (m|^data/(.*)|) {
185	    my $file = $1;
186	    next if $file =~ m|^\.|;
187
188	    my $md5 = do {
189		my $ctx = Digest::MD5->new;
190		open my $fh, "$datadir/$file"
191		    or die "Can't open $datadir/$file: $!";
192		$ctx->addfile($fh);
193		$ctx->hexdigest;
194	    };
195
196	    my $relfilename = "data/$file";
197	    my $use_mtime;
198	    if ($old_files{$relfilename} && $md5 eq $old_files{$relfilename}->{md5}) {
199		$use_mtime = $old_files{$relfilename}->{timestamp}; # don't change timestamp if possible
200	    } else {
201		my @stat = stat "$datadir/$file";
202		$use_mtime = $stat[9];
203	    }
204	    print $ofh join("\t", $relfilename, $use_mtime, $md5), "\n";
205	}
206    }
207    close $ofh
208	or die "While writing to .modified~: $!";
209    rename "$datadir/.modified~", "$datadir/.modified"
210	or die "Can't rename $datadir/.modified~ to $datadir/.modified: $!";
211}
212
213sub create_modified {
214    my(%args) = @_;
215    my $destdir = $args{-dest};
216    my $datadir = $destdir . "/data";
217    my(@files) = @{$args{-files}};
218    eval {
219	open(MOD, ">$datadir/.modified~") or die $!;
220	my @errors;
221	foreach my $file (@files) {
222	    my(@stat) = stat("$destdir/$file");
223	    if (!@stat) {
224		push @errors, "$destdir/$file: $!";
225		next;
226	    }
227	    print MOD join("\t", $file, $stat[9], "?"), "\n"
228		or die $!;
229	}
230	if (@errors) {
231	    main::status_message(M("Die folgenden Dateien haben Fehler erzeugt:\n") . join("\n", @errors),
232				 "die");
233	}
234	close MOD or die $!;
235    };
236    if ($@) {
237	warn "Can't write to $datadir/.modified: $@";
238    } else {
239	rename "$datadir/.modified~", "$datadir/.modified"
240	    or warn "Can't rename to $datadir/.modified: $!";
241    }
242}
243
244sub bbbike_data_update {
245    my(%args) = @_;
246    my $protocol = $args{-protocol} || "best";
247
248    my $rootdir = "$FindBin::RealBin";
249
250    my $my_die = sub { warn $_[0]; main::status_message($_[0], 'die') };
251    my $my_warn = sub { warn $_[0]; main::status_message($_[0], 'info') };
252
253    # sichergehen, dass nicht die Originaldateien �berschrieben werden...
254    $my_die->("FATAL: das ist ein Original-BBBike-Verzeichnis, welches nicht �berschrieben werden kann.")
255	if (-e "$rootdir/data/.original" ||
256	    -e "$rootdir/data/.archive");
257    $my_die->("FATAL: suspicious rootdir: $rootdir")
258	if ($rootdir =~ m|/home/e/eserte/src/bbbike|);
259    $my_die->("FATAL: Ein Verzeichnis RCS in $rootdir/data gefunden. Update nicht m�glich.")
260	if (-e "$rootdir/data/RCS");
261    $my_die->("FATAL: Ein Verzeichnis CVS in $rootdir/data gefunden. Update nicht m�glich. Es wird empfohlen, statt CVS git zu verwenden. Siehe README.")
262	if (-e "$rootdir/data/CVS");
263    $my_die->("FATAL: Ein Verzeichnis .svn in $rootdir/data gefunden. Update nicht m�glich. Subversion wird nicht unterst�tzt, bitte git verwenden. Siehe README.")
264	if (-e "$rootdir/data/.svn"); # will probably never happen
265    $my_die->("FATAL: Ein Verzeichnis .git in $rootdir gefunden. Bitte benutze 'git pull' in der Kommandozeile um die BBBike-Daten zu aktualisieren, oder entferne das Verzeichnis $rootdir/.git.")
266	if (-e "$rootdir/.git"); # if somebody is using github, or local git
267
268    if (!-w "$rootdir/data") {
269	main::status_message("Auf das Datenverzeichnis <$rootdir/data> darf nicht geschrieben werden.\n" .
270			     "Versuchen Sie die Update-Funktion als root oder System-Administrator.",
271			     "error");
272	return;
273    }
274
275    $my_die->("FATAL: Makefile in datadir detected")
276	if (-e "$rootdir/data/Makefile");
277
278    # assume http (or "best")
279    my(@files, %modified, %md5);
280    my $modfile = "$rootdir/data/.modified";
281    if (open(MOD, $modfile)) {
282	while(<MOD>) {
283	    chomp;
284	    my($f, $t, $md5) = split(/\t/);
285	    push @files, $f;
286	    $modified{$f} = $t;
287	    $md5{$f} = $t;
288	}
289	close MOD;
290	update_http(-dest => $rootdir,
291		    -root => $BBBike::BBBIKE_UPDATE_WWW,
292		    -files => \@files,
293		    -modified => \%modified,
294		    -md5 => \%md5,
295		   );
296	create_modified(-dest => $rootdir,
297			-files => \@files,
298		       );
299	main::reload_all();
300    } else {
301	main::status_message("Das Update konnte wegen einer fehlenden Datei ($modfile) nicht durchgef�hrt werden.", "error");
302    }
303}
304
3051;
306
307__END__
308