fgutils.pl to HTML.

index -|- end

Generated: Tue Feb 2 17:54:36 2010 from fgutils.pl 2009/10/25 14.7 KB.

#!perl -w
##########################################################################################
# include module: fgutils.pl
# 20090912 - minor update checking keys passed in array, to array_2_hash_on_equals(...)
# fgutils contains is_h_source, is_c_source, is_in_array, add_quotes, rename_2_old_bak
# fgutils contains get_rel_dos_path, get_relative_path, path_d2u($), path_u2d($), trim_all
# fgutils contains write2file($txt,$fil), strip_dotrel = remove '.\|/' from beginning
##########################################################################################
my $def_src_filt = "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;for;f90";
my $def_hdr_filt = "h;hpp;hxx;hm;inl;fi;fd";
my $def_rcs_filt = "ico;cur;bmp;dlg;rc2;rct;bin;cnt;rtf;gif;jpg;jpeg;jpe";
my $def_spl_filt = "txt;vc5;h-msvc8;asm";
my $def_oth_filt = $def_hdr_filt.';'.$def_rcs_filt.';'.$def_spl_filt;
my $def_src_grp = "Source Files";    # Begin Group "Source Files"
my $def_hdr_grp = "Header Files";   # Begin Group "Header Files"
my $def_rcs_grp = "Resource Files";   # Begin Group "Resource Files"
my $def_spl_grp = "Special Files";
my $def_unknown = "Other Files";
sub get_def_src_filt { return $def_src_filt; }
sub get_def_hdr_filt { return $def_hdr_filt; }
sub get_def_rcs_filt { return $def_rcs_filt; }
sub get_def_spl_filt { return $def_spl_filt; }
sub get_def_src_grp { return $def_src_grp; }
sub get_def_hdr_grp { return $def_hdr_grp; }
sub get_def_rcs_grp { return $def_rcs_grp; }
sub get_def_spl_grp { return $def_spl_grp; }
######## LOG FILE STUFF #########
my $write_log = 0;
sub open_log {
   my ($f) = shift;
   open $LF, ">$f" or die "ERROR: Unable to open $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 );
   }
   system( $of ) if ($p);
}
sub write2file {
   my ($txt,$fil) = @_;
   open WOF, ">$fil" or mydie("ERROR: Unable to open $fil! $!\n");
   print WOF $txt;
   close WOF;
}
sub append2file {
   my ($txt,$fil) = @_;
   open WOF, ">>$fil" or mydie("ERROR: Unable to open $fil! $!\n");
   print WOF $txt;
   close WOF;
}
sub trim_ends {
    my ($ln) = shift;
   $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
    return $ln;
}
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 = trim_ends($ln);
   $ln =~ s/\s{2}/ /g while ($ln =~ /\s{2}/);   # all double space to SINGLE
   return $ln;
}
#########################################
###### 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;
}
#########################################
# 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 rename_2_old_bak {
   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;
}
# miscellaneous items
sub add_quotes {
    my ($txt) = shift;
    return '"'.$txt.'"';
}
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;
}
# 29/10/2008 - The DEFAULT filter is -
# # PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat"
# WHICH INCLUDES A LOT MORE - 20090915 - added '.cc', seen in some unix sources
sub is_c_source {
   my $f = shift;
   if ( ($f =~ /\.c$/i) || ($f =~ /\.cpp$/i) || ($f =~ /\.cxx$/i) || ($f =~ /\.cc$/i) ) {
      return 1;
   }
   return 0;
}
sub is_c_source_extended {
   my $f = shift;
   if (is_c_source($f) ) {
      return 1;
   } elsif ( ($f =~ /\.rc$/i) ||
        ($f =~ /\.def$/i) ||
        ($f =~ /\.rc$/i) ||
        ($f =~ /\.odl$/i) ||
        ($f =~ /\.idl$/i) ||
        ($f =~ /\.hpj$/i) ||
        ($f =~ /\.bat$/i) ||
        ($f =~ /\.asm$/i) ||
        ($f =~ /\.nas$/i) ) {
        return 1;
    }
   return 0;
}
sub is_h_source {
   my $f = shift;
   if ( ($f =~ /\.h$/i) || ($f =~ /\.hpp$/i) || ($f =~ /\.hxx$/i) ) {
      return 1;
   }
   return 0;
}
sub is_h_special {
   my $f = shift;
   if (($f =~ /osg/i)||($f =~ /OpenThreads/i)||($f =~ /Producer/i)) {
      return 1;
   }
   return 0;
}
sub is_h_source_extended {
    my ($f) = shift;
    if (is_h_source($f)) {
        return 1;
    } elsif ($f =~ /README/i) {
        return 1;
    } elsif (is_h_special($f)) {
        return 1;
    }
    return 0;
}
sub is_resource_file($) {
    my ($f) = shift;
    my @res_extents = qw( ico cur bmp dlg rc2 rct bin rgs gif jpg jpeg jpe );
    foreach my $ext (@res_extents) {
        if ($f =~ /\.$ext$/i) {
            return 1;
        }
    }
    return 0;
}
sub strip_dotrel {
    my ($txt) = shift;
    $txt =~ s/^\.(\\|\/)//;
    return $txt;
}
# split_space - space_split - 
# like split(/\s/,$txt), but honour double inverted commas
# also accept and split '"something"/>', but ONLY if in the tail
sub space_split {
   my ($txt) = shift;
   my $len = length($txt);
   my ($k, $ch, $tag, $incomm, $k2, $nch);
   my @arr = ();
   $tag = '';
   $incomm = 0;
   for ($k = 0; $k < $len; $k++) {
      $ch = substr($txt,$k,1);
        $k2 = $k + 1;
        $nch = ($k2 < $len) ? substr($txt,$k2,1) : "";
      if ($incomm) {
         $incomm = 0 if ($ch eq '"');
         $tag .= $ch;
      } elsif ($ch =~ /\s/) { # any spacey char
         push(@arr, $tag) if (length($tag));
         $tag = '';
      } elsif (($ch =~ /\//)&&($nch eq '>')) { # 04/10/2008, but only if before '>' 24/09/2008 add this as well
         push(@arr, $tag) if (length($tag));
         $tag = $ch; # restart tag with this character
      } else {
         $tag .= $ch;
         $incomm = 1 if ($ch eq '"');
      }
   }
   push(@arr, $tag) if (length($tag));
   return @arr;
}
sub space_split_OLD {
   my ($txt) = shift;
   my $len = length($txt);
   my ($k, $ch, $tag, $incomm);
   my @arr = ();
   $tag = '';
   $incomm = 0;
   for ($k = 0; $k < $len; $k++) {
      $ch = substr($txt,$k,1);
      if ($incomm) {
         $incomm = 0 if ($ch eq '"');
         $tag .= $ch;
      } elsif ($ch =~ /\s/) {
         push(@arr, $tag) if (length($tag));
         $tag = '';
      } else {
         $tag .= $ch;
         $incomm = 1 if ($ch eq '"');
      }
   }
   push(@arr, $tag) if (length($tag));
   ##if ($dbg_src13) {
   ##   prt( "space_split (".scalar @arr.") of [$txt]\n" );
   ##   foreach $tag (@arr) {
   ##      prt( " $tag\n" );
   ##   }
   ##}
   return @arr;
}
sub array_2_hash_on_equals {
   my (@inarr) = @_;
   my %hash = ();
   my ($itm, @arr, $key, $val, $al, $a, $cnt, $titm);
   $cnt = 0;
   foreach $itm (@inarr) {
      $cnt++;
      $titm = trim_all($itm);
      if (length($titm) == 0) {
         prt( "NOTE: fgutils:array_2_hash_on_equals: Item $cnt has NO length in passed array!\n" );
         next;
      } elsif ($titm eq '=') {
         # 20090912 - lets overlook this = no noise
         ### prt( "NOTE: fgutils:array_2_hash_on_equals: Item $cnt is JUST an equal sign! [$itm]!\n" );
         next;
      }
      @arr = split('=',$itm);
      $al = scalar @arr;
      $key = $arr[0];
      $val = '';
      for ($a = 1; $a < $al; $a++) {
         $val .= '=' if length($val);
         $val .= $arr[$a];
      }
      if (defined $key && length($key)) {
         if (defined $hash{$key}) {
            prtw( "WARNING: array_2_hash_on_equals: Duplicate KEY: [$key] ... ADDING val [$val]\n" );
            $hash{$key} .= "\@".$val;
         } else {
            $hash{$key} = $val;
         }
      } else {
         if (defined $key) {
            prt( "NOTE: fgutils:array_2_hash_on_equals: Item $cnt:$itm: key=[$key] has NO length in passed array!\n" );
         } else {
            prt( "NOTE: fgutils:array_2_hash_on_equals: Item $cnt:$itm: key is NOT set in passed array!\n" );
         }
      }
   }
   return %hash;
}
sub strip_quotes {
   my ($ln) = shift;
   if ($ln =~ /^".*"$/) {
      $ln = substr($ln,1,length($ln)-2);
   }
   return $ln;
}
sub strip_both_quotes {
   my ($ln) = shift;
    $ln = strip_quotes($ln);
   if ($ln =~ /^'.*'$/) {
      $ln = substr($ln,1,length($ln)-2);
   }
   return $ln;
}
# seems MSVC8, and maybe others, when converting the MSVC6 DSP
# to a VCPORJ file can NOT tollerate a command
# ending in a '\' character, without quotes around it
# #########################################################
sub massage_command {
    my ($txt) = shift;
    if ($txt =~ /\\$/) {
        my ($len, $ch, $bgn, $end);
        # need to back up to previous space,
        # and add quotes around the last command
        $len = length($txt);
        while ($len) {
            $len--;
            $ch = substr($txt,$len,1);
            if ($ch eq ' ') {
                last;
            }
        }
        if ($len) {
            $len++;
            $bgn = substr($txt,0,$len);
            $end = substr($txt,$len);
            $txt = $bgn.add_quotes($end);
        }
    }
    return $txt;
}
#  0    1    2     3     4    5     6     7     8
# ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
# so  if I want the DIR form
#01/10/2008  16:01    <DIR>          SimGear
#16/09/2008  11:38               500 slnlist.txt
sub show_file_stat {
    use File::stat;
    use File::Basename;
    my ($fil, $pr) = @_;
    my ($nm,$dr) = fileparse($fil);
    my ($sb, $msg);
    $dr = '' if ($dr eq ".\\");
    if ($sb = stat($fil)) {
        @lt = localtime($sb->mtime);
        if (-d $fil) {
            $msg = sprintf( "%02d/%02d/%04d %02d:%02d %12s %s %s", $lt[3], $lt[4]+1, $lt[5]+1900,
                $lt[2], $lt[1], "<DIR>", $nm, $dr );
        } else {
            $msg = sprintf( "%02d/%02d/%04d %02d:%02d %12d %s %s", $lt[3], $lt[4]+1, $lt[5]+1900,
                $lt[2], $lt[1], $sb->size, $nm, $dr );
        }
    } else {
        $msg = "FAILED: stat of $nm $dr! $!";
    }
    prt( "$msg\n" ) if $pr;
    return $msg;
}
sub fix_rel_path {
   my ($path) = shift;
   $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: Got relative .. without previous!!! path=$path\n" );
         }
      } else {
         push(@na,$p);
      }
   }
   foreach my $pt (@na) {
      $npath .= "\\" if length($npath);
      $npath .= $pt;
   }
   return $npath;
}
1;
# eof

index -|- top

checked by tidy  Valid HTML 4.01 Transitional