r33767 - in /branches/upstream/libenv-ps1-perl: ./ current/ current/lib/ current/lib/Env/ current/t/

ryan52-guest at users.alioth.debian.org ryan52-guest at users.alioth.debian.org
Thu Apr 23 15:00:34 UTC 2009


Author: ryan52-guest
Date: Thu Apr 23 15:00:29 2009
New Revision: 33767

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=33767
Log:
[svn-inject] Installing original source of libenv-ps1-perl

Added:
    branches/upstream/libenv-ps1-perl/
    branches/upstream/libenv-ps1-perl/current/
    branches/upstream/libenv-ps1-perl/current/Build.PL
    branches/upstream/libenv-ps1-perl/current/Changes
    branches/upstream/libenv-ps1-perl/current/MANIFEST
    branches/upstream/libenv-ps1-perl/current/META.yml
    branches/upstream/libenv-ps1-perl/current/Makefile.PL
    branches/upstream/libenv-ps1-perl/current/README
    branches/upstream/libenv-ps1-perl/current/example.pl
    branches/upstream/libenv-ps1-perl/current/lib/
    branches/upstream/libenv-ps1-perl/current/lib/Env/
    branches/upstream/libenv-ps1-perl/current/lib/Env/PS1.pm
    branches/upstream/libenv-ps1-perl/current/t/
    branches/upstream/libenv-ps1-perl/current/t/00_usage.t

Added: branches/upstream/libenv-ps1-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/Build.PL?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/Build.PL (added)
+++ branches/upstream/libenv-ps1-perl/current/Build.PL Thu Apr 23 15:00:29 2009
@@ -1,0 +1,17 @@
+use Module::Build;
+
+Module::Build->new(
+	module_name => 'Env::PS1',
+	license     => 'perl',
+	dist_author => 'Jaap Karssenberg <pardus at cpan.org>',
+	requires    => {
+		'AutoLoader'    => 0,
+		'Sys::Hostname' => 0,
+		'POSIX'         => 0,
+	},
+	build_requires => {
+		'AutoSplit'     => 0,
+	},
+	autosplit => 'lib/Env/PS1.pm',
+	create_makefile_pl => 'passthrough',
+)->create_build_script;

Added: branches/upstream/libenv-ps1-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/Changes?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/Changes (added)
+++ branches/upstream/libenv-ps1-perl/current/Changes Thu Apr 23 15:00:29 2009
@@ -1,0 +1,41 @@
+ Revision history for Env-PS1 - prompt string formatter
+========================================================
+
+0.05 Mon Nov 22 2004
+	Maintenance release
+
+     Thu Nov 18
+	- Added the interpolation of environment variables
+	- Altered escape removal a little bit
+
+     Mon Aug 30
+        - Env::PS1 is now responding "live" to CLICOLOR
+
+0.04 Tue Aug 03 2004
+	Release due to vital bug fix
+
+     Wed Jul 28
+        - Made all autosplit'ed subroutine names case-insensitive unique
+	appeared a case-insensitive filesystem could cause an infinite loop
+
+0.03 Mon Mar 29 2004
+        - Added support to tie a scalar reference
+
+     Tue Mar 23
+        - Fixed bug for platforms not supporting getpwuid()
+
+     Sat Mar 13
+        - Introduced $ENV{CLICOLOR} to switch colours on/off
+
+0.02 Wed Mar 10
+        - Added Makefile.PL - only Build.PL doesn't seem enough :(
+	- Tweaked the example script a bit
+	- Added \P{format} for proc info
+	- Added carl0s' acpi snippets
+	- Fixed customization
+
+0.01 Mon Mar 08
+        - Finished all initial features
+
+     Sun Mar 07 2004
+	- Initialised the module

Added: branches/upstream/libenv-ps1-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/MANIFEST?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/MANIFEST (added)
+++ branches/upstream/libenv-ps1-perl/current/MANIFEST Thu Apr 23 15:00:29 2009
@@ -1,0 +1,9 @@
+Build.PL
+Changes
+example.pl
+lib/Env/PS1.pm
+Makefile.PL
+MANIFEST			This list of files
+META.yml
+README
+t/00_usage.t

