############################################################################
#
#       File:     openchk.icn
#
#       Subject:  Procedure to aid in open/close debugging
#
#       Author:   David A. Gamey
#
#       Date:     March 14, 1995
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  Usage:
#  
#     OpenCheck()
#
#  Subsequent opens and closes will write diagnostic information to &errout
#  Useful for diagnosing situations where many files are opened and closed 
#  and there is a possibility that some files are not always being closed.
#
#############################################################################

procedure OpenCheck(p,x)

local    f, e
static   openS

if type(p) == "procedure" then
{
   #  Internal use, by intercept routines

   if /openS then
   {
      write(&errout,"OpenCheck has not been initialized.")
      runerr(500)
   }

   case p of 
   {
      OpenCheck_open :  
      {
         if ( f := p!x ) then 
         {
            write( &errout, "Open of ", image(f), " succeeded." )
            insert( openS, f )
         }
         else 
         {
            writes( &errout, "Open of ")
            every writes( &errout, image(!x) )
            write( &errout, " failed." )
         }
      }

      OpenCheck_close:  
      {
         e := 1
         &error :=: e
         if ( f := p!x ) then 
         {  
            &error :=: e
            write( &errout, "Close of ", image(f), " succeeded." )
            delete( openS, f )
         }
         else 
         {
            &error :=: e
            write( &errout, "Close of ", image(f), " failed." )
         }
      }

      default:
         runerr(500)
   }
   
   write( &errout, *openS, " objects are open:" )
   every write( &errout, "   ", image(!sort( openS )) )
   
   if type(f) == "file" then 
      return f
   else
   {
      runerr(&errornumber,&errorvalue)    # if error
      fail
   }
}
else
{
   #  Setup call comes here

   if /p & /x then   
      if /openS := set() then
      {
         OpenCheck_open  :=: open
         OpenCheck_close :=: close
      }
   else
      runerr(123, \p | \x )
}
return
end

procedure OpenCheck_open( x[] )
return OpenCheck(OpenCheck_open,x)
end 

procedure OpenCheck_close( x[] )
return OpenCheck(OpenCheck_close,x)
end