[old-projects.git] / deptrack / deptrack.pl

#!/usr/bin/perl -w
#
# $Id$

use strict;
use DBI();

my $dsn = "DBI:mysql:database=deptrack;host=localhost";
my $dbh = DBI->connect($dsn,"deptrack","phptrax");

my @incpath = split /:/, "./:../";

my $mask_inc = "\\.inc(\\.php)?\$";
my $mask_php = "(?<!\\.inc)\\.php\$";
my $mask_img = "\\.(png|gif|jpg)\$"; 

my $rootdir = $ARGV[0];

my $debug = 0;

# return program syntax 
sub syntax {
  print "Syntax:\n\tdeptrack root_directory\n\n";
  exit 0;
}

sub dprint {
  my($text) = @_;
  print($text) if ($debug);
}

###############################################################################
#                                                                             #
#                              text operations                                #
#                                                                             #
###############################################################################

# worker function called by tagextract and tagstrip
sub tagcrunch {
  my($tag1,$tag2,$intag,@lines) = @_;
  my($line,$pos,@out,$add);
   
  while ($line = shift(@lines)) {
    if ($intag) {
      # we are inside the block
      if (($pos=index($line, $tag2)) > -1) {
        $add = substr($line,0,$pos);
	$line = substr($line,$pos+length($tag2));
	$intag = 0;
      } else {
        $add = $line;
	$line = "";
      }
      $add =~ s/^\s*//;
      $add =~ s/\s*$//;
      push @out, "$add\n" if (length($add)>0);
    }
  
    if (!$intag) {
      # we are outside the block
      while(($pos = index($line, $tag1)) > -1) {
        $line = substr($line,$pos+length($tag1));
        if (($pos=index($line, $tag2)) > -1) {
            $add = substr($line,0,$pos);
	    $line = substr($line,$pos+length($tag2));
	} else {
	  $add = $line; 
	  $line="";
          $intag=1;
	}
        $add =~ s/^\s*//;
	$add =~ s/\s*$//;
        push @out, "$add\n" if (length($add)>0);
      }
    } 
  }
  return @out;
}

# return only blocks of @lines between tag1 and tag2
sub tagextract {
  my($tag1,$tag2,@lines) = @_;
  return &tagcrunch($tag1,$tag2,0,@lines);
}

# return @lines minus blocks between tag1 and tag2
sub tagstrip {
  my($tag1,$tag2,@lines) = @_;
  return &tagcrunch($tag2,$tag1,1,@lines);
}

# for each line, remove whatever is after the comment marker
sub commentstrip {
  my($tag,@lines) = @_;
  my @out;
  
  foreach my $line (@lines) {
    $line =~ s/$tag.*//;
    $line =~ s/\s*$//;
    push @out, "$line\n" if (length($line)>0);
  }
  return @out;
}


###############################################################################
#                                                                             #
#                                  DB access                                  #
#                                                                             #
###############################################################################

# clear a database table
sub cleartable {
  my($table) = @_;
  my $sth = $dbh->do("delete from $table");
}

# add a dependency into DB
sub putdep {
  my($pageid,$depid,$did,$type) = @_;
  my($sth);
  
  $sth = $dbh->prepare("select id from dep where page=$pageid and dep=$depid and dir=$did and type='$type'");
  $sth->execute();
  if (!$sth->rows) {
    $dbh->do("insert into dep set page=$pageid,dep=$depid,dir=$did,type='$type'");
  }
}

# put a directory into DB
sub putdir {
  my($dir) = @_;

  &dprint("putdir($dir)\n");
  my $did=&getdirid($dir);
  if (!$did) {
    $dbh->do("insert into dir set path='$dir'");
    $did=&getdirid($dir);
  }
  return $did;
}