Added: branches/upstream/libenv-ps1-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/META.yml?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/META.yml (added)
+++ branches/upstream/libenv-ps1-perl/current/META.yml Thu Apr 23 15:00:29 2009
@@ -1,0 +1,18 @@
+--- #YAML:1.0
+name: Env-PS1
+version: 0.05
+author:
+  - Jaap Karssenberg <pardus at cpan.org>
+abstract: prompt string formatter
+license: perl
+requires:
+  AutoLoader: 0
+  POSIX: 0
+  Sys::Hostname: 0
+build_requires:
+  AutoSplit: 0
+provides:
+  Env::PS1:
+    file: lib/Env/PS1.pm
+    version: 0.05
+generated_by: Module::Build version 0.2604

Added: branches/upstream/libenv-ps1-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/Makefile.PL?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/Makefile.PL (added)
+++ branches/upstream/libenv-ps1-perl/current/Makefile.PL Thu Apr 23 15:00:29 2009
@@ -1,0 +1,31 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+    
+    unless (eval "use Module::Build::Compat 0.02; 1" ) {
+      print "This module requires Module::Build to install itself.\n";
+      
+      require ExtUtils::MakeMaker;
+      my $yn = ExtUtils::MakeMaker::prompt
+	('  Install Module::Build now from CPAN?', 'y');
+      
+      unless ($yn =~ /^y/i) {
+	die " *** Cannot install without Module::Build.  Exiting ...\n";
+      }
+      
+      require Cwd;
+      require File::Spec;
+      require CPAN;
+      
+      # Save this 'cause CPAN will chdir all over the place.
+      my $cwd = Cwd::cwd();
+      my $makefile = File::Spec->rel2abs($0);
+      
+      CPAN::Shell->install('Module::Build::Compat')
+	or die " *** Cannot install without Module::Build.  Exiting ...\n";
+      
+      chdir $cwd or die "Cannot chdir() back to $cwd: $!";
+    }
+    eval "use Module::Build::Compat 0.02; 1" or die $@;
+    use lib '_build/lib';
+    Module::Build::Compat->run_build_pl(args => \@ARGV);
+    require Module::Build;
+    Module::Build::Compat->write_makefile(build_class => 'Module::Build');

Added: branches/upstream/libenv-ps1-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/README?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/README (added)
+++ branches/upstream/libenv-ps1-perl/current/README Thu Apr 23 15:00:29 2009
@@ -1,0 +1,28 @@
+Env-PS1 0.05
+============
+
+ABOUT
+
+  This package supplies variables that are "tied" to environment variables 
+  like 'PS1' and 'PS2', if read it takes the contents of the variable as a
+  format string like the ones bash(1) uses to format the prompt.
+
+DEPENDENCIES
+
+  You'll need the following modules:
+
+    POSIX
+    Autoloader
+    Sys::Hostname
+
+  all of which are core modules
+
+INSTALL
+
+  Try something like:
+
+    $ perl Build.PL
+    $ ./Build test
+    $ ./Build install
+
+  See the Module::Build documentation for advanced build options.

