$!  PROMOTE_CMS.COM
$!
$!  Command file to promote files between two different CMS libraries.
$!
$!
$ bell[0,7] = %x07
$!
$ say :== write sys$output
$!
$ set noverify
$!
$!;;;;;;;;;;
$!  Clean up the working symbols
$!;;;;;;;;;;
$!
$ source_library = " "
$ dest_library = " "
$ fetch_remark = " "
$ insert_remark = " "
$ file_list = " "
$ continue_str = " "
$ original_dir = f$environment( "DEFAULT")
$ original_cms = f$trnlnm( "CMS$LIB")
$!
$!  Get parameters
$!
$ gosub prompt_source_library
$ gosub prompt_dest_library
$ gosub prompt_fetch_remark
$ gosub prompt_insert_remark
$ gosub prompt_file_list
$!
$!  One last chance to bail
$! 
$ gosub prompt_continue
$!
$ if continue_str .eqs. "N" then goto exit_program
$!
$ gosub create_promote_dir
$ gosub fetch_files
$ gosub insert_files
$!
$!;;;;;
$!  Don't leave user pointed at wrong cms
$!;;;;;
$ deassign cms$lib      
$!
$ if "''original_cms'" .nes. ""
$ then
$   cms set lib 'original_cms'
$ endif
$!
$ set def 'original_dir'
$!
$ goto exit_program
$!
$!;;;;;;;;;;
$!  Subroutine to prompt for the source library
$!;;;;;;;;;;
$prompt_source_library:
$   say " "
$   say " Please enter the source CMS library."
$   say " Use a device and directory path, not a single logical."
$   say " "
$   inquire source_library "Source Library "
$!
$   if f$length("''source_library'") .le. 1 then goto prompt_source_library
$!
$   source_library = f$edit( "''source_library'", "TRIM")
$!
$   if f$length( "''source_library'") .le. 1 then goto prompt_source_library
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine to prompt for the destination library
$!;;;;;;;;;;
$prompt_dest_library:
$   say " "
$   say " Please enter the destination CMS library."
$   say " Use a device and directory path, not a single logical."
$   say " "
$   inquire dest_library "Destination Library "
$!
$   if f$length("''dest_library'") .le. 1 then goto prompt_dest_library
$!
$   dest_library = f$edit( "''dest_library'", "TRIM")
$!
$   if f$length( "''dest_library'") .le. 1 then goto prompt_dest_library
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine to prompt for the fetch remark
$!;;;;;;;;;;
$prompt_fetch_remark:
$   say " "
$   say " Please enter the fetch comment"
$   say " Do not bother putting quotes on this comment"
$   say " This will be the comment used in the source library"
$   say " When fetching files for promotion"
$   say " "
$   inquire fetch_remark "Fetch Comment "
$!
$   if f$length("''fetch_remark'") .le. 1 then goto prompt_fetch_remark
$!
$   fetch_remark = f$edit( "''fetch_remark'", "TRIM")
$!
$   if f$length( "''fetch_remark'") .le. 1 then goto prompt_fetch_remark
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine to prompt for the insertion remark
$!;;;;;;;;;;
$prompt_insert_remark:
$   say " "
$   say " Please enter the insert comment"
$   say " Do not bother putting quotes on this comment"
$   say " This will be the comment used in the destination"
$   say " library when placing the files into that library"
$   say " "
$   inquire insert_remark "Insert Comment "
$!
$   if f$length("''insert_remark'") .le. 1 then goto prompt_insert_remark
$!
$   insert_remark = f$edit( "''insert_remark'", "TRIM")
$!
$   if f$length( "''insert_remark'") .le. 1 then goto prompt_insert_remark
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine to obtain the file list for promotion
$!;;;;;;;;;;
$prompt_file_list:
$   say " "
$   say " Please enter the file list to promote"
$   say " These must be either comma seperated files"
$   say " or a wild card list"
$   say " "
$   inquire file_list "File List "
$!
$   if f$length( "''file_list'") .le. 1 then goto prompt_file_list
$!
$   file_list = f$edit( "''file_list'", "TRIM")
$!
$   if f$length( "''file_list'") .le. 1 then goto prompt_file_list
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine 
$!;;;;;;;;;;
$prompt_continue:
$   say " "
$!
$   inquire continue_str "Do you wish to continue (Y/N) "
$!
$   if f$length( "''continue_str'") .le. 0  then goto prompt_continue
$!
$   continue_str = f$edit( "''continue_str'", "TRIM,UPCASE")
$!
$   if f$length( "''continue_str'") .le. 0  then goto prompt_continue
$!
$   if continue_str .eqs. "Y" then return
$   if continue_str .eqs. "N" then return
$!
$ goto prompt_continue
$!
$!;;;;;;;;;;
$!  Subroutine to create the promotion directory
$!;;;;;;;;;;
$create_promote_dir:
$   set noon
$   login_dir_str = f$trnlnm( "sys$login")
$   promote_dir_str = login_dir_str - "]" + ".promote_cms]"
$   create/dir 'promote_dir_str'
$!
$!  If we get an error above it is because the promotion directory
$!  already existed or the disk is full.  Let us hope the directory
$!  exists.
$!
$   set default 'promote_dir_str'
$!
$!  get rid of any files left over from some other promotion
$!
$   delete *.*;*
$!
$!  turn error processing back on
$!
$   set on
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine to fetch all of the files for promotion
$!;;;;;;;;;;
$fetch_files:
$   cms set lib 'source_library'
$   cms fetch 'file_list' "''fetch_remark'"
$!
$ return
$!
$!;;;;;;;;;;
$!  Subroutine to insert the files into the destination CMS library
$!  We must do this one file at a time since we will first try to 
$!  reserve the file and replace it.  If reserving the file fails
$!  we will create the element.
$!;;;;;;;;;;
$insert_files:
$   cms set lib 'dest_library'
$!
$   set noon
$   my_stream = 1
$!
$insert_files_loop_top:
$   the_file = f$search( "*.*", my_stream)
$!
$   if "''the_file'" .eqs. "" then goto insert_files_loop_exit
$!
$   start_sub = f$locate("]","''the_file'") + 1
$   end_sub = f$locate( ";","''the_file'")
$   str_len = end_sub - start_sub
$   the_file = f$extract( start_sub, str_len, "''the_file'")
$!
$   cms reserve/nooutput 'the_file' "''insert_remark'"
$   if .not. $STATUS
$   then
$       cms create element 'the_file' "''insert_remark'"
$   else
$       cms replace 'the_file' "''insert_remark'"
$   endif
$!
$   goto insert_files_loop_top
$!
$insert_files_loop_exit:
$   set on
$ return
$!
$exit_program:
$ exit