# put a file into DB
sub putfile {
  my($file,$exists) = @_;
  my($fid,$type);
 
  $exists=0 if (!$exists);
  &dprint("putfile($file,$exists)\n");
  if ($exists) {
    $type = "page" if ($file =~ /$mask_php/);
    $type = "include" if ($file =~ /$mask_inc/);
    $type = "image" if ($file =~ /$mask_img/);
  } else {
    $type = "dead";
  }

  $fid=&getfileid($file);
  if ($fid) {
    $dbh->do("update file set type='$type' where id=$fid") if ($exists);
  } else {
    $dbh->do("insert into file set path='$file',type='$type'");
    $fid=&getfileid($file);
  }
  return $fid;  
}

# return the ID corresponding to a directory name
sub getdirid {
  my($dir) = @_;
  my($sth);
  
  $sth = $dbh->prepare("select id from dir where path='$dir'");
  $sth->execute();
  if (my $ref = $sth->fetchrow_hashref()) {
    return $ref->{"id"};
  } else {
   return 0;
  }
}

# return the ID corresponding to a file name
sub getfileid {
  my($file) = @_;
  my($sth);
  
  $sth = $dbh->prepare("select id from file where path='$file'");
  $sth->execute();
  if (my $ref = $sth->fetchrow_hashref()) {
    return $ref->{"id"};
  } else {
   return 0;
  }
}


###############################################################################
#                                                                             #
#                              file processing                                #
#                                                                             #
###############################################################################

# from a path in the server tree, return the path in the filesystem
sub realpath {
  my($vpath) = @_;
  
  return $rootdir.$vpath;
}

