1 files changed, 113 insertions, 0 deletions
diff --git a/ipl/procs/openchk.icn b/ipl/procs/openchk.icn
new file mode 100644
index 0000000..0547638
--- /dev/null
+++ b/ipl/procs/openchk.icn
@@ -0,0 +1,113 @@
+############################################################################
+#
+#       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