Env::PS1 - prompt string formatter

	# use the import function
	use Env::PS1 qw/$PS1/;
	$ENV{PS1} = '\u@\h \$ ';
	print $PS1;
	$readline = <STDIN>;

	# or tie it yourself
	tie $prompt, 'Env::PS1', 'PS1';

	# you can also tie a scalar ref
	$format = '\u@\h\$ ';
	tie $prompt, 'Env::PS1', \$format;

package Env::PS1;

use strict;
use Carp;
use AutoLoader 'AUTOLOAD';

our $VERSION = 0.06;

our $_getpwuid = eval { getpwuid($>) }; # Not supported on some platforms

sub import {
	my $class = shift;
	return unless @_;
	my ($caller) = caller;
	for (@_) {
		/^\$(.+)/ or croak qq/$class can't export "$_", try "\$$_"/;
		no strict 'refs';
		tie ${"$caller\::$1"}, $class, $1;
	}
}

sub TIESCALAR {
	my ($class, $var) = @_;
	my $self = bless {
		var    => $var || 'PS1',
		format => '',
	}, $class;
	$self->cache();
	return $self;
}

sub STORE {
	my $self = shift;
	if (ref $$self{var}) { ${$$self{var}} = shift }
	else { $ENV{$$self{var}} = shift }
}

sub FETCH {
	my $self = shift;
	my $format = ref($$self{var}) ? ${$$self{var}} : $ENV{$$self{var}} ;
	$format =~ s#(\\\\)|(?<!\\)\$(?:(\w+)|\{(.*?)\})#
				$1 ? '\\\\' : $2 ? $ENV{$2} : $ENV{$3}
		#ge;
        unless ($format eq $$self{format} and exists $ENV{CLICOLOR}
                and $ENV{CLICOLOR} eq $$self{clicolor}) {
		@$self{qw/format clicolor/} = ($format, $ENV{CLICOLOR});
		$$self{cache} = [ $self->cache($format) ];
	}
	my $string = join '', map { ref($_) ? $_->() : $_ } @{$$self{cache}};
        $string =~ s#\$\((.+)\)#
                    `$1`;
                #ge;
	return $string;
}

sub sprintf {
	my $format = pop;
	$format =~ s#(\\\\)|(?<!\\)\$(?:(\w+)|\{(.*?)\})#
				$1 ? '\\\\' : $2 ? $ENV{$2} : $ENV{$3}
		#ge;
	return join '', map { ref($_) ? $_->() : $_ } Env::PS1->cache($format);
}

our @user_info; # ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$dir,$shell,$expire)
our %map; # for custom stuff
our %alias = (
	'$' => 'dollar',
	'@' => 'D', t => 'D', T => 'D', A => 'D',
);

sub cache {
	my ($self, $format) = @_;
	return '' unless defined $format; # get rid of uninitialised warnings
	@user_info = getpwuid($>) if $_getpwuid;
	my @parts;
	#print "# string: $format\n";
	while ($format =~ s/^(.*?)(\\\\|\\([aenr]|0\d\d)|\\(.)|!)//s) {
		push @parts, $1 || '';
		if ($2 eq '\\\\') { push @parts, '\\' } # stripped when \! is substitued
		elsif ($2 eq '!') { push @parts, '!!' } # posix prompt escape :$
		elsif ($3) { push @parts, eval qq/"\\$3"/ }
		elsif (exists $map{$4}) {
			my $item = $map{$4};
			if (ref $item and $format =~ s/^\{(.*?)\}//) {
				push @parts, $item->($1); # obscure foo
			}
			else { push @parts, $item }
	       	}
		elsif (grep {$4 eq $_} qw/C D P/) { # special cases
			my $sub = $4 ;
			$format =~ s/^\{(.*?)\}//;
			push @parts, $self->$sub($sub, $1);
		}
		elsif ($4 eq '[' or $4 eq ']') { next }
		else {
			my $sub = exists($alias{$4}) ? $alias{$4} : uc($4) ;
			push @parts, $self->can($sub) ? ($self->$sub($4)) : $4;
		}
	}
	push @parts, $format;
	my @cache = ('');
	for (@parts) { # optimise: join strings, push code refs
		if (ref $_ or ref $cache[-1]) { push @cache, $_ }
		else { $cache[-1] .= $_ }
	}
	return @cache;
}

## format subs

sub U { $user_info[0] || $ENV{USER} || $ENV{LOGNAME} }

