path: root/ufed.pl.in

#!XX_PERL@
use strict;
use warnings;

# Copyright 1999-2014 Gentoo Foundation
# Distributed under the terms of the GNU General Public License v2
# $

use lib qw{XX_perldir@};
use Portage;

# 0 = normal, 1 = gdb, 2 = valgrind
use constant { EXEC => 0 };
# Note on PBP: Like Portage.pm one single value for debugging purposes is not
#              enough to justify an additional dependency, so this stays being
#              a (discouraged) constant.

my $version = 'XX_PACKAGE_VERSION@';

my $interface = 'ufed-curses';
my $gdb       = "gdb -ex run ufed-curses";
my $memcheck  = "/usr/bin/valgrind -v --trace-children=yes --tool=memcheck"
              . " --track-origins=yes --leak-check=full --show-reachable=no"
              . " --read-var-info=yes"
              . " XX_libexecdir@/ufed-curses 2>/tmp/ufed_memcheck.log";

sub finalise;
sub flags_dialog;
sub save_flags;


flags_dialog;


# Take a list and return it ordered the following way:
# Put "-*" first, followed by enabling flags and put disabling flags to the
# end.
# Parameters: list of flags
sub finalise {
	my @arg = @_;
	my @result = sort {
		($a ne '-*') <=> ($b ne '-*')
		||
		($a =~ /^-/) <=> ($b =~ /^-/)
		||
		$a cmp $b
	} @arg;
	return @result;
}

# Launch the curses interface. Communication is done using pipes. Waiting for
# pipe read/write to finish is done automatically.
# No parameters accepted.
sub flags_dialog {
	use POSIX ();
	POSIX::dup2 1, 3;
	POSIX::dup2 1, 4;
	my ($iread, $iwrite) = POSIX::pipe;
	my ($oread, $owrite) = POSIX::pipe;
	my $child = fork;
	die "fork() failed\n" if not defined $child;
	if($child == 0) {
		POSIX::close $iwrite;
		POSIX::close $oread;
		POSIX::dup2 $iread, 3;
		POSIX::close $iread;
		POSIX::dup2 $owrite, 4;
		POSIX::close $owrite;
		if (0 == EXEC) {
			exec { "XX_libexecdir@/$interface" } $interface or
			do { print STDERR "Couldn't launch $interface\n"; exit 3 }
		} elsif (1 == EXEC) {
			exec $gdb or
			do { print STDERR "Couldn't launch $interface\n"; exit 3 }
		} elsif (2 == EXEC) {
			exec $memcheck or
			do { print STDERR "Couldn't launch $interface\n"; exit 3 }
		} else {
			print STDERR "Value " . EXEC . " unknown for EXEC\n";
			exit 4;
		}
	}
	POSIX::close $iread;
	POSIX::close $owrite;
	my $outTxt = "";

	# Write out flags 
	for my $flag (sort { uc $a cmp uc $b } keys %$Portage::use_flags) {
		my $conf = $Portage::use_flags->{$flag}; ## Shortcut

		$outTxt .= sprintf ("%s [%s%s] %d\n", $flag,
					defined($conf->{global}{conf}) ?
						$conf->{global}{conf} > 0 ? '+' :
						$conf->{global}{conf} < 0 ? '-' : ' ' : ' ',
					defined($conf->{global}{"default"}) ?
						$conf->{global}{"default"} > 0 ? '+' :
						$conf->{global}{"default"} < 0 ? '-' : ' ' : ' ',
					$conf->{count});

		# Print global description first (if available)
		if (defined($conf->{global}) && length($conf->{global}{descr})) {
			$outTxt .= sprintf("\t%s\t%s\t ( ) [+%s%s%s   ]\n",
						$conf->{global}{descr},
						$conf->{global}{descr_alt},
						$conf->{global}{installed} ? '+' : ' ',
						$conf->{global}{forced} ? '+' : ' ',
						$conf->{global}{masked} ? '+' : ' ');
		}

		# Finally print the local description lines
		for my $pkg (sort keys %{$conf->{"local"}}) {
			$outTxt .= sprintf("\t%s\t%s\t (%s) [ %s%s%s%s%s%s]\n",
						$conf->{"local"}{$pkg}{descr},
						$conf->{"local"}{$pkg}{descr_alt},
						$pkg,
						$conf->{"local"}{$pkg}{installed} > 0 ? '+' :
						$conf->{"local"}{$pkg}{installed} < 0 ? '-' : ' ',
						$conf->{"local"}{$pkg}{forced}    > 0 ? '+' :
						$conf->{"local"}{$pkg}{forced}    < 0 ? '-' : ' ',
						$conf->{"local"}{$pkg}{masked}    > 0 ? '+' :
						$conf->{"local"}{$pkg}{masked}    < 0 ? '-' : ' ',
						$conf->{"local"}{$pkg}{"default"} > 0 ? '+' :
						$conf->{"local"}{$pkg}{"default"} < 0 ? '-' : ' ',
						$conf->{"local"}{$pkg}{"package"} > 0 ? '+' :
						$conf->{"local"}{$pkg}{"package"} < 0 ? '-' : ' ',
						$conf->{"local"}{$pkg}{pkguse}    > 0 ? '+' :
						$conf->{"local"}{$pkg}{pkguse}    < 0 ? '-' : ' ');
		}
	}

	# Some overlays (like sunrise) use UTF-8 characters in their
	# use descriptions. They cause problems unless the whole
	# interface is changed to use wchar. Substitute with ISO:
	$outTxt =~ tr/\x{2014}\x{201c}\x{201d}/\x2d\x22\x22/ ;

	# Now let the interface know of the result
	if (open my $fh, '>&=', $iwrite) {
		binmode( $fh, ":encoding(ISO-8859-1)" );

		# Fixed config:
		# byte 1: Read only 0/1
		# Rest: The flags configuration
		print $fh "$Portage::ro_mode$outTxt";
		close $fh;
	} else {
		die "Couldn't let interface know of flags\n";
	}
	POSIX::close $iwrite;
	wait;
	if(POSIX::WIFEXITED($?)) {
		my $rc = POSIX::WEXITSTATUS($?);
		if( (0 == $rc) && (0 == $Portage::ro_mode) ) {
			open my $fh, '<&=', $oread or die "Couldn't read output.\n";
			my @flags = grep { $_ ne '--*' } do { local $/; split /\n/, <$fh> };
			close $fh;
			save_flags finalise @flags;
		} elsif( 1 == $rc ) {
			print "Cancelled, not saving changes.\n";
		}
		exit $rc;
	} elsif(POSIX::WIFSIGNALED($?)) {
		kill (POSIX::WTERMSIG($?), $$);
	} else {
		exit 127;
	}
	return;
}


