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