;+
; NAME:
;   CMSAVEDIR
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Display a directory of the variables in an IDL SAVE file.
;
; CALLING SEQUENCE:
;   CMSAVEDIR, filename [, /VERBOSE, /QUIET, ... ]
;   
; DESCRIPTION: 
;
;   CMSAVEDIR will display a listing of the variables and other
;   objects stored in an IDL SAVE file.
;
;   For command-line users the primary function of CMSAVEDIR will be
;   to find out what data is stored in a file and when it was saved.
;   For that, they simply need to type: CMSAVEDIR, 'myfile.sav'
;
;   CMSAVEDIR also offers a number of features for programmers.
;   CMSAVEDIR essentially interrogates the save file and discovers the
;   numbers, names and types of each of the variables stored in the
;   file.  Programmers can use that information to decide whether or
;   how to open a file using the other routines in the CMSVLIB.
;   Various keyword parameters are used return this information, as
;   documented below.
;
; ==================================================================
;   Research Systems, Inc. has issued a separate license intended
;   to resolve any potential conflict between this software and the
;   IDL End User License Agreement. The text of that license
;   can be found in the file LICENSE.RSI, included with this
;   software library.
; ==================================================================
;
; COMPATIBILITY:
;
;   -- File Format --
;
;   CMSAVEDIR cannot examine compressed save files, or files larger
;   than 2 gigabytes.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; INPUTS:
;
;   FILENAME - a scalar string, the name of the file to be examined.
;
; KEYWORDS:
;
;   VERBOSE - if set, print more detailed information about the input file.
;
;   QUIET - if set, then do not print any output.  Programmers can use
;           this keyword to allow CMSAVEDIR to return information
;           about the file silently.
;
;   STATUS - upon output, 1 for success, otherwise to indicate
;            failure.
;   ERRMSG - upon output, if a failure occurs, a message describing
;            the error condition.
;  
;   N_VARIABLES - upon output, the number of variables in the file.
;   VAR_NAMES - upon output, contains a string array of the names of
;               the variables stored in the file.
;   TYPES - upon output, an 11xN_VARIABLES array containing the SIZE
;           information of each variable in the file.
;
;   N_PRO - upon output, the number of procedures stored in the file.
;   PRO_NAMES - upon output, the names of the procedures stored in the
;               file, as a string array.
;
;   N_FUNCTION - upon output, the number of functions stored in the
;                 file.
;   FUNC_NAMES - upon output, the names of the functions stored in the
;                file, as a string array.
;
;   NAMED_STRUCTS - upon output, a string array listing any named
;                   structures which appear in the SAVE file.
;   NAMED_CLASSES - upon output, a string array listing any named
;                   class structures which appear in the SAVE file.
;
;   TIMESTAMP - upon output, contains the timestamp record information
;               in a structure.  The fields of the structure are:
;                    SAVE_DATE - string - date saved
;                    SAVE_USER - string - user who saved file
;                    SAVE_HOST - string - host name on which file
;                                         saved
;
;   VERSION - upon output, contains the version record information in
;             a structure.  The fields of the structure are:
;                    FORMAT_VERSION - integer - major format version
;                    ARCH    - string - saving host's !VERSION.ARCH
;                    OS      - string - saving host's !VERSION.OS
;                    RELEASE - string - saving host's !VERSION.RELEASE
;
;   NOTICE - upon output, contains any textual notice included within
;            the file.  The fields of the structure are:
;                    TEXT - string - text of the notice
;
;   FORCE - if set, will force CMSAVEDIR to open the file even if it
;           detects a potential incompatibility.
;
; EXAMPLE:
;
;   IDL> cmsavedir, 'int_str_intarr.sav'
;   ** int_str_intarr.sav
;   ** Sun Apr  9 20:28:25 2000 (craigm@beach.gsfc.nasa.gov)
;   ** IDL v5.2 (linux)
;     A               INT       =        0
;     B               STRING    = 'hello'
;     C               INT       = Array[3]
;   ** 3 variable(s), 0 heap value(s) and 0 procedure(s) in 1376 bytes
;
; SEE ALSO:
;
;   CMRESTORE, CMSAVE, SAVE, RESTORE, CMSVLIB
;
; MODIFICATION HISTORY:
;   Documented, 12 Jan 2001, CM
;   Added USAGE message, 09 Jun 2001, CM
;   Fixed bug in printing common variables, 17 Mar 2002, CM
;   Added notification about RSI License, 13 May 2002, CM
;   Added NOTICE record type, 09 Jun 2003, CM
;   
;
; $Id: cmsavedir.pro,v 1.17 2003/06/28 22:21:07 craigm Exp $
;
;-
; Copyright (C) 2000-2002, 2003, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-

