view release on metacpan or  search on metacpan

lib/Env/PS1.pm  view on Meta::CPAN

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__

=head1 NAME

Env::PS1 - prompt string formatter