path: root/bin/checklinks

#!/usr/bin/env perl
## Copyright © 2008-2010 by Daniel Friesel <derf@finalrewind.org>
## License: WTFPL <http://sam.zoy.org/wtfpl>
use strict;
use warnings;
use 5.010;
use Cwd;
use Getopt::Long;
use Term::ANSIColor;

no if $] >= 5.018, warnings => "experimental::smartmatch"; 

my $base = $ENV{HOME};
my $msglevel = 0;
my $remove = 0;
my (%substitute, %bc_subst);
my $linkfile;
my $exit = 0;
my $ct_auto = 0;


sub mkdirs {
	my $source = shift;
	my $path = $base;
	my @dirs = split(/\//, $source);

	# the last element is the file
	pop(@dirs);

	for my $dir (@dirs) {
		if (not -d "$path/$dir") {
			mkdir("$path/$dir") or die("Can't create $path/$dir: $!");
		}
		$path .= "/$dir";
	}
	return;
}

sub dir_content {
	my ($dir) = @_;
	my @return;
	my ($normal_file, $dot_file);

	opendir(my $dh, $dir) or die("Cannot opendir $dir: $!");
	while (my $entry = readdir($dh)) {
		next if ($entry ~~ ['.', '..', '.git', '.hg', '.links', 'links']);

		push(@return, $entry);

		if (not $dot_file and $entry =~ /^\./) {
			$dot_file = 1;
		}
		elsif (not $normal_file) {
			$normal_file = 1
		}
	}

	if ($normal_file and $dot_file) {
		@return = grep { /^\./ } @return;
	}

	return @return;
}

sub print_format {
	my ($message, $src, $dst, $color, $level) = @_;

	if ($level > 1) {
		$exit++;
	}

	return if ($level < $msglevel);

	if (defined($color)) {
		printf(colored('%-9s', $color), $message);
	}
	else {
		printf('%-9s', $message);
	}

	printf(" %-15s -> %-15s\n", $src, $dst);
	return;
}

sub remove_link {
	my ($type, $src, $dst) = @_;

	if (($type eq 'soft' and -l "$base/$src")
	 or ($type eq 'hard' and -e "$base/$src" and -e "$base/$dst"))
	{
		unlink("$base/$src") or warn("cannot unlink $base/$src: $!");
		print_format('removed', $src, '', 'red', 1);
	}
	return;
}

sub check_symlink {
	my $src = shift;
	my $dst = shift;

	mkdirs($src);

	if (not -l "$base/$src" and not -e "$base/$src") {
		symlink($dst, "$base/$src");
		print_format('created', $src, $dst, 'cyan', 1);
	}
	elsif (-l "$base/$src" and readlink("$base/$src") eq $dst) {
		print_format('ok', $src, $dst, 'green', 0);
	}
	elsif (-l "$base/$src" and readlink("$base/$src") eq "$base/$dst") {
		print_format('absolute', $src, $dst, 'yellow', 0);
	}
	elsif (not -l "$base/$src" and -e "$base/$src") {
		print_format('exists', $src, $dst, 'bold red', 2);
	}
	elsif (-l "$base/$src") {
		unlink("$base/$src");
		symlink($dst, "$base/$src");
		print_format('fixed', $src, $dst, 'cyan', 1);
	}
	return;
}

sub check_hardlink {
	my $src = shift;
	my $dst = shift;

	mkdirs($src);

	if (not -e "$base/$dst") {
		print_format('no dest', $src, $dst, 'red bold', 2);
	}
	elsif (not -f "$base/$src") {
		link("$base/$dst", "$base/$src") or warn($!);
		print_format('created', $src, $dst, 'cyan', 1);
	}
	elsif ((stat("$base/$src"))[1] != (stat("$base/$dst"))[1]) {
		unlink("$base/$src");
		link("$base/$dst", "$base/$src") or warn($!);
		print_format('updated', $src, $dst, 'cyan', 1);
	}
	elsif ((stat("$base/$src"))[1] == (stat("$base/$dst"))[1]) {
		print_format('ok', $src, $dst, 'green', 0);
	}
	return;
}

sub loop_links {
	my $dir;
	my $cwd = cwd();

	if (-d 'etc') {
		$dir = 'etc';
	}
	elsif (!$ct_auto) {
		$dir = '.';
	}
	else {
		return;
	}

	foreach my $entry (dir_content($dir)) {
		my $source = $entry;
		if ($source !~ /^\./) {
			$source = ".$source";
		}

		if ($remove) {
			remove_link('soft', $source);
		}
		else {
			check_symlink($source, "$cwd/$dir/$entry");
		}
	}
	return;
}


GetOptions(
	'ct-auto' => \$ct_auto,
	'm|msglevel=i' => \$msglevel,
	'p|parameter=s' => \%substitute,
	'q|quiet'  => sub {$msglevel = 1},
	'r|remove' => \$remove,
);

foreach my $key (keys %substitute) {

	my $path = $substitute{$key};

	$path =~ s{ ^ $ENV{HOME} /}{}x;

	$bc_subst{$key} = $path;

}

if ($ct_auto) {
	loop_links();
	exit 0;
}
elsif (-f 'links') {
	$linkfile = 'links';
}

open(my $links, '<', $linkfile) or die("Cannot open $linkfile: $!");
while (my $line = <$links>) {
	chomp($line);

	foreach my $key (keys(%substitute)) {

		if ($line =~ / ^ \S+ \s+ \S+ \s+ \$ /x) {
			$line =~ s/\$$key/$substitute{$key}/g;
		}
		else {
			$line =~ s/\$$key/$bc_subst{$key}/g;
		}
	}

	my ($type, $src, $dst) = split(/\s+/, $line);

	next if (not($type ~~ ['soft', 'hard', 'auto']));

	if ($type eq 'auto') {
		loop_links();
	}
	else {
		if ($remove) {
			remove_link($type, $src, $dst);
		}
		elsif ($type eq 'soft') {
			check_symlink($src, $dst);
		}
		elsif ($type eq 'hard') {
			check_hardlink($src, $dst);
		}
	}
}
close($links) or die("Cannot close $linkfile: $!");


exit($exit);

__END__

=head1 NAME

checklinks - create/update links

=head1 SYNOPSIS

B<checklinks> [ I<options> ]

=head1 DESCRIPTION

Create or update links based on a file

=head1 OPTIONS

=over

=item B<-m>, B<--msglevel>=I<level>

Set the level threshold to show status messages.

   0  show everything
   1  filter "ok" and "absolute" messages
   2  filter everything but "EXISTS" and "no dst"
  >2  no messages

=item B<-p>, B<--parameter> I<parameter>=I<value>

While reading the links file, replace $I<parameter> with I<value>.

When used in conjuction with ct(1), $package will be set to the current
package's absolute path,
$etc will be set to $package/etc (e.g. C<~/packages/caretaker/etc>) and $pkgdir
will point to the package root (e.g. C<~/packages>). Also, for each of these
parameters, C<r_param> (e.g. $r_etc) is the corresponding relative path as
seen from $HOME.

=item B<-q>, B<--quiet>

Shortcut for C<< --msglevel=1 >>

=item B<-r>, B<--remove>

Remove all link sources (hardlinks: only if their destination exists)

=back

=head1 OUTPUT

Typical checklinks output might look like this:

  ok        .zshrc          -> packages/zsh/etc/rc
  ok        .zprofile       -> packages/zsh/etc/profile
  absolute  .zlogin         -> packages/zsh/etc/login
  created   .zlogout        -> packages/zsh/etc/logout
  ok        .zshenv         -> packages/zsh/etc/env

The first item is the status, the second the link source (as in, the link),
the third the link target.

The following status messages are possible:

=over

=item ok

The link exists and points to the right file

=item absolute (soft links only)

The link exists and points to the right file, however it is an absolute link

=item fixed (soft links only)

The link pointed to the wrong file and has been corrected

=item updated (hard links only)

The source existed, but was not identical to the target. It has been deleted
and replaced with a link to the target

=item created

The link did not exist and has been created

=item exists (soft links only)

The source already exists, but is not a symlink

=item no dest (hard links only)

The link destination does not exist and therefore cannot be hardlinked to

=back


=head1 FILES

The symlink definitions are read from the file F<.links> or F<links> in the
current working directory. Each line contains, separated by spaces:

=over

=item the symlink type

This may either be 'soft' or 'hard' (symlink / hardlink) or 'auto'.

If the type is B<auto>, the following fields may be omitted. Instead, the
notes in L</"AUTO SYMLINKS"> apply.



=item the source

path of the source, i.e. the link. Relative to $HOME

In symlink mode, the source will only be updated if it either does not exist or
already is a symlink. This should prevent accidental data loss.
Note that in hardlink mode, the source will I<always> be deleted unless it is
already the correct hardlink

=item the target

path of the target, i.e. the link's destination.
This is relative to the source. See L<path_resolution>(7)

=back


Lines beginning with an invalid symlink type will be ignored.
I recommend using a # to introduce comments, though, and not simply write
something into the file just because that is (technically) also ok ;)

