C4/Format.pm

   1 package C4::Format; #asummes C4/Format
   2
   3 use strict;
   4 require Exporter;
   5
   6
   7 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
   8
   9 # set the version for version checking
  10 $VERSION = 0.01;
  11
  12 @ISA = qw(Exporter);
  13 @EXPORT = qw(&fmtstr &fmtdec);
  14 %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  15
  16 # your exported package globals go here,
  17 # as well as any optionally exported functions
  18
  19 @EXPORT_OK   = qw($Var1 %Hashit);
  20
  21
  22 # non-exported package globals go here
  23 use vars qw(@more $stuff);
  24
  25 # initalize package globals, first exported ones
  26
  27 my $Var1   = '';
  28 my %Hashit = ();
  29
  30 # then the others (which are still accessible as $Some::Module::stuff)
  31 my $stuff  = '';
  32 my @more   = ();
  33
  34 # all file-scoped lexicals must be created before
  35 # the functions below that use them.
  36
  37 # file-private lexicals go here
  38 my $priv_var    = '';
  39 my %secret_hash = ();
  40
  41 # here's a file-private function as a closure,
  42 # callable as &$priv_func;  it cannot be prototyped.
  43 my $priv_func = sub {
  44   # stuff goes here.
  45 };
  46
  47 # make all your functions, whether exported or not;
  48
  49 sub fmtstr {
  50   # format (space pad) a string
  51   # $fmt is Ln.. or Rn.. where n is the length
  52   my ($env,$strg,$fmt)=@_;
  53   my $align = substr($fmt,0,1);
  54   my $lenst = substr($fmt,1,length($fmt)-1);
  55   if ($align eq"R" ) {
  56      $strg = substr((" "x$lenst).$strg,0-$lenst,$lenst);
  57   } elsif  ($align eq "C" ) {
  58      $strg =
  59        substr((" "x(($lenst/2)-(length($strg)/2))).$strg.(" "x$lenst),0,$lenst);
  60   } else {
  61      $strg = substr($strg.(" "x$lenst),0,$lenst);
  62   }
  63   return ($strg);
  64 }
  65
  66 sub fmtdec {
  67   # format a decimal
  68   # $fmt is [$][,]n[m]
  69   my ($env,$numb,$fmt)=@_;
  70   my $curr = substr($fmt,0,1);
  71   if ($curr eq "\$") {
  72     $fmt = substr($fmt,1,length($fmt)-1);
  73   };
  74   my $comma = substr($fmt,0,1);
  75   if ($comma eq ",") {
  76     $fmt = substr($fmt,1,length($fmt)-1);
  77   };
  78   my $right;
  79   my $left = substr($fmt,0,1);
  80   if (length($fmt) == 1) {
  81     $right = 0;
  82   } else {
  83     $right = substr($fmt,1,1);
  84   }
  85   my $fnumb = "";
  86   my $tempint = "";
  87   my $tempdec = "";
  88   if (index($numb,".") == 0 ){
  89      $tempint = 0;
  90      $tempdec = substr($numb,1,length($numb)-1);
  91   } else {
  92      if (index($numb,".") > 0) {
  93        my $decpl = index($numb,".");
  94        $tempint = substr($numb,0,$decpl);
  95        $tempdec = substr($numb,$decpl+1,length($numb)-1-$decpl);
  96      } else {
  97        $tempint = $numb;
  98        $tempdec = 0;
  99      }
 100      if ($comma eq ",") {
 101         while (length($tempdec) > 3) {
 102            $fnumb = ",".substr($tempint,-3,3).$fnumb;
 103            substr($tempint,-3,3) = "";
 104         }
 105         $fnumb = substr($tempint,-3,3).$fnumb;
 106      } else {
 107         $fnumb = $tempint;
 108      }
 109   }
 110   if ($curr eq "\$") {
 111      $fnumb = fmtstr($env,$curr.$fnumb,"R".$left+1);
 112   } else {
 113      if ($left==0) {
 114         $fnumb = "";
 115      } else {
 116         $fnumb = fmtstr($env,$fnumb,"R".$left);
 117      }
 118   }
 119   if ($right > 0) {
 120      $tempdec = $tempdec.("0"x$right);
 121      $tempdec = substr($tempdec,0,$right);
 122      $fnumb = $fnumb.".".$tempdec;
 123   }
 124   return ($fnumb);
 125 }
 126
 127 END { }       # module clean-up code here (global destructor)