1#! /usr/bin/perl
2
3# ex:ts=8 sw=4:
4# $OpenBSD: PkgCheck.pm,v 1.28 2010/12/29 13:03:05 espie Exp $
5#
6# Copyright (c) 2003-2010 Marc Espie <espie@openbsd.org>
7#
8# Permission to use, copy, modify, and distribute this software for any
9# purpose with or without fee is hereby granted, provided that the above
10# copyright notice and this permission notice appear in all copies.
11#
12# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
13# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
14# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
15# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
16# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
17# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
18# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
19
20use strict;
21use warnings;
22
23use OpenBSD::AddCreateDelete;
24use OpenBSD::SharedLibs;
25
26package OpenBSD::PackingElement;
27sub thorough_check
28{
29	my ($self, $state) = @_;
30	$self->basic_check($state);
31}
32
33sub basic_check
34{
35}
36
37sub find_dependencies
38{
39}
40
41package OpenBSD::PackingElement::FileBase;
42use File::Basename;
43
44sub basic_check
45{
46	my ($self, $state) = @_;
47
48	my $name = $state->{destdir}.$self->fullname;
49	$state->{known}{dirname($name)}{basename($name)} = 1;
50	if ($self->{symlink}) {
51		if (!-l $name) {
52			if (!-e $name) {
53				$state->log("#1 should be a symlink but does not exist", $name);
54			} else {
55				$state->log("#1 is not a symlink", $name);
56			}
57		} else {
58			if (readlink($name) ne $self->{symlink}) {
59				$state->log("#1 should point to #2 but points to #3 instead",
60				    $name, $self->{symlink}, readlink($name));
61			}
62		}
63		return;
64	}
65	if (!-e $name) {
66		if (-l $name) {
67			$state->log("#1 points to non-existent #2",
68			    $name, readlink($name));
69		} else {
70			$state->log("#1 should exist", $name);
71		}
72	}
73	if (!-f _) {
74		$state->log("#1 is not a file", $name);
75	}
76	if ($self->{link}) {
77		my ($a, $b) = (stat _)[0, 1];
78		if (!-f $state->{destdir}.$self->{link}) {
79			$state->log("#1 should link to non-existent #2",
80			    $name, $self->{link});
81		} else {
82			my ($c, $d) = (stat _)[0, 1];
83			if (defined $a && defined $c) {
84				if ($a != $c || $b != $d) {
85					$state->log("#1 doesn't link to #2",
86					    $name, $self->{link});
87				}
88			}
89		}
90	}
91}
92
93sub thorough_check
94{
95	my ($self, $state) = @_;
96	my $name = $state->{destdir}.$self->fullname;
97	$self->basic_check($state);
98	return if $self->{link} or $self->{symlink} or $self->{nochecksum};
99	if (!-r $name) {
100		$state->log("can't read #1", $name);
101		return;
102	}
103	my $d = $self->compute_digest($name);
104	if (!$d->equals($self->{d})) {
105		$state->log("checksum for #1 does not match", $name);
106	}
107}
108
109package OpenBSD::PackingElement::SpecialFile;
110sub basic_check
111{
112	&OpenBSD::PackingElement::FileBase::basic_check;
113}
114
115sub thorough_check
116{
117	&OpenBSD::PackingElement::FileBase::basic_check;
118}
119
120package OpenBSD::PackingElement::DirlikeObject;
121sub basic_check
122{
123	my ($self, $state) = @_;
124	my $name = $state->{destdir}.$self->fullname;
125	$state->{known}{$name} //= {};
126	if (!-e $name) {
127		$state->log("#1 should exist", $name);
128	}
129	if (!-d _) {
130		$state->log("#1 is not a directory", $name);
131	}
132}
133
134package OpenBSD::PackingElement::Mandir;
135sub basic_check
136{
137	my ($self, $state) = @_;
138	$self->SUPER::basic_check($state);
139	my $name = $state->{destdir}.$self->fullname;
140	$state->{known}{$name}{'whatis.db'} = 1;
141}
142
143package OpenBSD::PackingElement::Fontdir;
144sub basic_check
145{
146	my ($self, $state) = @_;
147	$self->SUPER::basic_check($state);
148	my $name = $state->{destdir}.$self->fullname;
149	for my $i (qw(fonts.alias fonts.scale fonts.dir)) {
150		$state->{known}{$name}{$i} = 1;
151	}
152}
153
154package OpenBSD::PackingElement::Infodir;
155sub basic_check
156{
157	my ($self, $state) = @_;
158	$self->SUPER::basic_check($state);
159	my $name = $state->{destdir}.$self->fullname;
160	$state->{known}{$name}{'dir'} = 1;
161}
162
163package OpenBSD::PackingElement::Dependency;
164sub find_dependencies
165{
166	my ($self, $state, $l, $checker) = @_;
167	# several ways to failure
168	if (!$self->spec->is_valid) {
169		$state->log("invalid \@", $self->keyword, " ",
170		    $self->stringize);
171		return;
172	}
173	my @deps = $self->spec->filter(@$l);
174	if (@deps == 0) {
175		$state->log("dependency #1 does not match any installed package",
176		    $self->stringize);
177		return;
178	}
179	my $okay = 0;
180	for my $i (@deps) {
181		if ($checker->find($i)) {
182			$okay = 1;
183		}
184	}
185	if (!$okay) {
186		$checker->not_found($deps[0]);
187	}
188}
189
190package OpenBSD::PackingElement::Wantlib;
191sub find_dependencies
192{
193	my ($self, $state, $l, $checker) = @_;
194	my $r = OpenBSD::SharedLibs::lookup_libspec($state->{localbase},
195	    $self->spec);
196	if (defined $r && @$r != 0) {
197		my $okay = 0;
198		for my $lib (@$r) {
199			my $i = $lib->origin;
200			if ($i eq 'system') {
201				$okay = 1;
202				next;
203			}
204			if ($checker->find($i)) {
205				$okay = 1;
206			}
207		}
208		if (!$okay) {
209			$checker->not_found($r->[0]->origin);
210		}
211	} else {
212		$state->log("#1 not found", $self->stringize);
213	}
214}
215
216package OpenBSD::PkgCheck::State;
217our @ISA = qw(OpenBSD::AddCreateDelete::State);
218
219use OpenBSD::Log;
220
221sub init
222{
223	my $self = shift;
224	$self->{l} = OpenBSD::Log->new($self);
225	$self->SUPER::init;
226}
227
228sub log
229{
230	my $self = shift;
231	if (@_ == 0) {
232		return $self->{l};
233	} else {
234		$self->{l}->say(@_);
235	}
236}
237
238sub safe
239{
240	my ($self, $_) = @_;
241	s/[^\w\d\s\+\-\.\>\<\=\/\;\:\,\(\)\[\]]/?/g;
242	return $_;
243}
244
245sub handle_options
246{
247	my $self = shift;
248	$self->{no_exports} = 1;
249
250	$self->SUPER::handle_options('fiq',
251		'[-fimnqvx] [-B pkg-destdir] [-D value]');
252	$self->{interactive} = $self->opt('i');
253	$self->{force} = $self->opt('f');
254	$self->{quick} = $self->opt('q');
255	if (defined $self->opt('B')) {
256		$self->{destdir} = $self->opt('B');
257	} elsif (defined $ENV{'PKG_PREFIX'}) {
258		$self->{destdir} = $ENV{'PKG_PREFIX'};
259	}
260	if (defined $self->{destdir}) {
261		$self->{destdir} .= '/';
262		$ENV{'PKG_DESTDIR'} = $self->{destdir};
263	} else {
264		$self->{destdir} = '';
265		delete $ENV{'PKG_DESTDIR'};
266	}
267}
268
269package OpenBSD::DependencyCheck;
270
271sub new
272{
273	my ($class, $state, $name, $req) = @_;
274	my $o = bless {
275		not_yet => {},
276		possible => {},
277		others => {},
278		name => $name,
279		req => $req
280	    }, $class;
281	for my $pkg ($req->list) {
282		$o->{not_yet}{$pkg} = 1;
283		if ($state->{exists}{$pkg}) {
284			$o->{possible}{$pkg} = 1;
285		} else {
286			$state->errsay("#1: bogus #2",
287			    $name, $o->string($state->safe($pkg)));
288		}
289	}
290	return $o;
291}
292
293sub find
294{
295	my ($self, $name) = @_;
296	if ($self->{possible}{$name}) {
297		delete $self->{not_yet}{$name};
298		return 1;
299	} else {
300		return 0;
301	}
302}
303
304sub not_found
305{
306	my ($self, $name) = @_;
307	$self->{others}{$name} = 1;
308}
309
310sub ask_delete_deps
311{
312	my ($self, $state, $l) = @_;
313	if ($state->{force}) {
314		$self->{req}->delete(@$l);
315	} elsif ($state->{interactive}) {
316		require OpenBSD::Interactive;
317		if (OpenBSD::Interactive::confirm("Remove missing ".
318		    $state->safe($self->string(@$l)))) {
319			$self->{req}->delete(@$l);
320		}
321	}
322}
323
324sub ask_add_deps
325{
326	my ($self, $state, $l) = @_;
327	if ($state->{force}) {
328		$self->{req}->add(@$l);
329	} elsif ($state->{interactive}) {
330		require OpenBSD::Interactive;
331		if (OpenBSD::Interactive::confirm("Add missing ".
332		    $self->string(@$l))) {
333			$self->{req}->add(@$l);
334		}
335	}
336}
337
338sub adjust
339{
340	my ($self, $state) = @_;
341	if (keys %{$self->{not_yet}} > 0) {
342		my @todo = sort keys %{$self->{not_yet}};
343		unless ($state->{subst}->value("weed_libs")) {
344			@todo = grep {!/^\.libs/} @todo;
345		}
346		if (@todo != 0) {
347			$state->errsay("#1 has too many #2",
348			    $self->{name}, $state->safe($self->string(@todo)));
349			$self->ask_delete_deps($state, \@todo);
350		}
351	}
352	if (keys %{$self->{others}} > 0) {
353		my @todo = sort keys %{$self->{others}};
354		$state->errsay("#1 is missing #2",
355		    $self->{name}, $self->string(@todo));
356		    if ($self->{name} =~ m/^partial/) {
357			    $state->errsay("not a problem, since this is a partial- package");
358		    } else {
359			    $self->ask_add_deps($state, \@todo);
360		    }
361	}
362}
363
364package OpenBSD::DirectDependencyCheck;
365our @ISA = qw(OpenBSD::DependencyCheck);
366use OpenBSD::RequiredBy;
367sub string
368{
369	my $self = shift;
370	return "dependencies: ". join(' ', @_);
371}
372
373sub new
374{
375	my ($class, $state, $name) = @_;
376	return $class->SUPER::new($state, $name,
377	    OpenBSD::Requiring->new($name));
378}
379
380package OpenBSD::ReverseDependencyCheck;
381our @ISA = qw(OpenBSD::DependencyCheck);
382use OpenBSD::RequiredBy;
383sub string
384{
385	my $self = shift;
386	return "reverse dependencies: ". join(' ', @_);
387}
388
389sub new
390{
391	my ($class, $state, $name) = @_;
392	return $class->SUPER::new($state, $name,
393	    OpenBSD::RequiredBy->new($name));
394}
395
396package OpenBSD::PkgCheck;
397our @ISA = qw(OpenBSD::AddCreateDelete);
398
399use OpenBSD::PackageInfo;
400use OpenBSD::PackingList;
401use File::Find;
402use OpenBSD::Paths;
403use OpenBSD::Mtree;
404
405sub remove
406{
407	my ($self, $state, $name) = @_;
408	$state->{removed}{$name} = 1;
409	my $dir = installed_info($name);
410	for my $i (@OpenBSD::PackageInfo::info) {
411		if (-e $dir.$i) {
412			if ($state->verbose) {
413				$state->say("unlink(#1)", $dir.$i);
414			}
415			unless ($state->{not}) {
416				unlink($dir.$i) or
417				    $state->errsay("#1: Couldn't delete #2: #3",
418				    	$name, $dir.$i, $!);
419			}
420		}
421	}
422	if (-f $dir) {
423		if ($state->verbose) {
424			$state->say("unlink(#1)", $dir);
425		}
426		unless ($state->{not}) {
427			unlink($dir) or
428			    $state->errsay("#1: Couldn't delete #2: #3",
429				$name, $dir, $!);
430		}
431	} elsif (-d $dir) {
432		if ($state->verbose) {
433			$state->say("rmdir(#1)", $dir);
434		}
435		unless ($state->{not}) {
436			rmdir($dir) or
437			    $state->errsay("#1: Couldn't delete #2: #3",
438			    	$name, $dir, $!);
439		}
440	}
441}
442
443sub may_remove
444{
445	my ($self, $state, $name) = @_;
446	if ($state->{force}) {
447		$self->remove($state, $name);
448	} elsif ($state->{interactive}) {
449		require OpenBSD::Interactive;
450		if (OpenBSD::Interactive::confirm("Remove wrong package $name")) {
451			$self->remove($state, $name);
452		}
453	}
454	$state->{bogus}{$name} = 1;
455}
456
457sub for_all_packages
458{
459	my ($self, $state, $l, $msg, $code) = @_;
460
461	$state->progress->for_list($msg, $l,
462	    sub {
463		return if $state->{removed}{$_[0]};
464		if ($state->{bogus}{$_[0]}) {
465			$state->errsay("skipping #1", $_[0]);
466			return;
467		}
468		&$code;
469	    });
470}
471
472sub sanity_check
473{
474	my ($self, $state, $l) = @_;
475	$self->for_all_packages($state, $l, "Packing-list sanity", sub {
476		my $name = shift;
477		my $info = installed_info($name);
478		if (-f $info) {
479			$state->errsay("#1: #2 should be a directory",
480			    $state->safe($name), $state->safe($info));
481			if ($info =~ m/\.core$/) {
482				$state->errsay("looks like a core dump, ".
483					"removing");
484				$self->remove($state, $name);
485			} else {
486				$self->may_remove($state, $name);
487			}
488			return;
489		}
490		my $contents = $info.OpenBSD::PackageInfo::CONTENTS;
491		unless (-f $contents) {
492			$state->errsay("#1: missing #2",
493			    $state->safe($name), $state->safe($contents));
494			$self->may_remove($state, $name);
495			return;
496		}
497		my $plist;
498		eval {
499			$plist = OpenBSD::PackingList->fromfile($contents);
500		};
501		if ($@ || !defined $plist) {
502			$state->errsay("#1: bad packing-list", $state->safe($name));
503			$self->may_remove($state, $name);
504			return;
505		}
506		if ($plist->pkgname ne $name) {
507			$state->errsay("#1: pkgname does not match",
508			    $state->safe($name));
509			$self->may_remove($state, $name);
510		}
511		$plist->mark_available_lib($plist->pkgname);
512		$state->{exists}{$plist->pkgname} = 1;
513	});
514}
515
516sub dependencies_check
517{
518	my ($self, $state, $l) = @_;
519	OpenBSD::SharedLibs::add_libs_from_system($state->{destdir}, $state);
520	$self->for_all_packages($state, $l, "Direct dependencies", sub {
521		my $name = shift;
522		my $plist = OpenBSD::PackingList->from_installation($name,
523		    \&OpenBSD::PackingList::DependOnly);
524		my $checker = OpenBSD::DirectDependencyCheck->new($state,
525		    $name);
526		$state->{localbase} = $plist->localbase;
527		$plist->find_dependencies($state, $l, $checker);
528		$checker->adjust($state);
529		for my $dep ($checker->{req}->list) {
530			push(@{$state->{reverse}{$dep}}, $name);
531		}
532	});
533}
534
535sub reverse_dependencies_check
536{
537	my ($self, $state, $l) = @_;
538	$self->for_all_packages($state, $l, "Reverse dependencies", sub {
539		my $name = shift;
540		my $checker = OpenBSD::ReverseDependencyCheck->new($state,
541		    $name);
542		for my $i (@{$state->{reverse}{$name}}) {
543			$checker->find($i) or $checker->not_found($i);
544		}
545		$checker->adjust($state);
546	});
547}
548
549sub package_files_check
550{
551	my ($self, $state, $l) = @_;
552	$self->for_all_packages($state, $l, "Files from packages", sub {
553		my $name = shift;
554		my $plist = OpenBSD::PackingList->from_installation($name);
555		$state->log->set_context($name);
556		if ($plist->is_signed && !$state->defines('nosig')) {
557			require OpenBSD::x509;
558
559			if (!OpenBSD::x509::check_signature($plist, $state)) {
560				$state->fatal("#1 is corrupted", $name);
561			}
562		}
563		if ($state->{quick}) {
564			$plist->basic_check($state);
565		} else {
566			$plist->thorough_check($state);
567		}
568		$plist->mark_available_lib($plist->pkgname);
569	});
570}
571
572sub localbase_check
573{
574	my ($self, $state) = @_;
575	$state->{known} //= {};
576	my $base = $state->{destdir}.OpenBSD::Paths->localbase;
577	$state->{known}{$base."/man"}{'whatis.db'} = 1;
578	$state->{known}{$base."/info"}{'dir'} = 1;
579	$state->{known}{$base."/lib/X11"}{'app-defaults'} = 1;
580	$state->{known}{$base."/libdata"} = {};
581	$state->{known}{$base."/libdata/perl5"} = {};
582	# XXX
583	OpenBSD::Mtree::parse($state->{known}, $base,
584	    "/etc/mtree/BSD.local.dist", 1);
585	$state->progress->set_header("Other files");
586	find(sub {
587		$state->progress->working(1024);
588		if (-d $_) {
589			if ($File::Find::name eq
590			    OpenBSD::Paths->localbase."/lost+found") {
591				$state->say("fsck(8) info found: #1",
592				    $File::Find::name);
593				$File::Find::prune = 1;
594				return;
595			}
596			return if defined $state->{known}{$File::Find::name};
597			if (-l $_) {
598				return if $state->{known}{$File::Find::dir}{$_};
599			}
600			$state->say("Unknown directory #1", $File::Find::name);
601		} else {
602			return if $state->{known}{$File::Find::dir}{$_};
603			$state->say("Unknown file #1", $File::Find::name);
604		}
605	}, OpenBSD::Paths->localbase);
606}
607
608sub run
609{
610	my ($self, $state) = @_;
611
612	my @list = installed_packages();
613	$self->sanity_check($state, \@list);
614	$self->dependencies_check($state, \@list);
615	$state->log->dump;
616	$self->reverse_dependencies_check($state, \@list);
617	$state->log->dump;
618	$self->package_files_check($state, \@list);
619	$state->log->dump;
620	$self->localbase_check($state);
621	$state->progress->next;
622}
623
624sub parse_and_run
625{
626	my ($self, $cmd) = @_;
627
628	my $state = OpenBSD::PkgCheck::State->new($cmd);
629	$state->handle_options;
630	if (@ARGV != 0) {
631		$state->usage;
632	}
633	lock_db(0, $state) unless $state->{subst}->value('nolock');
634	$self->run($state);
635	return 0;
636}
637
6381;
639