lib/ui_subs.pm

   1 # Like the Debug class the user_interface (ui) class is a little bit
   2 # special in that it should never be instanciated. An instance (named
   3 # ui) is kept globally which can be accessed by the members of the
   4 # ui class if they are called statically. Calling a member staticaly
   5 # means that you adress them using the perl module name, for example:
   6 #
   7 # ui -> print( 'print this on the screen' );
   8 #
   9 # Notice that there is no $ in front of 'ui'. Here print is called
  10 # "statically". In other words, it means "call a member without an
  11 # instance".
  12 #
  13
  14 # {{{ include
  15 start include statements
  16 use Carp;
  17 use Carp qw(cluck);
  18 use Text::Wrap;
  19
  20 # These variables are used for mapping level names to numbers.
  21
  22 my $the_instance = ui::new();
  23
  24 end include statements
  25 # }}}
  26
  27 # {{{ new
  28 start new
  29 end new
  30 # }}}
  31
  32 # {{{ category
  33
  34 start category
  35     {
  36       # Usage:
  37       #
  38       # ui -> category( 'bootstrap' )
  39       #
  40       # If you give a value to category as a single argument, you will
  41       # set the global category of user interface messages.
  42       #
  43       # my $current_category = ui -> category
  44       #
  45       # If you don't give any argument the current category is returned.
  46
  47       if( defined($parm) ){
  48         $the_instance -> {'category'} = $parm;
  49       } else {
  50         return $the_instance -> {'category'};
  51       }
  52       return;
  53     }
  54 end category
  55
  56 # }}}
  57
  58 # {{{ package
  59
  60 start package
  61     {
  62       # Usage:
  63       #
  64       # ui -> package( 'output' )
  65       #
  66       # If you give a value to package as a single argument, you will
  67       # set the global package of ui messages.
  68       #
  69       # my $current_package = ui -> package
  70       #
  71       # If you don't give any argument the current package is returned.
  72
  73       if( defined($parm) ){
  74         $the_instance -> {'package'} = $parm;
  75       } else {
  76         return $the_instance -> {'package'};
  77       }
  78       return;
  79     }
  80 end package
  81
  82 # }}}
  83
  84 # {{{ subroutine
  85
  86 start subroutine
  87     {
  88       # Usage:
  89       #
  90       # ui -> subroutine( 'output' )
  91       #
  92       # If you give a value to subroutine as a single argument, you will
  93       # set the global subroutine of ui messages.
  94       #
  95       # my $current_subroutine = ui -> subroutine
  96       #
  97       # If you don't give any argument the current subroutine is returned.
  98
  99       if( defined($parm) ){
 100         $the_instance -> {'subroutine'} = $parm;
 101       } else {
 102         return $the_instance -> {'subroutine'};
 103       }
 104       return;
 105     }
 106 end subroutine
 107
 108 # }}}
 109
 110 # {{{ print
 111 start print
 112     {
 113
 114       # Usage:
 115       #
 116       # ui -> print( category => 'bootstrap',
 117       #              message  => 'This is a message' );
 118       #
 119       # ui::print will print out messages corresponding to the category specified as
 120       # argument. ui::print will look at the category given and the
 121       # global category to see whether anything should be printed.
 122       #
 123       #
 124       # NOTICE the lack of "\n" at the end of the message, ui::print
 125       # will append one "\n". In case there ever is a GUI for PsN
 126       # ui::print could be used to create a message in the GUI. And
 127       # in that case, an extra "\n" might be annoying.
 128       return if( $the_instance -> {'silent'} );
 129       if( $the_instance -> {'category'} eq $category or $category eq 'all' ){
 130         my ( $package_junk, $filename, $line, $subroutine, $junk ) = caller(1);
 131         my @names = split('::', $subroutine );
 132         $subroutine = $names[$#names];
 133         my $package = join( '::', @names[0..$#names-1] );
 134
 135         if ( ( not defined $the_instance -> {'package'} or
 136                $the_instance -> {'package'} eq $package ) and
 137              ( not defined $the_instance -> {'subroutine'} or
 138                $the_instance -> {'subroutine'} eq $subroutine ) ) {
 139
 140           my $prefix;
 141           my $text;
 142
 143           my $nl = $newline ? "\n" : '';
 144
 145           if ( $wrap ) {
 146             $text = wrap('', '', $message . $nl );
 147           } else {
 148             $text = $message . $nl;
 149           }
 150
 151           print STDERR ( $text );
 152         }
 153       }
 154     }
 155 end print
 156 # }}}
 157
 158 # {{{ status_bar
 159 start status_bar
 160       {
 161         if ( $goal != 0 ) {
 162           my $part = int(($sofar/$goal)*$width);
 163           $bar = "\r".'|'.'.' x $part . ' ' x ($width-$part) . '|';
 164         }
 165       }
 166 end status_bar
 167 # }}}
 168
 169 # {{{ silent
 170 start silent
 171 {
 172   if( defined($parm) ){
 173     $the_instance -> {'silent'} = $parm;
 174   } else {
 175     return $the_instance -> {'silent'};
 176   }
 177   return;
 178 }
 179 end silent
 180 # }}}