#!/Perl # logfile.pl # 26/08/2010 - changed 'open' to 'CREATE' # 16/05/2010 - added 'strip_quotes', 'fix_rel_path3' use File::Basename; # split path ($name,$dir,$ext) = fileparse($file [, qr/\.[^.]*/] ) sub open_log { my ($f) = shift; open $LF, ">$f" or die "ERROR:open_log:logfile.pl: Unable to CREATE $f ...\n"; $write_log = 1; } sub prt { my ($msg) = shift; if ($write_log) { print $LF $msg; } print $msg; } sub mydie { my ($msg) = shift; if ($write_log) { print $LF $msg; } die $msg; } sub close_log { my ($of, $p) = @_; prt( "Closing LOG and passing $of to system ...\nMay need to CLOSE notepad to exit ...\n") if ($p); if ($write_log) { close( $LF ); $write_log = 0; } system( $of ) if ($p); } sub write2file { my ($txt,$fil) = @_; open WOF, ">$fil" or mydie("ERROR:write2file:logfile.pl: Unable to CREATE [$fil]! $!\n"); print WOF $txt; close WOF; } sub write_a_file { my ($fil, @txt) = @_; open WOF, ">$fil" or mydie("ERROR:write_a_file:logfile.pl: Unable to CREATE $fil! $!\n"); print WOF @txt; close WOF; } sub append2file { my ($txt,$fil) = @_; open WOF, ">>$fil" or mydie("ERROR:append2file:logfile.pl: Unable to open/append to [$fil]! $!\n"); print WOF $txt; close WOF; } sub writebinfile { my ($txt,$fil) = @_; open WOF, ">$fil" or mydie( "ERROR:writebinfile:logfile.pl: Unable to CREATE [$fil]! $! \n" ); binmode WOF; print WOF $txt; close WOF; } ############################### # some utilities sub is_in_array { my ($itm, @arr) = @_; my $max = scalar @arr; for (my $k = 0; $k < $max; $k++) { if ($arr[$k] eq $itm) { return $k + 1; # return offset plus 1 } } return 0; } sub trim_all($) { my ($ln) = shift; $ln =~ s/\n/ /gm; # replace CR (\n) $ln =~ s/\r/ /gm; # replace LF (\r) $ln =~ s/\t/ /g; # TAB(s) to a SPACE $ln = substr($ln,1) while ($ln =~ /^\s/); # remove all LEADING space $ln = substr($ln,0, length($ln) - 1) while ($ln =~ /\s$/); # remove all TRAILING space $ln =~ s/\s{2}/ /g while ($ln =~ /\s{2}/); # all double space to SINGLE return $ln; } sub file_extension { my $fil = shift; my ($nm,$dir,$ext) = fileparse( $fil, qr/\.[^.]*/ ); return $ext; } sub file_title { my $fil = shift; my ($nm,$dir,$ext) = fileparse( $fil, qr/\.[^.]*/ ); return $nm; } # Return directory name of file. sub file_dirname { my ($fil) = shift; my ($nm,$dir) = fileparse($fil); return $dir; } # RENAME A FILE TO .OLD, or .BAK # 0 - do nothing if file does not exist. # 1 - rename to .OLD if .OLD does NOT exist # 2 - rename to .BAK, if .OLD already exists, # 3 - deleting any previous .BAK ... sub rename2oldbak { my ($fil) = shift; my $ret = 0; # assume NO SUCH FILE if ( -f $fil ) { # is there? my ($nm,$dir,$ext) = fileparse( $fil, qr/\.[^.]*/ ); my $nmbo = $dir . $nm . '.old'; $ret = 1; # assume renaming to OLD if ( -f $nmbo) { # does OLD exist $ret = 2; # yes - rename to BAK $nmbo = $dir . $nm . '.bak'; if ( -f $nmbo ) { $ret = 3; unlink $nmbo; } } rename $fil, $nmbo; } return $ret; } ######################################### ###### relative path stuff ############## sub path_u2d($) { my ($ud) = shift; $ud =~ s/\//\\/g; return $ud; } sub path_d2u($) { my ($du) = shift; $du =~ s/\\/\//g; return $du; } # Given TWO FOLDER, attempt to get RELATIVE PATH from the FROM DIRECTORY, # to the TARGET DIRECTORY. MUSTS BE DIRECTORIES, NOT FILE PATHS ##my $rel = get_relative_path( $htm_folder, $my_folder ); added 20070820 # seems to work fine ... still under test!!! # 17/11/2007 - Further refinement to REMOVE all warnings sub get_relative_path { my ($target, $fromdir) = @_; my $dbg_rel = 0; my ($colonpos, $path, $posval, $diffpos, $from, $to); my ($tlen, $flen); my ($lento, $lenfrom); my $retrel = ""; # only work with slash - convert DOS backslash to slash $target = path_d2u($target); $fromdir = path_d2u($fromdir); # add '/' to target. if missing if (substr($target, length($target)-1, 1) ne '/') { $target .= '/'; } # add '/' to fromdir. if missing if (substr($fromdir, length($fromdir)-1, 1) ne '/') { $fromdir .= '/'; } # remove drives, if present if ( ( $colonpos = index( $target, ":" ) ) != -1 ) { $target = substr( $target, $colonpos+1 ); } if ( ( $colonpos = index( $fromdir, ":" ) ) != -1 ) { $fromdir = substr( $fromdir, $colonpos+1 ); } # got the TO and FROM ... $to = $target; $from = $fromdir; print "To [$to], from [$from] ...\n" if ($dbg_rel); $path = ''; $posval = 0; $retrel = ''; $lento = length($to); $lenfrom = length($from); # // Step through the paths until a difference is found (ignore slash differences) # // or until the end of one is found while ( ($posval < $lento) && ($posval < $lenfrom) ) { if ( substr($from,$posval,1) eq substr($to,$posval,1) ) { $posval++; # bump to next } else { last; # break; } } # // Save the position of the first difference $diffpos = $posval; # // Check if the directories are the same or # // the if target is in a subdirectory of the fromdir if ( ( !substr($from,$posval,1) ) && ( substr($to,$posval,1) eq "/" || !substr($to,$posval,1) ) ) { # // Build relative path $diffpos = length($target); if (($posval + 1) < $diffpos) { $diffpos-- if ($diffpos); if ($diffpos > $posval) { $diffpos -= $posval; } else { $diffpos = 0; } ###$retrel = substr( $target, $posval+1, length( $target ) ); print "Return substr of target, from ".($posval+1).", for $diffpos length ...\n" if ($dbg_rel); $retrel = substr( $target, $posval+1, $diffpos ); } else { print "posval+1 (".($posval+1).") greater than length $diffpos ...\n" if ($dbg_rel); } } else { # // find out how many "../"'s are necessary # // Step through the fromdir path, checking for slashes # // each slash encountered requires a "../" #$posval++; while ( substr($from,$posval,1) ) { print "Check for slash ... $posval in $from\n" if ($dbg_rel); if ( substr($from,$posval,1) eq "/" ) { # || ( substr($from,$posval,1) eq "\\" ) ) { print "Found a slash, add a '../' \n" if ($dbg_rel); $path .= "../"; } $posval++; } print "Path [$path] ...\n" if ($dbg_rel); # // Search backwards to find where the first common directory # // as some letters in the first different directory names # // may have been the same $diffpos--; while ( ( substr($to,$diffpos,1) ne "/" ) && substr($to,$diffpos,1) ) { $diffpos--; } # // Build relative path to return $retrel = $path . substr( $target, $diffpos+1, length( $target ) ); } print "Returning [$retrel] ...\n" if ($dbg_rel); return $retrel; } sub get_rel_dos_path { my ($targ, $from) = @_; my $rp = get_relative_path($targ, $from); $rp = path_u2d($rp); return $rp; } ######################################### sub strip_quotes { my ($ln) = shift; if ($ln =~ /^".*"$/) { $ln = substr($ln,1,length($ln)-2); } return $ln; } sub fix_rel_path3($$) { my ($path,$caller) = @_; $path = path_u2d($path); # ENSURE DOS PATH SEPARATOR (in relative.pl) my @a = split(/\\/, $path); my $npath = ''; my $max = scalar @a; my @na = (); for (my $i = 0; $i < $max; $i++) { my $p = $a[$i]; if ($p eq '.') { # ignore this } elsif ($p eq '..') { if (@na) { pop @na; # discard previous } else { prtw( "WARNING:$caller: Got relative .. without previous!!! path=$path\n" ); } } else { push(@na,$p); } } foreach my $pt (@na) { $npath .= "\\" if length($npath); $npath .= $pt; } return $npath; } 1;