Example:

  # checklinks --parameter etc=packages/zsh
  soft .zshrc $etc/rc
  soft .zprofile $etc/profile
  soft .zlogin $etc/login
  soft .zlogout $etc/logout
  soft .zshenv $etc/env

=head2 AUTO SYMLINKS

If the link type is 'auto', B<checklinks> will attempt to guess which files are
meant to be symlinked where.  However, be aware that this feature is highly
experimental and may be changed or removed in the future. So far it will
only create absolute links. Also, do not mix 'auto' with other link types.

Automatic symlinking works this way:
B<checklinks> takes all files in either F<etc/>, or (if that doesn't exist)
the current directory. All files in there will be symlinked as a dotfile from
your home. If the directory only contains normal files, their corresponding
symlink will have a . as prefix; if dotfiles are present, only these will be
symlinked to (without adding another . as prefix, of course).
This way, it is possibly to have various files in a directory, but only
symlink those which are dotfiles.

Example:

  remnant ~/p/zsh > ls -A etc
  completions      functions      hosts   .zlogout   .zshenv
  completions.zwc  functions.zwc  startx  .zprofile  .zshrc
  remnant ~/p/zsh > cat links
  auto
  remnant ~/p/zsh > checklinks
  ok        .zshenv         -> /home/derf/packages/zsh/etc/.zshenv
  ok        .zlogout        -> /home/derf/packages/zsh/etc/.zlogout
  ok        .zshrc          -> /home/derf/packages/zsh/etc/.zshrc
  ok        .zprofile       -> /home/derf/packages/zsh/etc/.zprofile

=head1 DIAGNOSTICS

The exit value is the number of files with grave errors
(a status of "exists" or "no dest").