#include <stdio.h>
#include <stdlib.h>
#include <sys/types.h>
#include <dirent.h>
#include <sys/wait.h>
#include <string.h>

#define COMPARE(A,B) ( ! strncmp ( A , B , strlen( B ) ) )
#define COMPARE2(A,B) ( ! strcmp ( A , B ) )
#define INLINELEN (4*8192)
#define VARLEN 128
#define MAXARGS (4*8192)


#define DBDIR "tools/code_dbase"

int sw_all  = 0 ;


main( int argc, char *argv[] )
{
  FILE *fp ;
  FILE *calls ; 
  char fname[VARLEN], syscom[VARLEN] ;
  char *rout , *vname ;
  if ( argc < 2 || argc > 5 || ( argc == 2 && ! COMPARE2( argv[1] , "rebuild" ) ) ) {
    printf("usage : wrfvar varname routinename\n" ) ;
    printf("        wrfvar rebuild\n" ) ;
    exit(2) ;
  }
  vname = argv[1] ;
  rout = argv[2] ;
  if ( argc == 4 && argv[3] != NULL ) {
    if ( COMPARE2( argv[3] , "all" ) ) sw_all = 1 ;
  }
  sprintf( fname, "%s/calls", DBDIR ) ;
  if (( fp = fopen ( fname , "r" )) == NULL || COMPARE2( argv[1], "rebuild" ) ) {
    int rc ;
    printf("Building code database ... please wait\n") ;
    sprintf( syscom, "cd tools/CodeBase ; make" ) ;
    rc = system( syscom ) ;
    if ( WEXITSTATUS( rc ) ) { exit(3) ; }
    sprintf( syscom, "tools/build_codebase" ) ;
    rc = system( syscom ) ;
    if ( WEXITSTATUS( rc ) ) { exit(3) ; }
    sprintf( syscom, "ln -sf tools/wrfvar ." ) ;
    sprintf( syscom, "ln -sf tools/subinfo ." ) ;
    if ( COMPARE2( argv[1] , "rebuild" ) ) exit ;
  }
  fclose( fp ) ;
  lower_case_str ( vname ) ;
  lower_case_str ( rout ) ;
  printf("<h4>Trace upwards through call tree for %s</h4><p>\n",vname ) ;
  wrfvar ( vname, rout, 0 ) ;
}

