lib/file_subs.pm

   1 start include statements
   2 use Config;
   3 use Cwd;
   4 end include statements
   5
   6 # {{{ new
   7 start new
   8     {
   9       my $path = $this -> {'path'};
  10       my $name = $this -> {'name'};
  11
  12       $path = $this -> merge_path_and_name( path => $path,
  13                                             name => $name );
  14
  15       $path =~ s!([^\/]*)$!!;
  16       $name = $1;
  17
  18       $this -> {'path'} = $path;
  19       $this -> {'name'} = $name;
  20     }
  21 end new
  22 # }}} new
  23
  24 # {{{ is_absolute
  25 start is_absolute
  26     {
  27       if ( $Config{osname} eq 'MSWin32' ) {
  28         if( $name =~ /^\w\:[\\\/]/ ){
  29           $is_absolute = 1;
  30         } else {
  31           $is_absolute = 0;
  32         }
  33       } else { # Assume OS == unix
  34         if( $name =~ /^\// ){
  35           $is_absolute = 1;
  36         } else {
  37           $is_absolute = 0;
  38         }
  39       }
  40     }
  41 end is_absolute
  42 # }}} is_absolute
  43
  44 # {{{ clean_path
  45 start clean_path
  46     {
  47       $path =~ s!\\!\/!g; # Flip slashes
  48
  49       while( $path =~ /[^\/\.]+\/\.\.\// ){
  50         $path =~ s![^\/\.]+\/\.\.\/!!g; # Remove relative dots
  51       }
  52
  53       while( $path =~ m!^\/\.\.\/! ){
  54         $path =~ s!^\/\.\.\/!\/!;
  55       }
  56
  57       while( $path =~ m![^\.]\.\/! ){
  58         $path =~ s!\.\/!\/!; # remove singel dots
  59       }
  60
  61       while( $path =~ m!\/\/! ){
  62         $path =~ s!\/\/!\/!; # remove double slashes
  63       }
  64
  65       $clean_path = $path;
  66     }
  67 end clean_path
  68 # }}}
  69
  70 # {{{ merge_path_and_name
  71 start merge_path_and_name
  72     {
  73       # path finding strategy:
  74
  75       # 1. If path is not given it is assumed to be the current working
  76       # directory. If it is not absolute, it is assumed to be relative to
  77       # the current working directory.
  78
  79       # 2. If filename is absolute and a path is given, compare them and
  80       # warn if they differ.
  81
  82       # 3. If the filename is relative, merge it with the path.
  83
  84       # Step 1. Make the pathname absolute.
  85       if( defined $path ){
  86         if ( $Config{osname} eq 'MSWin32' ) {
  87           unless ( $path =~ /^\w\:[\\\/]/ ) {
  88             $path = getcwd() . '/' . $path;
  89           }
  90         } else { # Assume os == unix
  91           unless( $path =~ /^\// ) {
  92             $path = getcwd() . '/' . $path;
  93           }
  94         }
  95       } else {
  96         $path = getcwd();
  97         debug -> warn( level => debug::information, message => "file : No path given, assuming $path" );
  98       }
  99
 100       $path = $self -> clean_path( path => $path );
 101
 102       $name = $self -> clean_path( path => $name );
 103
 104       unless( $path =~ /\/$/ ) { # append trailing slash
 105         $path .= '/';
 106       }
 107
 108       my $tmp = $name;
 109       $tmp =~ s![^\/]*$!!;
 110
 111       # Step 1
 112       if( $self -> is_absolute( name => $name ) ){
 113         unless( $path eq $tmp ){
 114           debug -> warn( level => debug::warning, message => "file : Path($path) differs from filename($name), using: $tmp" );
 115         }
 116         $path = $name;
 117       } else {
 118         $path .= $name;
 119       }
 120
 121       # Step 3
 122       $merged_path = $self -> clean_path( path => $path );
 123     }
 124 end merge_path_and_name
 125 # }}}
 126
 127 # {{{ name
 128 start name
 129     {
 130       if( defined $parm ){
 131         my $path = $self -> merge_path_and_name( path => $self -> {'path'}, name => $parm );
 132
 133         $path =~ s!([^\/]*)$!!;
 134         my $name = $1;
 135
 136         $self -> {'path'} = $path;
 137         $parm = $name;
 138       }
 139     }
 140 end name
 141 # }}} name
 142
 143 # {{{ path
 144 start path
 145     {
 146       if( defined $parm ){
 147         my $path = $self -> merge_path_and_name( path => $parm, name => $self -> {'name'} );
 148
 149         $path =~ s!([^\/]*)$!!;
 150         my $name = $1;
 151
 152         $self -> {'name'} = $name;
 153         $parm = $path;
 154       }
 155     }
 156 end path
 157 # }}} path
 158
 159 # {{{ full_name
 160 start full_name
 161     {
 162       $full_name = $self -> {'path'} . $self -> {'name'};
 163     }
 164 end full_name
 165 # }}}