# given a working directory and a relative path, return full path
# ( in the server tree )
sub abspath {
  my($curdir,$relpath) = @_;
  my(@path,@comps,$ret);
 
  # current directory not absolute
  if ($curdir !~ /^\//) {
    print "abspath($curdir,$relpath) : $curdir is not an absolute path!\n";
    die;
  }

  # relpath is already absolute
  return $relpath if ($relpath =~ /^\//);
  
  # is there a final slash?
  my $finalslash="";
  $finalslash="/" if ($relpath =~ /\/$/);
  
  @path = split /\//,substr($curdir,1);
  @comps = split /\//,$relpath;
  foreach my $comp (@comps) {
    SWITCH: {
      if ($comp =~ /^\.$/) { last SWITCH; }
      if ($comp =~ /^\.\.$/) { pop @path; last SWITCH; }
      push @path, $comp;
    }
  }
  $ret = "/". join("/",@path) .$finalslash;
  $ret =~ s/\/\//\//;
  return $ret;
}

# parse a directory
sub parsedir {
  my($vdir) = @_;
  my($fid,$did);

  # build virtual path
  $did=&putdir($vdir);

  opendir(DIRHANDLE, &realpath($vdir));
  my @list = grep /^[^\.]/, readdir(DIRHANDLE);
  closedir(DIRHANDLE);
  
  my @incfiles=grep /$mask_inc/,@list;
  map (&putfile("${vdir}$_", 1), @incfiles);

  my @imgfiles=grep /$mask_img/,@list;
  map (&putfile("${vdir}$_", 1), @imgfiles);
  
  my @phpfiles=grep /$mask_php/,@list;
  foreach my $phpfile (@phpfiles) {
    if (-f realpath("${vdir}${phpfile}")) {
      $fid=&putfile("${vdir}${phpfile}", 1);
      &parsefile($fid, $did, "${vdir}${phpfile}", $vdir);
    } else {
      &putfile("${vdir}$phpfile", 0)
    }
  } 

  foreach my $entry (@list) {
    if ((-d realpath("${vdir}${entry}")) && ($entry !~ /^CVS$/)) {
      &parsedir("${vdir}${entry}/");
    }
  }
}

# parse a file
sub parsefile {
  my($fid,$did,$vfile,$vdir) = @_;
  my(@lines,@phplines,@includes,$depid,$sth,$ifile,$iexists);
  
  &dprint("parsefile($fid,$did,$vfile,$vdir)\n");
  
  # we return if we already have dependecies in the same scope
  $sth = $dbh->prepare("select id from dep where page=$fid and dir=$did");
  $sth->execute();
  return if (my $ref = $sth->fetchrow_hashref());
  
  open(FHANDLE,realpath($vfile));
  @lines = <FHANDLE>;
  close(FHANDLE);

  # strip out commented code
  @lines = &tagstrip("<!--","-->",@lines);

  # deal with PHP lines
  @phplines = &tagextract("<?php","?>",@lines);
  @phplines = &tagstrip("/*","*/",@phplines);
  @phplines = &commentstrip("\/\/",@phplines);
  @phplines = &commentstrip("#",@phplines);
  @includes = grep s/.*(require|include)\s*\(\"(.*)\"\).*\n$/$2/, @phplines;
  foreach my $include (@includes) {
    &dprint("REQ:$include\n");
    if ($include =~ /$mask_php/) {
      print "Warning : $include gets included by $vfile!\n";
    }
    $iexists=0;
    if ($include =~ /^[\.\/]/) {
      # the directory is specified
      $ifile = &abspath($vdir,$include);
      $iexists=1 if (-f &realpath($ifile));
    } else {
      # directory not specified, go through the include path
      foreach my $incp (@incpath) {
        $ifile = &abspath(&abspath($vdir,$incp),$include);
        &dprint("trying $ifile\n");
        if (-f &realpath($ifile)) {
          $iexists=1;
          last;
        }
      }
      # did not find file to be included, treat it as if it were
      # in the first segment of include path
      $ifile = &abspath(&abspath($vdir,$incpath[0]),$include) if (!$iexists);
    }
    $depid=&putfile($ifile,$iexists);
    &putdep($fid,$depid,$did,"include");
    &parsefile($depid,$did,$ifile,$vdir) if ($iexists);
  }
}

## do the work
my $nargs = @ARGV;
$nargs || &syntax();

$rootdir =~ s/\/$//;

if (!-d $rootdir) {
 print "root directory $rootdir not found!\n";
 die;
}

&cleartable("dir");
&cleartable("file");
&cleartable("dep");
&parsedir("/");
Commit	Line	Data
14d630dd JL	1	#!/usr/bin/perl -w
	2	#
	3	# $Id$
	4
90bd1770	5	use strict;
16c93300	6	use DBI();
90bd1770 JL	7
	8	my $dsn = "DBI:mysql:database=deptrack;host=localhost";
	9	my $dbh = DBI->connect($dsn,"deptrack","phptrax");
	10
a6c2c2fb	11	my @incpath = split /:/, "./:../";
381ef085	12
16c93300 JL	13	my $mask_inc = "\\.inc(\\.php)?\$";
	14	my $mask_php = "(?<!\\.inc)\\.php\$";
	15	my $mask_img = "\\.(png\|gif\|jpg)\$";
0a7f073d	16
381ef085 JL	17	my $rootdir = $ARGV[0];
381ef085 JL	18
69392ab9 JL	19	my $debug = 0;
69392ab9 JL	20
14d630dd JL	21	# return program syntax
14d630dd JL	22	sub syntax {
a6c2c2fb	23	print "Syntax:\n\tdeptrack root_directory\n\n";
096a8c17	24	exit 0;
14d630dd JL	25	}
14d630dd JL	26
69392ab9 JL	27	sub dprint {
	28	my($text) = @_;
	29	print($text) if ($debug);
	30	}
16c93300 JL	31
	32	###############################################################################
	33	# #
	34	# text operations #
	35	# #
	36	###############################################################################
	37
14d630dd JL	38	# worker function called by tagextract and tagstrip
	39	sub tagcrunch {
	40	my($tag1,$tag2,$intag,@lines) = @_;
90bd1770	41	my($line,$pos,@out,$add);
14d630dd JL	42
	43	while ($line = shift(@lines)) {
	44	if ($intag) {
	45	# we are inside the block
	46	if (($pos=index($line, $tag2)) > -1) {
	47	$add = substr($line,0,$pos);
	48	$line = substr($line,$pos+length($tag2));
	49	$intag = 0;
	50	} else {
	51	$add = $line;
	52	$line = "";
	53	}
	54	$add =~ s/^\s*//;
	55	$add =~ s/\s*$//;
096a8c17	56	push @out, "$add\n" if (length($add)>0);
14d630dd JL	57	}
	58
	59	if (!$intag) {
	60	# we are outside the block
	61	while(($pos = index($line, $tag1)) > -1) {
	62	$line = substr($line,$pos+length($tag1));
	63	if (($pos=index($line, $tag2)) > -1) {
	64	$add = substr($line,0,$pos);
	65	$line = substr($line,$pos+length($tag2));
	66	} else {
	67	$add = $line;
	68	$line="";
	69	$intag=1;
	70	}
	71	$add =~ s/^\s*//;
	72	$add =~ s/\s*$//;
096a8c17	73	push @out, "$add\n" if (length($add)>0);
14d630dd JL	74	}
	75	}
	76	}
0a7f073d	77	return @out;
14d630dd JL	78	}
	79
	80	# return only blocks of @lines between tag1 and tag2
	81	sub tagextract {
	82	my($tag1,$tag2,@lines) = @_;
096a8c17	83	return &tagcrunch($tag1,$tag2,0,@lines);
14d630dd JL	84	}
	85
	86	# return @lines minus blocks between tag1 and tag2
	87	sub tagstrip {
	88	my($tag1,$tag2,@lines) = @_;
096a8c17	89	return &tagcrunch($tag2,$tag1,1,@lines);
14d630dd JL	90	}
14d630dd JL	91
0a7f073d JL	92	# for each line, remove whatever is after the comment marker
	93	sub commentstrip {
	94	my($tag,@lines) = @_;
	95	my @out;
	96
	97	foreach my $line (@lines) {
	98	$line =~ s/$tag.*//;
	99	$line =~ s/\s*$//;
096a8c17	100	push @out, "$line\n" if (length($line)>0);
0a7f073d JL	101	}
	102	return @out;
	103	}
	104
16c93300 JL	105
	106	###############################################################################
	107	# #
	108	# DB access #
	109	# #
	110	###############################################################################
	111
a6c2c2fb	112	# clear a database table
16c93300 JL	113	sub cleartable {
	114	my($table) = @_;
	115	my $sth = $dbh->do("delete from $table");
	116	}
	117
a6c2c2fb	118	# add a dependency into DB
381ef085 JL	119	sub putdep {
	120	my($pageid,$depid,$did,$type) = @_;
	121	my($sth);
	122
	123	$sth = $dbh->prepare("select id from dep where page=$pageid and dep=$depid and dir=$did and type='$type'");
	124	$sth->execute();
	125	if (!$sth->rows) {
	126	$dbh->do("insert into dep set page=$pageid,dep=$depid,dir=$did,type='$type'");
	127	}
	128	}
	129
a6c2c2fb	130	# put a directory into DB
381ef085 JL	131	sub putdir {
	132	my($dir) = @_;
	133
69392ab9	134	&dprint("putdir($dir)\n");
381ef085 JL	135	my $did=&getdirid($dir);
	136	if (!$did) {
	137	$dbh->do("insert into dir set path='$dir'");
	138	$did=&getdirid($dir);
	139	}
	140	return $did;
	141	}
	142
a6c2c2fb	143	# put a file into DB
16c93300 JL	144	sub putfile {
	145	my($file,$exists) = @_;
	146	my($fid,$type);
a6c2c2fb JL	147
a6c2c2fb JL	148	$exists=0 if (!$exists);
69392ab9	149	&dprint("putfile($file,$exists)\n");
16c93300 JL	150	if ($exists) {
	151	$type = "page" if ($file =~ /$mask_php/);
	152	$type = "include" if ($file =~ /$mask_inc/);
	153	$type = "image" if ($file =~ /$mask_img/);
16c93300	154	} else {
381ef085 JL	155	$type = "dead";
	156	}
	157
	158	$fid=&getfileid($file);
	159	if ($fid) {
	160	$dbh->do("update file set type='$type' where id=$fid") if ($exists);
	161	} else {
	162	$dbh->do("insert into file set path='$file',type='$type'");
16c93300 JL	163	$fid=&getfileid($file);
	164	}
	165	return $fid;
	166	}
	167
a6c2c2fb	168	# return the ID corresponding to a directory name
381ef085 JL	169	sub getdirid {
	170	my($dir) = @_;
	171	my($sth);
	172
	173	$sth = $dbh->prepare("select id from dir where path='$dir'");
	174	$sth->execute();
	175	if (my $ref = $sth->fetchrow_hashref()) {
	176	return $ref->{"id"};
	177	} else {
	178	return 0;
	179	}
	180	}
	181
a6c2c2fb	182	# return the ID corresponding to a file name
16c93300 JL	183	sub getfileid {
	184	my($file) = @_;
	185	my($sth);
	186
	187	$sth = $dbh->prepare("select id from file where path='$file'");
	188	$sth->execute();
	189	if (my $ref = $sth->fetchrow_hashref()) {
	190	return $ref->{"id"};
	191	} else {
	192	return 0;
	193	}
	194	}
	195
	196
	197	###############################################################################
	198	# #
	199	# file processing #
	200	# #
	201	###############################################################################
	202
a6c2c2fb	203	# from a path in the server tree, return the path in the filesystem
381ef085 JL	204	sub realpath {
	205	my($vpath) = @_;
	206
	207	return $rootdir.$vpath;
	208	}
	209
a6c2c2fb JL	210	# given a working directory and a relative path, return full path
a6c2c2fb JL	211	# ( in the server tree )
381ef085 JL	212	sub abspath {
	213	my($curdir,$relpath) = @_;
	214	my(@path,@comps,$ret);
	215
	216	# current directory not absolute
	217	if ($curdir !~ /^\//) {
	218	print "abspath($curdir,$relpath) : $curdir is not an absolute path!\n";
	219	die;
	220	}
	221
	222	# relpath is already absolute
	223	return $relpath if ($relpath =~ /^\//);
	224
	225	# is there a final slash?
	226	my $finalslash="";
	227	$finalslash="/" if ($relpath =~ /\/$/);
	228
	229	@path = split /\//,substr($curdir,1);
	230	@comps = split /\//,$relpath;
	231	foreach my $comp (@comps) {
	232	SWITCH: {
	233	if ($comp =~ /^\.$/) { last SWITCH; }
	234	if ($comp =~ /^\.\.$/) { pop @path; last SWITCH; }
	235	push @path, $comp;
	236	}
	237	}
	238	$ret = "/". join("/",@path) .$finalslash;
	239	$ret =~ s/\/\//\//;
	240	return $ret;
	241	}
	242
14d630dd JL	243	# parse a directory
14d630dd JL	244	sub parsedir {
381ef085 JL	245	my($vdir) = @_;
381ef085 JL	246	my($fid,$did);
0a7f073d JL	247
0a7f073d JL	248	# build virtual path
381ef085	249	$did=&putdir($vdir);
0a7f073d	250
381ef085	251	opendir(DIRHANDLE, &realpath($vdir));
90bd1770 JL	252	my @list = grep /^[^\.]/, readdir(DIRHANDLE);
90bd1770 JL	253	closedir(DIRHANDLE);
0a7f073d	254
16c93300 JL	255	my @incfiles=grep /$mask_inc/,@list;
16c93300 JL	256	map (&putfile("${vdir}$_", 1), @incfiles);
0a7f073d	257
16c93300 JL	258	my @imgfiles=grep /$mask_img/,@list;
	259	map (&putfile("${vdir}$_", 1), @imgfiles);
	260
	261	my @phpfiles=grep /$mask_php/,@list;
381ef085 JL	262	foreach my $phpfile (@phpfiles) {
	263	if (-f realpath("${vdir}${phpfile}")) {
	264	$fid=&putfile("${vdir}${phpfile}", 1);
	265	&parsefile($fid, $did, "${vdir}${phpfile}", $vdir);
	266	} else {
	267	&putfile("${vdir}$phpfile", 0)
	268	}
	269	}
	270
0a7f073d	271	foreach my $entry (@list) {
381ef085 JL	272	if ((-d realpath("${vdir}${entry}")) && ($entry !~ /^CVS$/)) {
381ef085 JL	273	&parsedir("${vdir}${entry}/");
0a7f073d	274	}
14d630dd JL	275	}
	276	}
	277
	278	# parse a file
	279	sub parsefile {
381ef085	280	my($fid,$did,$vfile,$vdir) = @_;
a5d444f3	281	my(@lines,@phplines,@includes,$depid,$sth,$ifile,$iexists);
381ef085	282
69392ab9	283	&dprint("parsefile($fid,$did,$vfile,$vdir)\n");
a6c2c2fb JL	284
a6c2c2fb JL	285	# we return if we already have dependecies in the same scope
381ef085 JL	286	$sth = $dbh->prepare("select id from dep where page=$fid and dir=$did");
	287	$sth->execute();
	288	return if (my $ref = $sth->fetchrow_hashref());
	289
	290	open(FHANDLE,realpath($vfile));
90bd1770 JL	291	@lines = <FHANDLE>;
90bd1770 JL	292	close(FHANDLE);
0a7f073d	293
90bd1770	294	# strip out commented code
096a8c17	295	@lines = &tagstrip("<!--","-->",@lines);
90bd1770 JL	296
90bd1770 JL	297	# deal with PHP lines
096a8c17 PH	298	@phplines = &tagextract("<?php","?>",@lines);
	299	@phplines = &tagstrip("/","/",@phplines);
	300	@phplines = &commentstrip("\/\/",@phplines);
	301	@phplines = &commentstrip("#",@phplines);
381ef085	302	@includes = grep s/.(require\|include)\s\(\"(.)\"\).\n$/$2/, @phplines;
90bd1770	303	foreach my $include (@includes) {
69392ab9	304	&dprint("REQ:$include\n");
381ef085	305	if ($include =~ /$mask_php/) {
69392ab9	306	print "Warning : $include gets included by $vfile!\n";
381ef085	307	}
69392ab9 JL	308	$iexists=0;
	309	if ($include =~ /^[\.\/]/) {
	310	# the directory is specified
	311	$ifile = &abspath($vdir,$include);
	312	$iexists=1 if (-f &realpath($ifile));
	313	} else {
	314	# directory not specified, go through the include path
	315	foreach my $incp (@incpath) {
	316	$ifile = &abspath(&abspath($vdir,$incp),$include);
	317	&dprint("trying $ifile\n");
	318	if (-f &realpath($ifile)) {
	319	$iexists=1;
	320	last;
a6c2c2fb	321	}
a6c2c2fb	322	}
69392ab9 JL	323	# did not find file to be included, treat it as if it were
	324	# in the first segment of include path
	325	$ifile = &abspath(&abspath($vdir,$incpath[0]),$include) if (!$iexists);
90bd1770	326	}
69392ab9 JL	327	$depid=&putfile($ifile,$iexists);
	328	&putdep($fid,$depid,$did,"include");
	329	&parsefile($depid,$did,$ifile,$vdir) if ($iexists);
90bd1770	330	}
14d630dd JL	331	}
14d630dd JL	332
0a7f073d	333	## do the work
14d630dd	334	my $nargs = @ARGV;
096a8c17	335	$nargs \|\| &syntax();
14d630dd	336
381ef085 JL	337	$rootdir =~ s/\/$//;
	338
	339	if (!-d $rootdir) {
	340	print "root directory $rootdir not found!\n";
	341	die;
	342	}
	343
	344	&cleartable("dir");
	345	&cleartable("file");
	346	&cleartable("dep");
	347	&parsedir("/");