# Write given list of flags back to make.conf if the file has not been changed
# since reading it.
# Parameters: list of flags
sub save_flags {
	my (@flags) = @_;
	my $BLANK = qr{(?:[ \n\t]+|#.*)+};              # whitespace and comments
	my $UBLNK = qr{(?:                              # as above, but scan for #USE=
		[ \n\t]+ |
		\#[ \t]*USE[ \t]*=.*(\n?) | # place capture after USE=... line
		\#.*)+}x;
	my $IDENT = qr{([^ \\\n\t'"{}=#]+)};            # identifiers
	my $ASSIG = qr{=};                              # assignment operator
	my $UQVAL = qr{(?:           # guard to extend the character limit
		[^ \\\n\t'"#]{1,32766} | # max 32766 of regular characters or
		\\.                      # one escaped character
		){1,32766}               # extend by 32766 sub matches
	}sx;                                            # unquoted value
	my $SQVAL = qr{'(?:          # guard to extend the character limit
		[^']{0,32766}            # 0 to 32766 characters ...
		){0,32766}               # ... up to 32766 times
	'}x;                                            # singlequoted value
	my $DQVAL = qr{"(?:          # guard to extend the character limit
		[^\\"]{0,32766}        | # max 32766 non-escaped characters or
		\\.                      # one escaped character
		){0,32766}               # extend by up to 32766 sub matches
	"}sx;                                           # doublequoted value
	my $BNUQV = qr{(?:
		[^ \\\n\t'"#]{1,32766} | # Anything but escapes, quotes and so on
		\\\n()                 | # or a backslash followed by a newline
		\\.                      # or any other escape sequence
		){1,32766}               # extended like above
	}sx;                                            # unquoted value (scan for \\\n)
	my $BNDQV = qr{"(?:(?:       # double guard to extend more freely
		[^\\"]                 | # Anything but a backslash or double quote
		\\\n()                 | # or a backslash and a newline
		\\.                      # or any other escaped value
		){0,32766}){0,32766}     # max 32766*32766 matches.
	"}sx;                                           # doublequoted value (scan for \\\n)

	my $contents;

	my $makeconf_name = $Portage::used_make_conf;
	{
		open my $makeconf, '<', $makeconf_name or die "Couldn't open $makeconf_name\n";
		open my $makeconfold, '>', $makeconf_name . '~' or die "Couldn't open ${makeconf_name}~\n";
		local $/;
		$_ = <$makeconf>;
		print $makeconfold $_;
		close $makeconfold;
		close $makeconf;
	}

	my $sourcing = 0;
	eval {
		# USE comment start/end (start/end of newline character at the end, specifically)
		# default to end of make.conf, to handle make.confs without #USE=
		my($ucs, $uce) = (length, length);
		my $flags = '';
		pos = 0;
		for(;;) {
			if(/\G$UBLNK/gc) {
				($ucs, $uce) = ($-[1], $+[1]) if defined $1;
			}
			last if pos == length;
			my $flagatstartofline = do {
				my $linestart = 1+rindex $_, "\n", pos()-1;
				my $line = substr($_, $linestart, pos()-$linestart);
				$line !~ /[^ \t]/;
			};
			/\G$IDENT/gc or die "No identifier found to start with.";
			my $name = $1;
			/\G$BLANK/gc;
			if($name ne 'source') {
				/\G$ASSIG/gc or die "Identifier $name without assignement detected.";
				/\G$BLANK/gc;
			} else {
				$sourcing = 1;
			}
			pos == length and die "Bumped into early EOF.";
			if($name ne 'USE') {
				/\G(?:$UQVAL|$SQVAL|$DQVAL)+/gc or die "Blank assignement for $name detected.";
			} else {
				my $start = pos;
				m/\G(?:$BNUQV|$SQVAL|$BNDQV)+/gc or die "Empty USE assignement detected.";
				my $end = pos;

				# save whether user uses backslash-newline
				my $bsnl = defined $1 || defined $2;

				# start of the line is one past the last newline; also handles first line
				my $linestart = 1+rindex $_, "\n", $start-1;

				# everything on the current line before the USE flags, plus one for the "
				my $line = substr($_, $linestart, $start-$linestart).' ';

				# only indent if USE starts a line
				my $blank = $flagatstartofline ? $line : "";
				$blank =~ s/[^ \t]/ /g;

				# word wrap
				if(@flags != 0) {
					my $length = 0;
					while($line =~ /(.)/g) {
						if($1 ne "\t") {
							$length++;
						} else {
							# no best tab size discussions, please. terminals use ts=8.
							$length&=~8;
							$length+=8;
						}
					}
					my $blanklength = $blank ne '' ? $length : 0;

					# new line, using backslash-newline if the user did that
					my $nl = ($bsnl ? " \\\n" : "\n").$blank;
					my $linelength = $bsnl ? 76 : 78;
					my $flag = $flags[0];

					if($blanklength != 0 || length $flag <= $linelength) {
						$flags   = $flag;
						$length += length $flag;
					} else {
						$flags   = $nl.$flag;
						$length  = length $flag;
					}
					for my $flag (@flags[1..$#flags]) {
						if($length + 1 + length $flag <= $linelength) {
							$flags  .= " $flag";
							$length += 1+length $flag;
						} else {
							$flags  .= $nl.$flag;
							$length  = $blanklength + length $flag;
						}
					}
				}

				# replace the current USE flags with the modified ones
				substr($_, $start, $end-$start) = "\"$flags\"";

				# and have the next search start after our new flags
				pos = $start + 2 + length $flags;

				# and end this
				undef $flags;
				last;
			}
		}

		if(defined $flags) {

			# if we didn't replace the flags, tack them after the last #USE= or at the end
			$flags = '';
			if(@flags != 0) {
				$flags = $flags[0];
				my $length = 5 + length $flags[0];
				for my $flag(@flags[1..$#flags]) {
					if($length + 1 + length $flag <= 78) {
						$flags  .= " $flag";
						$length += 1+length $flag;
					} else {
						$flags  .= "\n     $flag";
						$length  = 5+length $flag;
					}
				}
			}
			substr($_, $ucs, $uce-$ucs) = "\nUSE=\"$flags\"\n";
		} else {

			# if we replaced the flags, delete any further overrides
			for(;;) {
				my $start = pos;
				/\G$BLANK/gc;
				last if pos == length;
				/\G$IDENT/gc or die "Identifier detection failed.";
				my $name = $1;
				/\G$BLANK/gc;
				if($name ne 'source') {
					/\G$ASSIG/gc or die "Identifier $name without assignement detected.";
					/\G$BLANK/gc;
				} else {
					$sourcing = 1;
				}
				m/\G(?:$UQVAL|$SQVAL|$DQVAL)+/gc or die "Empty assignement for $name detected.";
				my $end = pos;
				if($name eq 'USE') {
					substr($_, $start, $end-$start) = '';
					pos = $start;
				}
			}
		}
	};
	defined($@) and length($@) and chomp $@
		and die "\nParse error when writing make.conf"
		. " - did you modify it while ufed was running?\n"
		. " - Error: \"$@\"\n";

	print STDERR <<EOF if $sourcing;
Warning: source command found in $makeconf_name. Flags may
be saved incorrectly if the sourced file modifies them.
EOF
	{
		open my $makeconf, '>', $makeconf_name or die "Couldn't open $makeconf_name\n";
		print $makeconf $_;
		close $makeconf;
		$makeconf_name =~ /\/make\.conf$/
			or print "USE flags written to $makeconf_name\n";
	}
	
	return;
}