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 warnings;
  33 use strict;
  34 use IO::File;
  35 use Storable;
  36 use Data::Dumper;
  37 use Maasha::Common;
  38 use Digest::MD5;
  39
  40 use Exporter;
  41
  42 use vars qw( @ISA @EXPORT @EXPORT_OK );
  43
  44 @ISA = qw( Exporter ) ;
  45
  46
  47 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> FILES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  48
  49
  50 sub file_read_open
  51 {
  52     # Martin A. Hansen, January 2004.
  53
  54     # Read opens a file that may be gzipped and returns a filehandle.
  55
  56     my ( $path,   # full path to file
  57        ) = @_;
  58
  59     # Returns filehandle
  60
  61     my ( $fh );
  62
  63     if ( is_gzipped( $path ) ) {
  64         $fh = new IO::File "zcat $path|" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
  65     } else {
  66         $fh = new IO::File $path, "r" or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
  67     }
  68
  69     return $fh;
  70 }
  71
  72
  73 sub files_read_open
  74 {
  75     # Martin A. Hansen, May 2009.
  76
  77     # Cats a number of files and returns a filehandle.
  78
  79     my ( $files,   # full path to file
  80        ) = @_;
  81
  82     # returns filehandle
  83
  84     my ( $file, $fh, $type, %type_hash, $file_string );
  85
  86     foreach $file ( @{ $files } )
  87     {
  88         Maasha::Common::error( qq(No such file: $file) ) if not -f $file;
  89
  90         $type = `file $file`;
  91
  92         if ( $type =~ /gzip compressed/ ) {
  93             $type_hash{ 'gzip' } = 1;
  94         } else {
  95             $type_hash{ 'ascii' } = 1;
  96         }
  97     }
  98
  99     Maasha::Common::error( qq(Mixture of zipped and unzipped files) ) if scalar keys %type_hash > 1;
 100
 101     $file_string = join " ", @{ $files };
 102
 103     if ( $type =~ /gzip compressed/ ) {
 104         $fh = new IO::File "zcat $file_string|" or Maasha::Common::error( qq(Could not open pipe: $!) );
 105     } else {
 106         $fh = new IO::File "cat $file_string|" or Maasha::Common::error( qq(Could not open pipe: $!) );
 107     }
 108
 109     return $fh;
 110 }
 111
 112
 113 sub file_write_open
 114 {
 115     # Martin A. Hansen, January 2004.
 116
 117     # write opens a file and returns a filehandle
 118
 119     my ( $path,   # full path to file
 120          $gzip,   # flag if data is to be gzipped - OPRIONAL
 121        ) = @_;
 122
 123     # returns filehandle
 124
 125     my ( $fh );
 126
 127     if ( $gzip ) {
 128         $fh = new IO::File "|gzip -f>$path" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 129     } else {
 130         $fh = new IO::File $path, "w" or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 131     }
 132
 133     return $fh;
 134 }
 135
 136
 137 sub file_append_open
 138 {
 139     # Martin A. Hansen, February 2006.
 140
 141     # append opens file and returns a filehandle
 142
 143     my ( $path,     # path to file
 144        ) = @_;
 145
 146     # returns filehandle
 147
 148     my ( $fh );
 149
 150     $fh = new IO::File $path, "a" or Maasha::Common::error( qq(Could not append-open file "$path": $!) );
 151
 152     return $fh;
 153 }
 154
 155
 156 sub stdin_read
 157 {
 158     # Martin A. Hansen, July 2007.
 159
 160     # Returns a filehandle to STDIN
 161
 162     my ( $fh );
 163
 164     $fh = new IO::File "<&STDIN" or Maasha::Common::error( qq(Could not read from STDIN: $!) );
 165
 166     return $fh;
 167 }
 168
 169
 170 sub stdout_write
 171 {
 172     # Martin A. Hansen, July 2007.
 173
 174     # Returns a filehandle to STDOUT
 175
 176     my ( $fh );
 177
 178     $fh = new IO::File ">&STDOUT" or Maasha::Common::error( qq(Could not write to STDOUT: $!) );
 179
 180     return $fh;
 181 }
 182
 183
 184 sub file_read
 185 {
 186     # Martin A. Hansen, December 2004.
 187
 188     # given a file, a seek beg position and
 189     # length, returns the corresponding string.
 190
 191     my ( $fh,     # file handle to file
 192          $beg,    # read start in file
 193          $len,    # read length of block
 194         ) = @_;
 195
 196     # returns string
 197
 198     my ( $string );
 199
 200     Maasha::Common::error( qq(Negative length: $len) ) if $len < 0;
 201
 202     sysseek $fh, $beg, 0;
 203     sysread $fh, $string, $len;
 204
 205     return $string;
 206 }
 207
 208
 209 sub file_store
 210 {
 211     # Martin A. Hansen, December 2004.
 212
 213     # writes a data structure to file.
 214
 215     my ( $path,      # full path to file
 216          $data,      # data structure
 217        ) = @_;
 218
 219     Storable::store( $data, $path ) or Maasha::Common::error( qq(Could not write-open file "$path": $!) );
 220 }
 221
 222
 223 sub file_retrieve
 224 {
 225     # Martin A. Hansen, December 2004.
 226
 227     # retrieves hash data structure
 228     # (this routines needs to test if its a hash, array or else)
 229
 230     my ( $path,   # full path to data file
 231        ) = @_;
 232
 233     my ( $data );
 234
 235     $data = Storable::retrieve( $path ) or Maasha::Common::error( qq(Could not read-open file "$path": $!) );
 236
 237     return wantarray ? %{ $data } : $data;
 238 }
 239
 240
 241 sub file_copy
 242 {
 243     # Martin A. Hansen, November 2008.
 244
 245     # Copy the content of a file from source path to
 246     # destination path.
 247
 248     my ( $src,   # source path
 249          $dst,   # destination path
 250        ) = @_;
 251
 252     # Returns nothing.
 253
 254     my ( $fh_in, $fh_out, $line );
 255
 256     Maasha::Common::error( qq(copy failed: destination equals source "$src") ) if $src eq $dst;
 257
 258     $fh_in  = file_read_open( $src );
 259     $fh_out = file_write_open( $dst );
 260
 261     while ( $line = <$fh_in> ) {
 262         print $fh_out $line;
 263     }
 264
 265     close $fh_in;
 266     close $fh_out;
 267 }
 268
 269
 270 sub is_gzipped
 271 {
 272     # Martin A. Hansen, November 2008.
 273
 274     # Checks if a given file is gzipped.
 275     # Currrently uses a call to the systems
 276     # file tool. Returns 1 if gzipped otherwise
 277     # returns 0.
 278
 279     my ( $path,   # path to file
 280        ) = @_;
 281
 282     # Returns boolean.
 283
 284     my ( $type );
 285
 286     $type = `file $path`;
 287
 288     if ( $type =~ /gzip compressed/ ) {
 289         return 1;
 290     } else {
 291         return 0;
 292     }
 293 }
 294
 295
 296 sub file_size
 297 {
 298     # Martin A. Hansen, March 2007
 299
 300     # returns the file size for a given file
 301
 302     my ( $path,   # full path to file
 303        ) = @_;
 304
 305     # returns integer
 306
 307     my $file_size = -s $path;
 308
 309     return $file_size;
 310 }
 311
 312
 313 sub file_md5
 314 {
 315     # Martin A. Hansen, December 2009.
 316
 317     # Get an MD5 sum for a given file.
 318
 319     my ( $file,   # file path
 320        ) = @_;
 321
 322     # Returns a string.
 323
 324     my ( $fh, $md5 );
 325
 326     $fh = file_read_open( $file );
 327
 328     $md5 = Digest::MD5->new;
 329
 330     $md5->addfile( $fh );
 331
 332     close $fh;
 333
 334     return $md5->hexdigest;
 335 }
 336
 337
 338 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DIRECTORIES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 339
 340
 341 sub dir_create
 342 {
 343     # Martin A. Hansen, July 2007.
 344
 345     # Creates a directory.
 346
 347     my ( $path,   # full path to dir
 348        ) = @_;
 349
 350     # Returns created path.
 351
 352     if ( -d $path ) {
 353         Maasha::Common::error( qq(Directory already exists "$path") );
 354     } else {
 355         mkdir $path or Maasha::Common::error( qq(Could not create directory "$path": $!) );
 356     }
 357
 358     return $path;
 359 }
 360
 361
 362 sub dir_create_if_not_exists
 363 {
 364     # Martin A. Hansen, May 2008.
 365
 366     # Creates a directory if it does not already exists.
 367
 368     my ( $path,   # full path to dir
 369        ) = @_;
 370
 371     # Returns path.
 372
 373     if ( not -d $path ) {
 374         mkdir $path or Maasha::Common::error( qq(Could not create directory "$path": $!) );
 375     }
 376
 377     return $path;
 378 }
 379
 380
 381 sub dir_remove
 382 {
 383     # Martin A. Hansen, April 2008.
 384
 385     # Removes a directory recursively.
 386
 387     my ( $path,   # directory
 388        ) = @_;
 389
 390     Maasha::Common::run( "rm", "-rf $path" ) if -d $path;
 391 }
 392
 393
 394 sub ls_dirs
 395 {
 396     # Martin A. Hansen, June 2007.
 397
 398     # returns all dirs in a given directory.
 399
 400     my ( $path,   # full path to directory
 401        ) = @_;
 402
 403     # returns a list of filenames.
 404
 405     my ( $dh, @dirs );
 406
 407     $dh = open_dir( $path );
 408
 409     @dirs =  read_dir( $dh );
 410     @dirs = grep { -d "$path/$_" } @dirs;
 411
 412     map { $_ = "$path/$_" } @dirs;
 413
 414     close $dh;
 415
 416     @dirs = sort @dirs;
 417
 418     return wantarray ? @dirs : \@dirs;
 419 }
 420
 421
 422 sub ls_dirs_base
 423 {
 424     # Martin A. Hansen, November 2009.
 425
 426     # Returns all directory basenames execpt . and ..
 427     # from a given directory.
 428
 429     my ( $path,
 430        ) = @_;
 431
 432     # Returns a list.
 433
 434     my ( @dirs, $dir, @list );
 435
 436     @dirs = Maasha::Filesys::ls_dirs( $path );
 437
 438     foreach $dir ( @dirs )
 439     {
 440         next if $dir =~ /\/\.\.?$/;
 441
 442         push @list, ( split "/", $dir )[ -1 ];
 443     }
 444
 445     return wantarray ? @list : \@list;
 446 }
 447
 448
 449 sub ls_files
 450 {
 451     # Martin A. Hansen, June 2007.
 452
 453     # returns all files in a given directory.
 454
 455     my ( $path,   # full path to directory
 456        ) = @_;
 457
 458     # returns a list of filenames.
 459
 460     my ( $dh, @files );
 461
 462     $dh = open_dir( $path );
 463
 464     @files =  read_dir( $dh );
 465     @files = grep { -f "$path/$_" } @files;
 466
 467     map { $_ = "$path/$_" } @files;
 468
 469     close $dh;
 470
 471     return wantarray ? @files : \@files;
 472 }
 473
 474
 475 sub open_dir
 476 {
 477     # Martin A. Hansen, June 2007.
 478
 479     # open a directory and returns a directory handle
 480
 481     use IO::Dir;
 482
 483     my ( $path,   # full path to directory
 484        ) = @_;
 485
 486     # returns object
 487
 488     my $dh;
 489
 490     $dh = IO::Dir->new( $path ) or Maasha::Common::error( qq(Could not open dir "$path": $!) );
 491
 492     return $dh;
 493 }
 494
 495
 496 sub read_dir
 497 {
 498     # Martin A. Hansen, June 2007.
 499
 500     # read all files and directories from a directory.
 501
 502     my ( $dh,   # directory handle object
 503        ) = @_;
 504
 505     # returns list
 506
 507     my ( $elem, @elems );
 508
 509     while ( defined( $elem = $dh->read ) ) {
 510         push @elems, $elem;
 511     }
 512
 513     return wantarray ? @elems : \@elems;
 514 }
 515
 516
 517 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 518
 519
 520 1;
 521
 522
 523 __END__