code_perl/Maasha/Filesys.pm

   1 package Maasha::Filesys;
   2
   3
   4 # Copyright (C) 2006-2008 Martin A. Hansen.
   5
   6 # This program is free software; you can redistribute it and/or
   7 # modify it under the terms of the GNU General Public License
   8 # as published by the Free Software Foundation; either version 2
   9 # of the License, or (at your option) any later version.
  10
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program; if not, write to the Free Software
  18 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  19
  20 # http://www.gnu.org/copyleft/gpl.html
  21
  22
  23 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  24
  25
  26 # This module contains routines for manipulation of files and directories.
  27
  28
  29 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  30
  31
  32 use strict;
  33 use IO::File;
  34 use Maasha::Common;
  35
  36 use Exporter;
  37
  38 use vars qw( @ISA @EXPORT @EXPORT_OK );
  39
  40 @ISA = qw( Exporter ) ;
  41
  42
  43 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> FILES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  44
  45
  46 sub file_read_open
  47 {
  48     # Martin A. Hansen, January 2004.
  49
  50     # Read opens a file that may be gzipped and returns a filehandle.
  51
  52     my ( $path,   # full path to file
  53        ) = @_;
  54
  55     # Returns filehandle
  56
  57     my ( $fh );
  58
  59     if ( is_gzipped( $path ) ) {
  60         $fh = new IO::File "zcat $path|" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
  61     } else {
  62         $fh = new IO::File $path, "r" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
  63     }
  64
  65     return $fh;
  66 }
  67
  68
  69 sub files_read_open
  70 {
  71     # Martin A. Hansen, May 2009.
  72
  73     # Cats a number of files and returns a filehandle.
  74
  75     my ( $files,   # full path to file
  76        ) = @_;
  77
  78     # returns filehandle
  79
  80     my ( $file, $fh, $type, %type_hash, $file_string );
  81
  82     foreach $file ( @{ $files } )
  83     {
  84         Maasha::Common::error( qq(No such file: $file) ) if not -f $file;
  85
  86         $type = `file $file`;
  87
  88         if ( $type =~ /gzip compressed/ ) {
  89             $type_hash{ 'gzip' } = 1;
  90         } else {
  91             $type_hash{ 'ascii' } = 1;
  92         }
  93     }
  94
  95     Maasha::Common::error( qq(Mixture of zipped and unzipped files) ) if scalar keys %type_hash > 1;
  96
  97     $file_string = join " ", @{ $files };
  98
  99     if ( $type =~ /gzip compressed/ ) {
 100         $fh = new IO::File "zcat $file_string|" or Maasha::Common::error( qq(Could not open pipe: $!) );
 101     } else {
 102         $fh = new IO::File "cat $file_string|" or Maasha::Common::error( qq(Could not open pipe: $!) );
 103     }
 104
 105     return $fh;
 106 }
 107
 108
 109 sub file_write_open
 110 {
 111     # Martin A. Hansen, January 2004.
 112
 113     # write opens a file and returns a filehandle
 114
 115     my ( $path,   # full path to file
 116          $gzip,   # flag if data is to be gzipped - OPRIONAL
 117        ) = @_;
 118
 119     # returns filehandle
 120
 121     my ( $fh );
 122
 123     if ( $gzip ) {
 124         $fh = new IO::File "|gzip -f>$path" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 125     } else {
 126         $fh = new IO::File $path, "w" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 127     }
 128
 129     return $fh;
 130 }
 131
 132
 133 sub file_append_open
 134 {
 135     # Martin A. Hansen, February 2006.
 136
 137     # append opens file and returns a filehandle
 138
 139     my ( $path,     # path to file
 140        ) = @_;
 141
 142     # returns filehandle
 143
 144     my ( $fh );
 145
 146     $fh = new IO::File $path, "a" or Maasha::Common::error( qq(Could not append-open file "$path": $!) );
 147
 148     return $fh;
 149 }
 150
 151
 152 sub stdin_read
 153 {
 154     # Martin A. Hansen, July 2007.
 155
 156     # Returns a filehandle to STDIN
 157
 158     my ( $fh );
 159
 160     $fh = new IO::File "<&STDIN" or Maasha::Common::error( qq(Could not read from STDIN: $!) );
 161
 162     return $fh;
 163 }
 164
 165
 166 sub stdout_write
 167 {
 168     # Martin A. Hansen, July 2007.
 169
 170     # Returns a filehandle to STDOUT
 171
 172     my ( $fh );
 173
 174     $fh = new IO::File ">&STDOUT" or Maasha::Common::error( qq(Could not write to STDOUT: $!) );
 175
 176     return $fh;
 177 }
 178
 179
 180 sub file_read
 181 {
 182     # Martin A. Hansen, December 2004.
 183
 184     # given a file, a seek beg position and
 185     # length, returns the corresponding string.
 186
 187     my ( $fh,     # file handle to file
 188          $beg,    # read start in file
 189          $len,    # read length of block
 190         ) = @_;
 191
 192     # returns string
 193
 194     my ( $string );
 195
 196     Maasha::Common::error( qq(Negative length: $len) ) if $len < 0;
 197
 198     sysseek $fh, $beg, 0;
 199     sysread $fh, $string, $len;
 200
 201     return $string;
 202 }
 203
 204
 205 sub file_copy
 206 {
 207     # Martin A. Hansen, November 2008.
 208
 209     # Copy the content of a file from source path to
 210     # destination path.
 211
 212     my ( $src,   # source path
 213          $dst,   # destination path
 214        ) = @_;
 215
 216     # Returns nothing.
 217
 218     my ( $fh_in, $fh_out, $line );
 219
 220     Maasha::Common::error( qq(copy failed: destination equals source "$src") ) if $src eq $dst;
 221
 222     $fh_in  = file_read_open( $src );
 223     $fh_out = file_write_open( $dst );
 224
 225     while ( $line = <$fh_in> ) {
 226         print $fh_out $line;
 227     }
 228
 229     close $fh_in;
 230     close $fh_out;
 231 }
 232
 233
 234 sub is_gzipped
 235 {
 236     # Martin A. Hansen, November 2008.
 237
 238     # Checks if a given file is gzipped.
 239     # Currrently uses a call to the systems
 240     # file tool. Returns 1 if gzipped otherwise
 241     # returns 0.
 242
 243     my ( $path,   # path to file
 244        ) = @_;
 245
 246     # Returns boolean.
 247
 248     my ( $type );
 249
 250     $type = `file $path`;
 251
 252     if ( $type =~ /gzip compressed/ ) {
 253         return 1;
 254     } else {
 255         return 0;
 256     }
 257 }
 258
 259
 260 sub file_size
 261 {
 262     # Martin A. Hansen, March 2007
 263
 264     # returns the file size for a given file
 265
 266     my ( $path,   # full path to file
 267        ) = @_;
 268
 269     # returns integer
 270
 271     my $file_size = ( stat ( $path ) )[ 7 ];
 272
 273     return $file_size;
 274 }
 275
 276
 277 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DIRECTORIES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 278
 279
 280 sub dir_create
 281 {
 282     # Martin A. Hansen, July 2007.
 283
 284     # Creates a directory.
 285
 286     my ( $path,   # full path to dir
 287        ) = @_;
 288
 289     # Returns nothing.
 290
 291     if ( -d $path ) {
 292         Maasha::Common::error( qq(Directory already exists "$path": $!) );
 293     } else {
 294         mkdir $path or Maasha::Common::error( qq(Could not create directory "$path": $!) );
 295     }
 296 }
 297
 298
 299 sub dir_create_if_not_exists
 300 {
 301     # Martin A. Hansen, May 2008.
 302
 303     # Creates a directory if it does not already exists.
 304
 305     my ( $path,   # full path to dir
 306        ) = @_;
 307
 308     # Returns nothing.
 309
 310     if ( not -d $path ) {
 311         mkdir $path or Maasha::Common::error( qq(Could not create directory "$path": $!) );
 312     }
 313 }
 314
 315
 316 sub dir_remove
 317 {
 318     # Martin A. Hansen, April 2008.
 319
 320     # Removes a directory recursively.
 321
 322     my ( $path,   # directory
 323        ) = @_;
 324
 325     Maasha::Common::run( "rm", "-rf $path" ) if -d $path;
 326 }
 327
 328
 329 sub ls_dirs
 330 {
 331     # Martin A. Hansen, June 2007.
 332
 333     # returns all dirs in a given directory.
 334
 335     my ( $path,   # full path to directory
 336        ) = @_;
 337
 338     # returns a list of filenames.
 339
 340     my ( $dh, @dirs );
 341
 342     $dh = open_dir( $path );
 343
 344     @dirs =  read_dir( $dh );
 345     @dirs = grep { -d "$path/$_" } @dirs;
 346
 347     map { $_ = "$path/$_" } @dirs;
 348
 349     close $dh;
 350
 351     return wantarray ? @dirs : \@dirs;
 352 }
 353
 354
 355 sub ls_files
 356 {
 357     # Martin A. Hansen, June 2007.
 358
 359     # returns all files in a given directory.
 360
 361     my ( $path,   # full path to directory
 362        ) = @_;
 363
 364     # returns a list of filenames.
 365
 366     my ( $dh, @files );
 367
 368     $dh = open_dir( $path );
 369
 370     @files =  read_dir( $dh );
 371     @files = grep { -f "$path/$_" } @files;
 372
 373     map { $_ = "$path/$_" } @files;
 374
 375     close $dh;
 376
 377     return wantarray ? @files : \@files;
 378 }
 379
 380
 381 sub open_dir
 382 {
 383     # Martin A. Hansen, June 2007.
 384
 385     # open a directory and returns a directory handle
 386
 387     use IO::Dir;
 388
 389     my ( $path,   # full path to directory
 390        ) = @_;
 391
 392     # returns object
 393
 394     my $dh;
 395
 396     $dh = IO::Dir->new( $path ) or Maasha::Common::error( qq(Could not open dir "$path": $!) );
 397
 398     return $dh;
 399 }
 400
 401
 402 sub read_dir
 403 {
 404     # Martin A. Hansen, June 2007.
 405
 406     # read all files and directories from a directory.
 407
 408     my ( $dh,   # directory handle object
 409        ) = @_;
 410
 411     # returns list
 412
 413     my ( $elem, @elems );
 414
 415     while ( defined( $elem = $dh->read ) ) {
 416         push @elems, $elem;
 417     }
 418
 419     return wantarray ? @elems : \@elems;
 420 }
 421
 422
 423 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 424
 425
 426 1;
 427
 428
 429 __END__