pro cmsavedir, filename, types=vtypes, force=force, status=status, $
               var_names=vnames, pro_names=pronames, func_names=funnames, $
               n_variables=nvar, n_pro=npro, n_function=nfunc, $
               errmsg=errmsg, verbose=all, read_heap=rheap, raw=raw, $
               timestamp=stamp, version=vers, quiet=quiet, $
               named_structs=structs, named_classes=classes, $
               notice=notice

  forward_function cmsv_rraw

  status = 0
  errmsg = ''

  if n_params() EQ 0 then begin
      message, 'USAGE: CMSAVEDIR, filename, ...', /info
      return
  endif

  catch, catcherr
  if catcherr EQ 0 then lib = cmsvlib(/query) else lib = 0
  catch, /cancel
  if lib EQ 0 then $
    message, 'ERROR: The CMSVLIB library must be in your IDL path.'

  ;; Open the file
  get_lun, unit
  cmsv_open, unit, filename(0), pp, status=status, errmsg=errmsg, $
    force=force, compressed=compressed
  if status NE 1 then begin
      free_lun, unit
      message, errmsg, /info
      return
  endif
  pp0 = pp

  ;; Initial set-up
  ;; promote64 is due to a format change in IDL 5.4
  ;; stamp is the timestamp structure
  ;; vers  is the version structure
  ;; firstvar is used to know when we hit the first variable so we can
  ;;          print the header of the display
  ;; rstamp and rvers are use to know when we have read the timestamp
  ;;        and version records.

  print_raw = keyword_set(raw)
  promote64 = 0 & opromote64 = 0
  stamp = {save_date: '', save_user: '', save_host: ''}
  vers  = {arch: '', os: '', release: '4.X', format_version: 0L}
  notice = {text: ''}
  firstvar = 1 & nvar = 0L & npro = 0L & nfunc = 0L & nheap = 0L
  rstamp = 0 & rvers = 0
  fs = fstat(unit)
  filesize = fs.size

  ;; Empty the NAMED_STRUCTS and NAMED_CLASSES keywords, so they can
  ;; be filled in fresh by CMSV_RVTYPE
  structs = 0 & dummy = temporary(structs)
  classes = 0 & dummy = temporary(classes)

  ;; Simple set-up for heap data
  ptr_index   = [0L]
  ptr_offsets = [0L]

  ;; Loop through the file reading records as we go.

  while status EQ 1 do begin
      ;; Read the next block, or at least the first 2 kB of it
      ;; This is OK since all scalar types will be smaller than that
      point_lun, unit, pp
      cmsv_rrec, block, p1, bdata, unit=unit, next_block=pnext, /init, $
        block_type=bt, block_name=bn, status=status, errmsg=errmsg, $
        promote64=promote64, compressed=compressed
      if status EQ 0 then goto, DONE

      if bn EQ 'END_MARKER' then goto, DONE

      ;; After any header blocks have been read, then print info
      if NOT keyword_set(quiet) AND firstvar $
        AND bn NE 'TIMESTAMP' AND bn NE 'VERSION' then begin
          print, '** '+filename(0)
          print, stamp.save_date, stamp.save_user, stamp.save_host, $
            format='("** ",A0," (",A0,"@",A0,")")'
          print, vers.release, vers.os, $
            format='("** IDL v",A0," (",A0,")")'
          firstvar = 0
      endif
      
      ;; We can't really decode the compressed block, but we can print
      ;; some information about it
      if compressed then goto, FAILED_BLOCK

      errmsg = ''
      ;; Check for each block type of interest.
      case bn of 

          ;; Timestamp record
          'TIMESTAMP': begin
              stamp = bdata
              if NOT keyword_set(all) then goto, NEXT_BLOCK
              rstamp = 1
              if NOT keyword_set(quiet) then begin
                  print, stamp.save_date, format='("    Date: ''",A0,"''")'
                  print, stamp.save_user, format='("Username: ''",A0,"''")'
                  print, stamp.save_host, format='("Hostname: ''",A0,"''")'
              endif
          end

          ;; Version record
          'VERSION': begin
              vers = bdata
              if NOT keyword_set(all) then goto, NEXT_BLOCK

              rvers = 1
              if NOT keyword_set(quiet) then begin
                  print, vers.arch,           format='("    Arch: ''",A0,"''")'
                  print, vers.os,             format='("      OS: ''",A0,"''")'
                  print, vers.release,        format='(" Release: ''",A0,"''")'
                  print, vers.format_version, format='("File Ver: ",I0)'
              endif
          end

          'IDENTIFICATION': begin
              ident = bdata
              if NOT keyword_set(all) then goto, NEXT_BLOCK
              
              print, ident.author,        format='("  Author: ''",A0,"''")'
              print, ident.title,         format='("   Title: ''",A0,"''")'
              print, ident.idcode,        format='(" ID Code: ''",A0,"''")'
          end

          'NOTICE': begin
              notice = bdata
              if keyword_set(all) then $
                print, '   - Record type '+strtrim(bt,2)+' ('+bn+')'
              print, strlen(notice.text), $
                format='("** NOTICE record: ",I0," chars (view with /VERBOSE)")'
              if keyword_set(all) then $
                print, notice.text
          end

          ;; Variable record.  This is the meat of the routine.  Some
          ;; other routines are routed here too, when they need to
          ;; print variable information.
          'VARIABLE': begin
              sysvar = 0
              DO_VARIABLE:
              tp1 = 0
              stname = 0 & dummy = temporary(stname)
              ;; Read name and type
              cmsv_rvtype, block, p1, varname, sz1, status=st1, template=val, $
                unit=unit, system=sysvar, errmsg=errmsg, /no_create, $
                structure_name=stname, $
                named_structs=structs, named_classes=classes
              if varname EQ '' OR st1 EQ 0 then goto, FAILED_BLOCK

              ;; Save the name and type information
              if nvar EQ 0 then vnames = [varname] $
              else vnames = [vnames, varname]
              if nvar EQ 0 then vtypes = ([sz1, lonarr(11)])(0:10) $
              else vtypes = [vtypes, ([sz1, lonarr(11)])(0:10)]
              nvar = nvar + 1

              ;; Read the data if needed
              type1 = sz1(sz1(0)+1)
              if sz1(0) EQ 0 AND type1 NE 11 then begin
                  if n_elements(val) GT 0 then tp1 = val
                  cmsv_rdata, block, p1, sz1, val, template=tp1, status=st1, $
                    unit=unit, errmsg=errmsg
                  if st1 EQ 0 then goto, NEXT_BLOCK
              endif 

              ;; Print the data
              hf = helpform(varname, val, size=sz1, width=78, $
                            structure_name=stname)
              if NOT keyword_set(quiet) then begin
                  print, '  '+hf, format='(A)'
              endif
          end

          ;; A system variable is recorded just like a variable.
          'SYSTEM_VARIABLE': begin
              sysvar = 1
              goto, DO_VARIABLE
          end

          ;; A common variable is printed but not counted
          'COMMON_BLOCK': begin
              names = bdata
              if n_elements(names) LE 1 then  goto, NEXT_BLOCK
              if NOT keyword_set(quiet) then begin
                  print, '  '+names(1:*)+' ('+names(0)+')', format='(A)'
              endif
              ;; nvar = nvar + n_elements(names) ; don't count common variables
          end

          ;; A compiled routine.  Just the simple stuff is restored
          ;; here since it seems to change a lot between versions.
          'COMPILED': begin

              proname = cmsv_rraw(/string, block, p1, status=st1, unit=unit)
              if st1 then prolength = cmsv_rraw(/long, block, p1, status=st1)
              if st1 then n_vars = cmsv_rraw(/long, block, p1, status=st1)
              if st1 then n_args = cmsv_rraw(/long, block, p1, status=st1)
              if st1 then flags = cmsv_rraw(/long, block, p1, status=st1)
              if st1 EQ 0 then goto, NEXT_BLOCK
              key = '' & extra = ''
              if (flags AND '01'xb) NE 0 then begin
                  type = 'FUNCTION' 
                  if nfunc EQ 0 then funnames = proname $
                  else funnames = [funnames, proname]
                  nfunc = nfunc + 1
              endif else begin
                  type = 'PRO'
                  if npro EQ 0 then pronames = proname $
                  else pronames = [pronames, proname]
                  npro = npro + 1
              endelse
              if (flags AND '02'xb) NE 0 then key  = ', KEYWORDS'
              if (flags AND '08'xb) NE 0 then extra = ', _EXTRA'
              if NOT keyword_set(quiet) then begin
                  print, type, proname, n_args, key, extra, $
                    format='("  ",A0," ",A0,", ",I0," args",A0,A0)'
              endif
          end

          ;; A heap header is really an index to following heap
          ;; variables, so that at a later time they can be restored.
          'HEAP_INDEX': begin
              if keyword_set(all) then $
                print, '   - Record type '+strtrim(bt,2)+' ('+bn+')'
              ii = bdata
              ptr_index   = [ptr_index, ii]
              ptr_offsets = [ptr_offsets, ii*0L]
          end

          ;; The heap data is stored here, unnamed.
          'HEAP_DATA': begin
              if keyword_set(all) then $
                print, '   - Record type '+strtrim(bt,2)+' ('+bn+')'
              p2 = p1
              cmsv_rvtype, block, p1, vindex, /heap, /no_create, unit=unit, $
                status=st1, errmsg=errmsg, $
                structure_name=stname, $
                named_structs=structs, named_classes=classes
              if st1 EQ 0 then goto, NEXT_BLOCK

              ;; VINDEX will be the heap variable number.  Once we
              ;; know this we can put the file offset into
              vindex = floor(vindex(0))
              wh = where(ptr_index EQ vindex, ct)
              if ct EQ 0 then goto, NEXT_BLOCK
              nheap = nheap + 1
              ptr_offsets(wh(0)) = pp + p2
          end

          ;; What to do in the generic case
          else: begin
              FAILED_BLOCK:
              if compressed then compstr = '  (compressed)' else compstr = ''
              if keyword_set(all) OR bn EQ 'UNKNOWN' then $
                print, '   - Record type '+strtrim(bt,2)+' ('+bn+')'+compstr
              if keyword_set(all) AND bn EQ 'UNKNOWN' then print_raw = 1
          end
      endcase

      NEXT_BLOCK:
      ;; Some final extremely verbose output for every block, if
      ;; requested.
      if print_raw then begin
          point_lun, unit, pp
          cmsv_rrec, block, p1, unit=unit, /init, /full, $
            status=status, errmsg=errmsg, offset=pp, $
            promote64=opromote64, compressed=compressed
          if status EQ 1 then begin
              print, '     (binary data)'
              binaryform_long, block
          endif
      endif

      if NOT keyword_set(raw) then print_raw = 0
      if errmsg NE '' then message, errmsg, /info

      ;; Now advance to the next record.
      if pnext EQ 0 then begin
          message, 'WARNING: premature termination of '+filename(0), /info
          goto, DONE
      endif
      if pp NE pnext then begin
          pp = pnext 
      endif else begin
          status = 0
          errmsg = 'ERROR: internal inconsistency'
      endelse

      opromote64 = promote64
  endwhile
  DONE:
  if status EQ 0 then message, errmsg, /info 

  ;; Final statistics
  if nvar GT 0 then vtypes = reform(vtypes, 11, nvar, /overwrite)

  if NOT keyword_set(quiet) then $
    print, nvar, nheap, npro+nfunc, filesize, $
    format=('("** ",I0," variable(s), ",I0," heap value(s) and ",' + $
            'I0," procedure(s) in ",I0," bytes")')

  free_lun, unit
  return
end