sub W { 
	return sub { $ENV{PWD} eq $ENV{HOME} ? "~" : $ENV{PWD} } if $_[1] eq 'w';
	return sub {
		return '/' if $ENV{PWD} eq '/';
                if($ENV{PWD} eq $ENV{HOME}) {
                  return "~";
                }
		$ENV{PWD} =~ m#([^/]*)/?$#;
		return $1;
	};
}

## others defined below for Autoload

1;

__END__

sub D  {
	return sub {
		my $t = localtime;
		$t =~ m/^(\w+\s+\w+\s+\d+)/;
		return $1;
	} if $_[1] eq 'd';

	use POSIX qw(strftime);
	my $format =
		($_[1] eq 't') ? '%H:%M:%S' :
		($_[1] eq 'T') ? '%I:%M:%S' :
		($_[1] eq '@') ? '%I:%M %p' :
		($_[1] eq 'A') ? '%H:%M'    : $_[2] ;

	return sub { strftime $format, localtime };
}

sub S {
	$0 =~ m#([^/]*)$#;
	return $1 || '';
}

sub dollar { $user_info[2] ? '$' : '#' }

sub H {
	use Sys::Hostname;
	no warnings;
	*H = sub {
		my $h = &hostname;
		$h =~ s#\..*$## if $_[1] eq 'h';
		return $h;
	};
	return &H;
}

sub L { # How platform dependent is this ?
	use POSIX qw/ttyname/;
	no warnings;
	*L = sub {
		my $t = ttyname(*STDOUT);
		$t =~ s#.*/## if $_[1] eq 'l';
		return $t;
	};
	return &L;
}

sub C {
	our %colours = ( # Copied from Term::ANSIScreen
		'clear'      => 0,    'reset'      => 0,
		'bold'       => 1,    'dark'       => 2,
		'underline'  => 4,    'underscore' => 4,
		'blink'      => 5,    'reverse'    => 7,
		'concealed'  => 8,

		'black'      => 30,   'on_black'   => 40,
		'red'        => 31,   'on_red'     => 41,
		'green'      => 32,   'on_green'   => 42,
		'yellow'     => 33,   'on_yellow'  => 43,
		'blue'       => 34,   'on_blue'    => 44,
		'magenta'    => 35,   'on_magenta' => 45,
		'cyan'       => 36,   'on_cyan'    => 46,
		'white'      => 37,   'on_white'   => 47,
	);
	no warnings;
	*C = sub {
		return if defined $ENV{CLICOLOR} and ! $ENV{CLICOLOR};
		my @attr = split ',', $_[2];
		#print "# $_[2] => \\e[" . join(';', map {$colours{lc($_)}} @attr) . "m\n";
		return "\e[" . join(';', map {$colours{lc($_)}} @attr) . "m";
	};
	C(@_);
}

# $ uptime
# 17:38:53 up  3:24,  2 users,  load average: 0.04, 0.10, 0.13

sub P {
	my ($self, undef, $format) = @_;
	my %code;
	$format =~ s/\%(.)/$code{$1}++; "'.\$proc{$1}.'"/ge;
	my @subs = grep exists($code{$_}), qw/a b t/;

	return sub {
		my %proc;
		for my $s (@subs) {
			my $sub = "P_$s";
			$proc{$s} = $self->$sub();
		}
		if (open UP, 'uptime|') {
			my $up = <UP>;
			close UP;
			$up =~ /up\s*(\d+:\d+)/ and $proc{u} = $1;
			$up =~ /(\d+)\s*user/     and $proc{w} = $1;
			$up =~ /((\d+\.\d+),\s*\d+\.\d+,\s*\d+\.\d+)/
				and @proc{'L', 'l'} = ($1, $2);
		}
		#use Data::Dumper; print "'$format'", Dumper \%proc, "\n";
		eval "'$format'"; # all in single quote, except for escapes
	}
}

sub P_a {
	open(AC,'/proc/acpi/ac_adapter/AC/state') or return '?';
	my $a = <AC>;
	close AC;
	return ( ($a =~ /on/) ? '+' : '-' );
}

sub P_b {
	open(BAT,'/proc/acpi/battery/BAT0/state') or return '?';
	my ($b) = grep /^remaining capacity:/, (<BAT>);
	close BAT;
	$b =~ /(\d+)/;
	return $1 || '0';
}

sub P_t {
	open(TH, '/proc/acpi/thermal_zone/THM/temperature') or return '?';
	my $t = <TH>;
	close TH;
	$t =~ /(\d+)/;
	return $1 || '0';
}