web/util.pm

   1 ###################################################
   2 # utility functions to support pidl
   3 # Copyright (C) tridge@samba.org, 2001
   4 #
   5 #   This program is free software; you can redistribute it and/or modify
   6 #   it under the terms of the GNU General Public License as published by
   7 #   the Free Software Foundation; either version 2 of the License, or
   8 #   (at your option) any later version.
   9 #
  10 #   This program is distributed in the hope that it will be useful,
  11 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 #   GNU General Public License for more details.
  14 #
  15 #   You should have received a copy of the GNU General Public License
  16 #   along with this program; if not, write to the Free Software
  17 #   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19 package util;
  20
  21 use Data::Dumper;
  22
  23 #####################################################################
  24 # check if a string is in an array
  25 sub InArray($$)
  26 {
  27     my $s = shift;
  28     my $a = shift;
  29     for my $v (@{$a}) {
  30         if ($v eq $s) { return 1; }
  31     }
  32     return 0;
  33 }
  34
  35 #####################################################################
  36 # flatten an array of arrays into a single array
  37 sub FlattenArray($)
  38 {
  39     my $a = shift;
  40     my @b;
  41     for my $d (@{$a}) {
  42         for my $d1 (@{$d}) {
  43             push(@b, $d1);
  44         }
  45     }
  46     return \@b;
  47 }
  48
  49 #####################################################################
  50 # flatten an array of hashes into a single hash
  51 sub FlattenHash($)
  52 {
  53     my $a = shift;
  54     my %b;
  55     for my $d (@{$a}) {
  56         for my $k (keys %{$d}) {
  57             $b{$k} = $d->{$k};
  58         }
  59     }
  60     return \%b;
  61 }
  62
  63
  64 #####################################################################
  65 # return the modification time of a file
  66 sub FileModtime($)
  67 {
  68     my($filename) = shift;
  69     return (stat($filename))[9];
  70 }
  71
  72
  73 #####################################################################
  74 # read a file into a string
  75 sub FileLoad($)
  76 {
  77     my($filename) = shift;
  78     local(*INPUTFILE);
  79     open(INPUTFILE, $filename) || return "";
  80     my($saved_delim) = $/;
  81     undef $/;
  82     my($data) = <INPUTFILE>;
  83     close(INPUTFILE);
  84     $/ = $saved_delim;
  85     return $data;
  86 }
  87
  88 #####################################################################
  89 # write a string into a file
  90 sub FileSave($$)
  91 {
  92     my($filename) = shift;
  93     my($v) = shift;
  94     local(*FILE);
  95     open(FILE, ">$filename") || die "can't open $filename";
  96     print FILE $v;
  97     close(FILE);
  98 }
  99
 100 #####################################################################
 101 # return a filename with a changed extension
 102 sub ChangeExtension($$)
 103 {
 104     my($fname) = shift;
 105     my($ext) = shift;
 106     if ($fname =~ /^(.*)\.(.*?)$/) {
 107         return "$1.$ext";
 108     }
 109     return "$fname.$ext";
 110 }
 111
 112 #####################################################################
 113 # save a data structure into a file
 114 sub SaveStructure($$)
 115 {
 116     my($filename) = shift;
 117     my($v) = shift;
 118     FileSave($filename, Dumper($v));
 119 }
 120
 121 #####################################################################
 122 # load a data structure from a file (as saved with SaveStructure)
 123 sub LoadStructure($)
 124 {
 125     return eval FileLoad(shift);
 126 }
 127
 128
 129 ####################################################################
 130 # setup for gzipped output of a web page if possible.
 131 # based on cvsweb.pl method
 132 # as a side effect this function adds the final line ot the HTTP headers
 133 sub cgi_gzip()
 134 {
 135     my $paths = ['/usr/bin/gzip', '/bin/gzip'];
 136     my $GZIPBIN;
 137     my $Browser = $ENV{'HTTP_USER_AGENT'} || "";
 138
 139 #  newer browsers accept gzip content encoding
 140 # and state this in a header
 141 # (netscape did always but didn't state it)
 142 # It has been reported that these
 143 #  braindamaged MS-Internet Exploders claim that they
 144 # accept gzip .. but don't in fact and
 145 # display garbage then :-/
 146 # Turn off gzip if running under mod_perl. piping does
 147 # not work as expected inside the server. One can probably
 148 # achieve the same result using Apache::GZIPFilter.
 149     my $maycompress = (($ENV{'HTTP_ACCEPT_ENCODING'} =~ m|gzip|
 150                         || $Browser =~ m%^Mozilla/3%)
 151                        && ($Browser !~ m/MSIE/)
 152                        && !defined($ENV{'MOD_PERL'}));
 153
 154     if (!$maycompress) { print "\r\n"; return; }
 155
 156     for my $p (@{$paths}) {
 157         if (stat($p)) { $GZIPBIN = $p; }
 158     }
 159
 160     my $fh = do {local(*FH);};
 161
 162     if (stat($GZIPBIN) && open($fh, "|$GZIPBIN -1 -c")) {
 163         print "Content-encoding: x-gzip\r\n";
 164         print "Vary: Accept-Encoding\r\n";  #RFC 2068, 14.43
 165         print "\r\n"; # Close headers
 166         $| = 1; $| = 0; # Flush header output
 167         select ($fh);
 168     } else {
 169         print "\r\n";
 170     }
 171 }
 172
 173 ##########################################
 174 # escape a string for cgi
 175 sub cgi_escape($)
 176 {
 177     my $s = shift;
 178
 179     $s =~ s/&/&amp;/mg;
 180     $s =~ s/</&lt;/mg;
 181     $s =~ s/>/&gt;/mg;
 182     $s =~ s/"/&quot;/mg;
 183
 184     return $s;
 185 }
 186
 187 ##########################################
 188 # count the number of lines in a buffer
 189 sub count_lines($)
 190 {
 191     my $s = shift;
 192     my $count;
 193     $count = split(/$/m, $s);
 194     return $count;
 195 }
 196
 197 ################
 198 # display a time as days, hours, minutes
 199 sub dhm_time($)
 200 {
 201         my $sec = shift;
 202         my $days = int($sec / (60*60*24));
 203         my $hour = int($sec / (60*60)) % 24;
 204         my $min = int($sec / 60) % 60;
 205
 206         my $ret = "";
 207
 208         if ($sec < 0) {
 209                 return "-";
 210         }
 211
 212         if ($days != 0) {
 213                 return sprintf("%dd %dh %dm", $days, $hour, $min);
 214         }
 215         if ($hour != 0) {
 216                 return sprintf("%dh %dm", $hour, $min);
 217         }
 218         if ($min != 0) {
 219                 return sprintf("%dm", $min);
 220         }
 221         return sprintf("%ds", $sec);
 222 }
 223
 224 1;
 225