Added: branches/upstream/libenv-ps1-perl/current/example.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/example.pl?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/example.pl (added)
+++ branches/upstream/libenv-ps1-perl/current/example.pl Thu Apr 23 15:00:29 2009
@@ -1,0 +1,65 @@
+#!/usr/bin/perl
+
+use lib './blib/lib/';
+
+die "Please run \"perl Build.PL && ./Build\" first\n" unless -d './blib/lib/';
+eval 'use Env::PS1 qw/$PS1/';
+
+my @demo = (
+	username => '\u',
+	'current dir' => '\w',
+	'basename current dir' => '\W',
+	hostname => '\H',
+	'short hostname' => '\h',
+	'basename $0' => '\s',
+	date => '\d',
+	'terminaldevice basename' => '\l',
+	'terminal device' => '\L',
+	time => '\t',
+	time => '\T',
+	time => '\@',
+	time => '\A',
+);
+
+my ($i, $l) = (0, 0);
+length($_) > $l and $l = length($_) for grep {++$i % 2} @demo;
+$l += 2;
+
+print "Most escapes are one character long, like these:\n";
+
+while (@demo) {
+	my ($k, $v) = ( shift(@demo), shift(@demo) );
+	$ENV{PS1} = $v;
+	print $k, ' 'x($l - length($k)), "$v  =  $PS1\n";
+}
+
+print "\nAlso their are two escapes with arguments:\n";
+
+$ENV{PS1} = '\\D{%a %b %e %H:%M:%S %Y}';
+print "strftime format    \\D{\%a \%b \%e \%H:\%M:\%S \%Y}\n\t= $PS1\n";
+
+$ENV{PS1} = q(\\C{bold,red}shiny isn't it ?\\C{reset});
+print "and ANSI colours   \\C{bold,red}shiny isn't it ?\\C{reset}\n\t= $PS1\n";
+
+$ENV{PS1} = '\\P{%u up %w users, loadavg: %L}';
+print "and some proc info \\P{\%u up \%w users, loadavg: \%L}\n\t= $PS1\n";
+
+print "\nAnd now for some real prompts:\n\n";
+
+print Env::PS1->sprintf($_), "\n\n" for
+	'\C{bold,blue}\u@\H \A \C{green}\W\$\C{reset} ',
+	'\[\033[01;31m\]\h \[\033[01;34m\]\W \$ \[\033[00m\]',
+	'\C{green}\D{%H:%M:%S} \W\$\C{reset} ',
+	'\C{bold,black}/--( \u@\H )-( \t )-( \w )- * *\n\\\\-- * \$\C{reset} ';
+	
+__END__
+
+=head1 NAME
+
+example.pl - some prompts demonstrated
+
+=head1 DESCRIPTION
+
+This script demonstrates the module by
+showing the supported escape sequences and some prompts.
+

Added: branches/upstream/libenv-ps1-perl/current/lib/Env/PS1.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/lib/Env/PS1.pm?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/lib/Env/PS1.pm (added)
+++ branches/upstream/libenv-ps1-perl/current/lib/Env/PS1.pm Thu Apr 23 15:00:29 2009
@@ -1,0 +1,549 @@
+package Env::PS1;
+
+use strict;
+use Carp;
+use AutoLoader 'AUTOLOAD';
+
+our $VERSION = 0.05;
+
+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 $ENV{CLICOLOR} eq $$self{clicolor}) {
+		@$self{qw/format clicolor/} = ($format, $ENV{CLICOLOR});
+		$$self{cache} = [ $self->cache($format) ];
+	}
+	my $string = join '', map { ref($_) ? $_->() : $_ } @{$$self{cache}};
+	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} } if $_[1] eq 'w';
+	return sub {
+		return '/' if $ENV{PWD} eq '/';
+		$ENV{PWD} =~ m#([^/]*)/?$#;
+		return $1;
+	};
+}
+
+## others defined below for Autoload
+
+1;
+
+__END__
+
+=head1 NAME
+
+Env::PS1 - prompt string formatter
+
+=head1 SYNOPSIS
+
+	# 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;
+
+=head1 DESCRIPTION
+
+This package supplies variables that are "tied" to environment variables like
+'PS1' and 'PS2', if read it takes the contents of the variable as a format string
+like the ones B<bash(1)> uses to format the prompt.
+
+It is intended to be used in combination with the various ReadLine packages.
+
+=head1 EXPORT
+
+You can request for arbitrary variables to be exported, they will be
+tied to the environment variables of the same name.
+
+=head1 TIE
+
+When you C<tie> a variable you can supply one argument which can either be
+the name of an environement variable or a SCALAR reference. This argument
+defaults to 'PS1'.
+
+=head1 METHODS
+
+=over 4
+
+=item C<sprintf($format)>
+
+Returns the formatted string.
+
+Using this method all the time is a lot B<less> efficient then
+using the tied variable, because the tied variable caches parts
+of the format that remain the same anyway.
+
+=back
+
+=head1 FORMAT
+
+The format is copied mostly from bash(1) because that's what it is supposed
+to be compatible with. We made some private extensions which obviously are
+not portable.
+
+Note that this is not the prompt format as specified by the posix specification,
+that would only know "!" for the history number and "!!" for a literal "!".
+
+Apart from the escape sequences you can also use environment variables in
+the format string; use C<$VAR> or C<${VAR}>.
+
+The following escape sequences are recognized:
+
+=over 4
+
+=item \a
+
+The bell character, identical to "\007"
+
+=item \d
+
+The date in "Weekday Month Date" format
+
+=item \D{format}
+
+The date in strftime(3) format, uses L<POSIX>
+
+=cut
+
+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 };
+}
+
+=item \e
+
+The escape character, identical to "\033"
+
+=item \n
+
+Newline
+
+=item \r
+
+Carriage return
+
+=item \s
+
+The basename of $0
+
+=cut
+
+sub S {
+	$0 =~ m#([^/]*)$#;
+	return $1 || '';
+}
+
+=pod
+
+=item \t
+
+The current time in 24-hour format, identical to "\D{%H:%M:%S}"
+
+=item \T
+
+The current time in 12-hour format, identical to "\D{%I:%M:%S}"
+
+=item \@
+
+The current time in 12-hour am/pm format, identical to "\D{%I:%M %p}"
+
+=item \A
+
+The current time in short 24-hour format, identical to "\D{%H:%M}"
+
+=item \u
+
+The username of the current user
+
+=item \w
+
+The current working directory
+
+=item \W
+
+The basename of the current working directory
+
+=item \$
+
+"#" for effective uid is 0 (root), else "$"
+
+=cut
+
+sub dollar { $user_info[2] ? '$' : '#' }
+
+=item \0dd
+
+The character corresponding to the octal number 0dd
+
+=item \\
+
+Literal backslash
+
+=item \H
+
+Hostname, uses L<Sys::Hostname>
+
+=item \h
+
+First part of the hostname
+
+=cut
+
+sub H {
+	use Sys::Hostname;
+	no warnings;
+	*H = sub {
+		my $h = &hostname;
+		$h =~ s#\..*$## if $_[1] eq 'h';
+		return $h;
+	};
+	return &H;
+}
+
+=item \l
+
+The basename of the (output) terminal device name,
+uses POSIX, but won't be really portable.
+
+=cut
+
+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;
+}
+
+=item \[ \]
+
+These are used to encapsulate a sequence of non-printing chars.
+Since we don't need that, they are removed.
+
+=back
+
+=head2 Extensions
+
+The following escapes are extensions not supported by bash, and are not portable:
+
+=over 4
+
+=item \L
+
+The (output) terminal device name, uses POSIX, but won't be really portable.
+
+=item \C{colour}
+
+Insert the ANSI sequence for named colour.
+Known colours are: black, red, green, yellow, blue, magenta, cyan and white;
+background colours prefixed with "on_".
+Also known are reset, bold, dark, underline, blink and reverse, although the
+effect depends on the terminla you use.
+
+Unless you want the whole commandline coloured you should 
+end your prompt with "\C{reset}".
+
+Of course you can still use the "raw" ansi escape codes for these colours.
+
+Note that "bold" is sometimes also known as "bright", so "\C{bold,black}"
+will on some terminals render dark grey.
+
+If the environment variable C<CLICOLOR> is defined but false colours are
+switched off automaticly.
+
+=cut
+
+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(@_);
+}
+
+=item \P{format}
+
+Proc information.
+
+I<All of these are unix specific>
+
+=over 4
+
+=item %a
+
+Acpi AC status '+' or '-' for connected or not, linux specific
+
+=item %b
+
+Acpi battery status in mWh, linux specific
+
+=item %L
+
+Load average
+
+=item %l
+
+First number of the load average
+
+=item %t
+
+Acpi temperature, linux specific
+
+=item %u
+
+Uptime
+
+=item %w
+
+Number of users logged in
+
+=back
+
+=cut
+
+# $ 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';
+}
+
+=back
+
+=head2 Not implemented escapes
+
+The following escapes are not implemented, because they are application specific.
+
+=over 4
+
+=item \j
+
+The number of jobs currently managed by the application.
+
+=item \v
+
+The version of the application.
+
+=item \V
+
+The release number of the application, version + patchelvel
+
+=item \!
+
+The history number of the next command.
+
+This escape gets replaced by literal '!' while a literal '!' gets replaces by '!!';
+this makes the string a posix compatible prompt, thus it will work if your readline
+module expects a posix prompt.
+
+=item \#
+
+The command number of the next command (like history number, but minus the
+lines read from the history file).
+
+=back
+
+=head2 Customizing
+
+If you want to overload escapes or want to supply values for the application
+specific escapes you can put them in C<%Env::PS1::map>, the key is the escape letter,
+the value either a string or a CODE ref. If you map a CODE ref it normally is called 
+every time the prompt string is read. When the escape is followed by an argument
+in the format string (like C<\D{argument}>) the CODE ref is called only once when the
+string is cached, but in that case it may in turn return a CODE ref.
+
+=head1 BUGS
+
+Please mail the author if you encounter any bugs.
+
+=head1 AUTHOR
+
+Jaap Karssenberg || Pardus [Larus] E<lt>pardus at cpan.orgE<gt>
+
+Copyright (c) 2004 Jaap G Karssenberg. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Env>,
+L<Term::ReadLine::Zoid>
+
+=cut
+