wrfvar ( char * vname, char *rout, int recursion_level )
{
  FILE *ROUT ;
  FILE *BBB ;
  FILE *ELEF ;
  FILE *CALLER ;
  FILE *CALLERS ;
  FILE *REGISTRY ;
  DIR  *dir ;
  char inln[INLINELEN], inln2[INLINELEN], inln3[INLINELEN] ;
  int i ;
  char fname[VARLEN], fname2[VARLEN], sf[VARLEN] ;
  char vv[VARLEN], vv2[VARLEN] ;
  char u0[VARLEN] , u1[VARLEN] , u2[VARLEN] ;
  char v0[VARLEN] , v1[VARLEN] , v2[VARLEN] ;
  char r[12][VARLEN], t[12][VARLEN], u[12][VARLEN], v[12][VARLEN] ;
  char routfile[VARLEN] ;
  char tmp[VARLEN], darg[VARLEN], dintent[VARLEN] ;
  char hamuna[VARLEN] ;
  char rout1[VARLEN], rout2[VARLEN], rout3[VARLEN] ;
  char sourcefile[VARLEN], sourcefile_caller[VARLEN] ;
  char s1[VARLEN], s2[VARLEN], s3[VARLEN] ;
  char * p, * q, * q1, prev ;
  int found_var, nargs_rout, argn, callno, more_calls, first_time ;
  int contains_i1_declarations ;

  if (( dir = opendir ( DBDIR )) == NULL ) {
    fprintf(stderr, "Must be in top level WRF directory\n") ; exit(2) ;
  } closedir( dir ) ;

  strcpy( rout1, rout ) ;
  strcpy( vv, vname ) ;
  strcpy( vv2, vname ) ;
  remove_whitespace( vv2 ) ;
  /* remove arguments */
  if ((q = strchr( vv2 , '(' )) != NULL ) *q = '\0' ;
  /* remove time level if there */
  if (( q = strrchr( vv2, '_' )) != NULL ) {
    if ( COMPARE2( q , "_1" ) || COMPARE2( q , "_2" ) || COMPARE2( q , "_3" ) ) *q = '\0' ;
  }
  if ( COMPARE( vv2, "grid%" ) || !strcmp( rout, "registry_i1" )) {
    if (( REGISTRY = fopen( "Registry/Registry" , "r" )) == NULL ) {
          fprintf(stderr,"can not open Registry/Registry\n") ; exit(2) ; }
    strcpy( inln, "" ) ;
    while ( fgets( inln2, INLINELEN, REGISTRY ) != NULL ) {
      int inquote ;
      strcat( inln, inln2 ) ;
      if (( q = strrchr ( inln, '\\' )) != NULL ) {   /* continuation */
        *q = '\0' ; continue ; 
      }
      if (( q = strchr( inln, '#' )) != NULL ) *q = '\0' ;
      inquote = 0 ;
      for ( p = inln, q = inln2 ; *p ; p++, q++ ) {
        if      ( ! inquote && *p == '"' ) { inquote = 1 ; *p = ' ' ; }
        else if (   inquote && *p == '"' ) { inquote = 0 ; *p = ' ' ; }
        if ( *p == ' ' && inquote ) { *q = '`' ; }
        else                        { *q = *p ; }
      }
      *q = '\0' ;
      for ( i = 0 ; i < 11 ; i++ ) {
        strcpy( r[i] , "" ) ;
        get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; 
        if ( i < 10 ) lower_case_str( r[i] ) ;
      }
      if ( COMPARE2 ( r[0], "state" ) ) {
        if ( COMPARE ( r[4], "dyn_" ) ) {
          /* if core associated */
          sprintf(s1,"%s_",&(r[4][4])) ;
          i = strlen(&(r[4][4])) ;
#if 1
          { char *x , *y ; int j ; 
            for ( x = vv2+5 , y = s3 , j = 0 ; j < i ; j++ ) { *y++ = *x++ ; }
            *y = '\0' ;
          }
#else
/* is there a bug in this?? */
          strncpy( s3, vv2+5, i ) ;
fprintf(stderr,"X %s <- %s %d\n", s3, vv2, i ) ;
#endif
          sprintf(s2,"%s_",s3) ;
          if ( COMPARE2 ( s1, s2 )  &&
                COMPARE2 ( vv2+5+(strlen(r[4])-3), r[2] ) ) {
            for (p = r[9]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n",
                   recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ;
          }
        } else {
          /* if not core associated */
          if ( COMPARE2 ( vv2+5, r[2] ) ) {
            for (p = r[9]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n",
                   recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ;
          }
        }
      } else if ( COMPARE2 ( r[0], "rconfig" ) ) {
          if ( COMPARE2 ( vv2+5, r[2] ) ) {
            for (p = r[8]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <br>\n",
                   recursion_level+1, r[0], r[1], r[2], r[8] ) ;
          }
      } else if ( COMPARE2 ( r[0], "i1" ) && !strcmp( rout, "registry_i1" )) {
          if ( COMPARE2 ( vv2, r[2] ) ) {
            for (p = r[9]  ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            for (p = r[10] ; *p ; p++ ) { if ( *p == '`' ) *p = ' ' ; }
            printf("%3d. <b>Registry-defined</b>: <class> %s <type> %s <varname> %s <description> \"%s\" <units> \"%s\"<br>\n",
                   recursion_level+1, r[0], r[1], r[2], r[9], r[10] ) ;
          }
      }

      strcpy( inln, "" ) ;
    }
    fclose( REGISTRY ) ;
    return ;
  }

  sprintf( routfile, "%s/%s", DBDIR, rout ) ;
  strcpy ( sourcefile , "" ) ;
  found_var = 0 ;
  nargs_rout = 0 ;
  if (( ROUT = fopen( routfile, "r" )) == NULL ) return ;
  {
    contains_i1_declarations = 0 ;
    while ( fgets( inln, INLINELEN, ROUT ) != NULL ) {
      remove_nl ( inln ) ;
      /* find first non space */
      for ( p = inln ; *p ; p++ ) { if ( *p != ' ' ) break ; }
      /* change multiple spaces to single space */
      for ( q = p, q1 = q , prev = *p ; *q ; q++ ) 
	 { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
      strcpy( inln, p ) ;
      for ( i = 0 ; i < 11 ; i++ ) {
        strcpy( t[i] , "" ) ;
        get_token_n( inln, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ;
      }
      if ( COMPARE2( "contains_i1_declarations", t[0] ) ) {
        contains_i1_declarations = 1 ;
      } else if ( COMPARE2( "sourcefile" , t[0] ) ) {
	strcpy ( sourcefile , t[1] ) ;
      } else if ( COMPARE2( "arg" , t[0] ) ) {
	nargs_rout ++ ;
	if ( COMPARE2( t[3] , vname ) && ! COMPARE2( t[9] , "registry" ) ) {
	  argn = atoi( t[1] ) ;
	  printf("%3d. <b>%s</b> is dummy arg %d of %s (%s);\n", recursion_level+1, vname, argn+1, rout, sourcefile ) ;
	  found_var = 1 ;
	  fclose( ROUT ) ;
	  sprintf(fname,"%s/calls", DBDIR ) ;
	  strcpy( rout2, rout ) ;
	  if (( CALLERS = fopen( fname , "r" )) == NULL ) return ;
          while ( fgets( inln2, INLINELEN, CALLERS ) != NULL ) {
            for ( i = 0 ; i < 11 ; i++ ) {
              strcpy( u[i] , "" ) ;
              get_token_n( inln2, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ;
            }
	    if ( COMPARE2( u[2], rout2 ) ) {
	      strcpy( rout , u[0] ) ;
	      sprintf( fname, "%s/%s", DBDIR, rout ) ;
	      if (( ROUT = fopen( fname, "r" )) == NULL ) return ;
  	      strcpy ( sourcefile_caller, "" ) ;
	      callno = 1 ;
              more_calls = 0 ;
	      while ( fgets( inln3, INLINELEN, ROUT ) != NULL ) {
                for ( i = 0 ; i < 11 ; i++ ) {
                  strcpy( v[i] , "" ) ;
                  get_token_n( inln3, " ", i , v[i] ) ; remove_nl(v[i]) ; lower_case_str( v[i] ) ;
                }
		if        ( COMPARE2( v[0] , "sourcefile" ) ) {
		  strcpy( sourcefile_caller, v[1] ) ;
		} else if ( COMPARE2( v[0] , "actarg") && ( COMPARE2( v[4] , rout2 ) && atoi( v[1] ) == argn )) {
                  if ( callno == 1 || sw_all ) {
		    printf("     corresponding actual arg is <b>%s</b>, arg number %d in call %d by %s (%s).<br>\n",
                              v[6],argn,callno,rout2,sourcefile_caller) ;
		     /* RECURSION */
		    wrfvar ( v[6], rout, recursion_level+1 ) ;
                  } else if ( callno >= 2 ) {
                    more_calls = callno ;
                  }
		  callno++ ;
		}
	      }
	      fclose( ROUT ) ;
              if ( more_calls > 1 && recursion_level == 0 ) {
                printf("  there are %d more calls to %s from %s.  Try 'wrfvar %s %s all' to see all.\n", more_calls, rout2, rout, vname, rout2 ) ;
              }
	    }
	  }
	  fclose( CALLERS ) ;
	} else if ( COMPARE2( t[3] , vname ) && COMPARE2( t[9] , "registry" ) ) {
	  /* RECURSION */
          sprintf(tmp, "grid%%s", vname ) ;
	  wrfvar ( vname, "registry", recursion_level+1 ) ;
	  found_var = 1 ;
	}
      }
    }
  }
  if ( found_var == 0 ) {
    if ( contains_i1_declarations ) {
      /* take a look in the registry for i1 vars that might match */
      wrfvar ( vname, "registry_i1", recursion_level ) ;  /* recursion level does not increase here, since we're checking the registry */
    } else {
      printf("%s is not an argument to %s. May be local or use-associated.\n",vname,rout1 ) ;
      printf("%s has %d arguments\n",rout1,nargs_rout) ;
      fclose(ROUT) ;
      if (( ROUT = fopen( routfile , "r" )) == NULL ) return ;
      while ( fgets( inln2, INLINELEN, ROUT ) != NULL ) {
        remove_nl( inln2 ) ;
        /* find first non space */
        for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; }
        /* change multiple spaces to single space */
        for ( q = p, q1 = q , prev = *p ; *q ; q++ ) { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
        for ( i = 0 ; i < 11 ; i++ ) {
          strcpy( r[i] , "" ) ;
          get_token_n( inln2, " ", i , r[i] ) ; remove_nl(r[i]) ; lower_case_str( r[i] ) ;
        }
        if ( COMPARE2( r[0] , "arg" ) ) {
	  i = atoi(r[1]) + 1 ;
	  printf("%3d. ",i) ; 
	  printf("%s of type %s intent %s\n",r[3],r[5],r[7]) ;
        }
      }
    fclose( ROUT ) ;
    }
  }

/* get a list of the routines this guy calls */

  if ( recursion_level == 0 ) {
    first_time = 1 ;
    if (( BBB = fopen( routfile, "r" )) == NULL ) return ;
    while ( fgets( inln2, INLINELEN, BBB ) != NULL ) {
      remove_nl( inln2 ) ;
      /* find first non space */
      for ( p = inln2 ; *p ; p++ ) { if ( *p != ' ' ) break ; }
      /* change multiple spaces to single space */
      for ( q = p, q1 = q , prev = *p ; *q ; q++ ) 
	   { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
      for ( i = 0 ; i < 11 ; i++ ) {
        strcpy( t[i] , "" ) ;
        get_token_n( inln2, " ", i , t[i] ) ; remove_nl(t[i]) ; lower_case_str( t[i] ) ;
      }
      if        ( COMPARE2( t[0] , rout1 ) && COMPARE2( t[1] , "calls" ) ) {
	strcpy( hamuna , t[2] ) ;
      } else if ( COMPARE2( t[0] , "actarg" ) && COMPARE2( t[6] , vname ) ) {
	if ( first_time ) {
	  printf("\n<h4>%s is an actual arg in calls to these routines from %s</h4>\n",vname,rout1) ;
	  first_time = 0 ;
	}
	sprintf(fname,"%s/%s",DBDIR,hamuna) ;
	if (( ELEF = fopen ( fname , "r" )) == NULL ) continue ;
	while ( fgets( inln3, INLINELEN, ELEF ) != NULL ) {
          remove_nl( inln3 ) ;
          /* find first non space */
          for ( p = inln3 ; *p ; p++ ) { if ( *p != ' ' ) break ; }
          /* change multiple spaces to single space */
          for ( q = p, q1 = q , prev = *p ; *q ; q++ ) 
	     { if ( prev == ' ' && *q == ' ' ) { continue ; } else { prev = *q ; *q1++ = *q ; } }
          for ( i = 0 ; i < 11 ; i++ ) {
            strcpy( u[i] , "" ) ;
            get_token_n( inln3, " ", i , u[i] ) ; remove_nl(u[i]) ; lower_case_str( u[i] ) ;
          }
	  if ( COMPARE2( u[0] , "arg" ) && COMPARE2( u[1] , t[1] ) ) {
	    strcpy( darg , u[3] ) ;
	    strcpy( dintent , u[7] ) ;
	    break ;
	  }
	}
	fclose( ELEF ) ;
	printf("  %s (argument %d ; matching dummy arg is %s with intent %s)\n",hamuna,atoi(t[1])+1,darg,dintent ) ;
      }
    }
    printf("\n") ;
    fclose(BBB) ;
  }
}



#if 0
#!/bin/perl

$dbdir = "tools/code_dbase" ;

if ( ! opendir( TOOLDIR, "tools") )  {
print "\nMust be in top level WRF directory\n" ;
exit ;
}
closedir TOOLDIR ;

if ( (scalar @ARGV  < 1 || scalar @ARGV > 3)  || (scalar @ARGV == 1 && @ARGV[0] ne "rebuild") )  {
print "usage: wrfvar varname routinename \n" ;
print "       wrfvar rebuild \n" ;
exit ;
}


if ( ! open( XXX, "$dbdir/calls" ) || $ARGV[0] eq "rebuild" )
{
  print "Building code database ... please wait.\n" ;
  system( "cd tools/CodeBase ; make" ) ;
  $rc = system( "tools/build_codebase" ) ;

  if ( ($rc >> 8) == 99 ) { exit ; }
  system( "ln -sf tools/wrfvar ." ) ;
  system( "ln -sf tools/subinfo ." ) ;

  if ( $ARGV[0] eq "rebuild" ) { exit ; }
}


$vname = lc $ARGV[0] ;
$vname1 = $vname ;
$rout1 = lc $ARGV[1] ;
$recursion_level = $ARGV[2] ;
$rout = $rout1 ;
#print $vname,"\n" ;
#print $rout,"\n" ;

$spc = "`" ;
$vv = $vname ;
$vv =~ s/\(.*// ;
#print $vv,"\n" ;
if ( substr($vv,0,5)  eq "grid%" ) {
    open REGISTRY, "< Registry/Registry" or die "cannot open Registry/Registry" ;
    while ( <REGISTRY> ) {

      $line = $_ ;
      $line =~ s/#.*// ;
      next if ( $line eq "" ) ;
      $line =~ s/[ \t][ \t]*/ /g ;
      $line = lc $line ;
      # fill in the blanks in quote delimited strings then remove 
      # the quotes so we can split on white space
      
      $inquote = 0 ;
      $newline = "" ;
      for ( $i = 0 ; $i < length($line) ; $i++ )
      {
        $ccc = substr($line,$i,1) ;
        if    ( ! $inquote && $ccc eq '"' ) { $inquote = 1 ; }
        elsif (   $inquote && $ccc eq '"' ) { $inquote = 0 ; }
        if ( $ccc eq " " && $inquote ) { $newline = $newline.$spc ; }
        else                           { $newline = $newline.$ccc ; }
      }
      $line = $newline ;
      $line =~ s/\"//g ;

      @r = split ( ' ',$line ) ;
      if ( ($r[0] eq state ) ) {
        if (( substr($r[4],0,4) eq "dyn_" && 
              substr($r[4],4,length($r[4])-4)."_" eq substr($vv,5,length($r[4])-4)."_" &&
              substr($vv,5+length($r[4])-4+1,length($r[2]))) eq $r[2] ) {

          $r[9] =~ s/`/ /g ;
          $r[9] = uc $r[9] ;
          $r[10] =~ s/`/ /g ;
          $r[10] = uc $r[10] ;
	  print "**  Registry Definition: <class> $r[0] <type> $r[1] <varname> ", uc $r[2]," <decription> \"$r[9]\" <units> \"$r[10]\"\n"
	}
      }
    }
    close REGISTRY ;
    exit ;
}

$routfile = $dbdir."/".$rout ;
open ROUT, "< $routfile" or die "can not open $routfile" ;

$sourcefile = "" ;
$found_var = 0 ;
$nargs_rout = 0 ;
while ( <ROUT> )
{
  s/^  *// ;
  s/  */ /g ;
  @t = split ' ' ;
  if ( $t[0] eq "sourcefile" ) {
    $sourcefile = $t[1] ;
  } elsif ( $t[0] eq "arg" ) {
    $nargs_rout++ ;
    if ( $t[3] eq $vname && $t[9] ne "registry" ) {
      $argn = $t[1] ;
      print "  ",uc $vname," is dummy argument $argn of $rout ($sourcefile)\n"  ;
      $found_var = 1 ;
      close ROUT ;
      system( "sort -u $dbdir/calls > /tmp/wrfvar-sort ; /bin/mv /tmp/wrfvar-sort $dbdir/calls" ) ;
      open CALLERS, "< $dbdir/calls" ;
      $rout2 = $rout ;
      while ( <CALLERS> ) {
        @u = split ' ' ;
        if ( $u[2] eq $rout2 )
        {
	  $rout = $u[0] ;
          $routfile = $dbdir."/".$rout ;
 	  open ROUT, "< $routfile" or die "can not open $routfile" ;
          $sourcefile_caller = "" ;
          $callno = 1 ;
	  while ( <ROUT> ) {
            @v = split ' ' ;
            if ( $v[0] eq "sourcefile" ) {
              $sourcefile_caller = $v[1] ;
            } elsif ( $v[0] eq 'actarg' && $v[4] eq $rout2 && $v[1] eq $argn ) {
 	      print ucfirst $rout2," call $callno by $rout ($sourcefile_caller) with actual argument $argn: ",uc $v[6],"\n" ;
              $callno++ ;
	      $vname = $v[6] ;
              ############## RECURSION ##############
              @sysargs = ( "tools/wrfvar" , $v[6], $rout, $recursion_level+1 )  ;
              system( @sysargs ) ; 
	    }
          }
          close ( ROUT ) ;
        }
      }
      close ( CALLERS ) ;
    } elsif ( $t[3] eq $vname && $t[9] eq "registry" ) {
      @sysargs = ( "tools/wrfvar" , "grid%".$vname, "registry", $recursion_level+1 ) ;
      ############## RECURSION ##############
      system( @sysargs ) ; 
      $found_var = 1 ;
    }
  }
}

if ( $found_var == 0 ) {
  print uc $vname , " is not an argument to ${rout1}.  May be local or use-associated.\n" ;
  print ucfirst $rout1," has $nargs_rout arguments.\n" ;
  close ROUT ;
  open ROUT, "< $routfile" or die "can not open $routfile" ;
  while ( <ROUT> )
  {
    s/^  *// ;
    s/  */ /g ;
    @t = split ' ' ;
    if ( $t[0] eq "arg" ) {
      $i = $t[1] + 1 ;
      printf("%3d. ",$i) ;
      print uc $t[3]," of type ", uc $t[5],", intent ",uc $t[7],"\n" ;
    }
  }
  close ROUT ;
}

# get a list of the routines this guy calls 

if ( $recursion_level == 0 ) {
$first_time = 1 ;
open BBB, "< $dbdir/$rout1" or die " cannot open $dbdir/$rout1" ;
while ( <BBB> ) {
  @t = split ' ' ;
  if      ( $t[0] eq "$rout1" && $t[1] eq calls ) {
     $hamuna = $t[2] ;
  } elsif ( $t[0] eq "actarg" && $t[6] eq $vname1 ) {
     if ( $first_time == 1 ) {
       print "\n",uc $vname1," is an actual argument in calls to these routines from ",uc $rout1," :\n" ;
       $first_time = 0 ;
     }
     open ELEF,"< $dbdir/$hamuna" or die "cannot open $dbdir/$hamuna"  ;
     while ( <ELEF> ) {
       @u = split ' ' ;
       if ( $u[0] eq arg && $u[1] eq $t[1] ) {
	  $darg = $u[3] ;
	  $dintent = $u[7] ;
       }
     }
     close ELEF ;
     print "  ", $hamuna," (argument ",$t[1]+1," ; matching dummy arg is ",uc $darg," with intent ",uc $dintent,") \n" ;
  }
}
print "\n" ;
close BBB ;
}
exit ;

#endif