Added: branches/upstream/libenv-ps1-perl/current/t/00_usage.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libenv-ps1-perl/current/t/00_usage.t?rev=33767&op=file
==============================================================================
--- branches/upstream/libenv-ps1-perl/current/t/00_usage.t (added)
+++ branches/upstream/libenv-ps1-perl/current/t/00_usage.t Thu Apr 23 15:00:29 2009
@@ -1,0 +1,50 @@
+
+use strict;
+use vars qw/$PS1 $PS2/;
+use Test::More tests => 11;
+
+use_ok('Env::PS1', '$PS1');
+
+my @u_info = eval { getpwuid($>) }
+	? ( getpwuid($>) ) : ( $ENV{USER} || $ENV{LOGNAME} );
+
+$ENV{PS1} = '\Q \u \\\\ ';
+print "# PS1: $PS1\n";
+ok $PS1 eq 'Q '.$u_info[0].' \\ ', 'simple format';
+
+$ENV{PS1} = '\\a\\n\\r\\007';
+ok $PS1 eq "\a\n\r\a", 'perl format';
+
+ at ENV{qw/_TEST_ -TEST-/} = ('testing Env::PS1', '!');
+$ENV{PS1} = 'what ? $_TEST_ ${-TEST-}';
+print "# PS1: $PS1\n";
+ok $PS1 eq 'what ? testing Env::PS1 !!', 'format with env variable';
+
+$PS1 = '\$';
+ok $PS1 eq ($u_info[2] ? '$' : '#'), 'alias';
+
+my $result = $u_info[0].'@foobar';
+$PS1 = '\u at foobar';
+ok $PS1 eq $result, 'STORE';
+
+my ($format, $prompt) = ('\u at foobar', '');
+tie $prompt, 'Env::PS1', \$format;
+$format = '\u at foobar';
+ok $prompt eq $result, 'SCALAR ref';
+
+$format = '\C{red,on_green}dus\C{reset}';
+$ENV{CLICOLOR} = 0;
+ok $prompt eq 'dus', 'CLICOLOR';
+
+ok Env::PS1->sprintf('\u at foobar') eq $result, 'E:PS1:sprintf';
+
+no warnings;
+$Env::PS1::map{v} = 3;
+$PS1 = '\v';
+ok $PS1 eq 3, 'map';
+
+my $i = 0;
+$Env::PS1::map{i} = sub { ++$i };
+$PS1 = '\i';
+ok( ($PS1 == 1 and $PS1 == 2), 'map with subroutine' );
+




More information about the Pkg-perl-cvs-commits mailing list