* CREATEA
* CREATE.ACCOUNT verb
* Copyright (c) 2007 Ladybridge Systems, All Rights Reserved
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
* 
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
* GNU General Public License for more details.
* 
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software Foundation,
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
* 
* Ladybridge Systems can be contacted via the www.openqm.com web site.
* 
* START-HISTORY:
* 09 Oct 07  2.6-5 Resequenced pathname checks to work around problem with
*                  OS$FULLPATH.
* 03 Oct 07  2.6-5 If creating account on the flash device holding the QMSYS
*                  account, use @DRIVE for portability.
* 21 Aug 07  2.6-0 Create $COMMAND.STACK by default.
* 02 Nov 06  2.4-15 VOC record types are now case insensitive.
* 13 Apr 06  2.4-1 Relaxed account name rules.
* 28 Jul 05  2.2-6 Allow for pre-existing cat subdirectory for use in
*                  automated install processes.
* 27 May 05  2.2-0 Added $ACCOUNT.ROOT.DIR handling.
* 28 Oct 04  2.0-8 0275 Should check existance of account name entered on the
*                  command line before prompting for the pathname.
* 13 Oct 04  2.0-5 Use message handler.
* 16 Sep 04  2.0-1 OpenQM launch. Earlier history details suppressed.
* END-HISTORY
*
* START-DESCRIPTION:
*
* CREATE.ACCOUNT account.name  path.name [NO.QUERY]
*
* END-DESCRIPTION
*
* START-CODE

$internal
program $create.account
$catalog $CREATEA

$include keys.h
$include int$keys.h
$include parser.h
$include err.h

   prompt ''

   parser = "!PARSER"
   no.query = @false
   windows = system(91)

   @system.return.code = -ER$ARGS     ;* Preset for argument errors


   openpath @qmsys:@ds:'ACCOUNTS' to acc.f else
      @system.return.code = -status()
      stop sysmsg(6000) ;* Cannot open ACCOUNTS file in QMSYS account
   end


   call @parser(PARSER$RESET, 0, @sentence, 0)
   call @parser(PARSER$GET.TOKEN, token.type, token, keyword) ;* Verb

   * Get and process account name

   call @parser(PARSER$GET.TOKEN, token.type, acc.name, keyword)
   if token.type = PARSER$END then
      display sysmsg(6001) :  ;* Account name:
      input acc.name
      acc.name = upcase(trim(acc.name))
      if acc.name = '' then stop
   end

   * Check if already exists in ACCOUNTS file.  We will need to do this
   * again when we are ready to create the account but doing it here
   * saves the user typing the path name before we spot the error.

   read acc.rec from acc.f, acc.name then      ;* 0275
      @system.return.code = -ER$ACC.EXISTS
      stop sysmsg(6002) ;* Account already exists
   end

   * Validate account name

   acc.name = upcase(acc.name)

   if len(acc.name) > 32 or not(alpha(acc.name[1,1])) or index(acc.name, ' ', 1) then
      stop sysmsg(6003) ;* Account name is invalid
   end

   * Get and process pathname

   call @parser(parser$get.token, token.type, pathname, keyword)
   if token.type = PARSER$END then
      dflt.dir = ''
      openpath @qmsys:@ds:'VOC' to qmsys.voc then
         read voc.rec from qmsys.voc, '$ACCOUNT.ROOT.DIR' then
            if upcase(voc.rec[1,1]) = 'X' then
               dflt.dir = voc.rec<2>
               if dflt.dir[1] # @ds then dflt.dir := @ds
               dflt.dir := acc.name
            end
         end
         close qmsys.voc
      end

      if dflt.dir # '' then
         display sysmsg(6034, dflt.dir) :  ;* Pathname:
      end else
         display sysmsg(6004) :  ;* Pathname:
      end
      input pathname
      if pathname = '' then pathname = dflt.dir
      pathname = trim(pathname)
   end

   * Validate pathname

   if windows then pathname = upcase(pathname)
   if not(ospath(pathname, OS$PATHNAME)) then
      stop sysmsg(6005) ;* Invalid account pathname
   end

   * Check for further command arguments

   loop
      call @parser(parser$get.token, token.type, token, keyword)
   until token.type = PARSER$END
      begin case
         case keyword = KW$NO.QUERY
            no.query = @true

         case 1
            stop sysmsg(2018, token) ;* Unexpected token (xx)
      end case
   repeat

   * Check if already exists in ACCOUNTS file

   readu acc.rec from acc.f, acc.name locked
      stop sysmsg(6006, status()) ;* ACCOUNTS record is locked by user xx
   end then
      @system.return.code = -ER$ACC.EXISTS
      stop sysmsg(6002) ;* Account already exists
   end

   * Check parent directory exists

   if index(pathname, @ds, 1) then
      parent.dir = field(pathname, @ds, 1, dcount(pathname, @ds) - 1)
      if parent.dir # '' and not(parent.dir matches "1A':") then
         if not(ospath(parent.dir, OS$EXISTS)) then
            @system.return.code = -ER$NO.DIR
            stop sysmsg(6008) ;* Parent directory does not exist
         end
      end
   end

   pathname = ospath(pathname, OS$FULLPATH)
   if windows then pathname = upcase(pathname)

   * Check if account directory exists

   if ospath(pathname, OS$EXISTS) then
      * Check for presence of a VOC file
      openpath pathname:@ds:'VOC' to voc.f then
         if not(no.query) then
            display sysmsg(6009) ;* Directory already contains a VOC file
            loop
               display sysmsg(6010) :  ;* Add to ACCOUNTS register (Y/N)?
               input yn
               yn = upcase(yn)
               if yn = 'N' then
                  @system.return.code = -ER$STOPPED
                  stop sysmsg(6011) ;* Account not created
               end
            until yn = 'Y'
            repeat
         end
      end else
         gosub make.account
      end
   end else
      if not(no.query) then
         loop
            display sysmsg(6012) :  ;* Create new directory for account (Y/N)?
            input yn
            yn = upcase(yn)
            if yn = 'N' then
               @system.return.code = -ER$STOPPED
               stop sysmsg(6011) ;* Account not created
            end
         until yn = 'Y'
         repeat
      end

      create.file pathname directory on error
         @system.return.code = -ER$NOT.CREATED
         stop sysmsg(6013) ;* Unable to create account directory
      end

      gosub make.account
   end

   * Add ACCOUNTS entry

   display sysmsg(6014) ;* Adding to register of accounts...

   if windows then
      if bitand(kernel(K$COMMAND.OPTIONS, 0), CMD.FLASH) then
         if pathname[2,1] = ':' and @qmsys[1,2] = pathname[1,2] then
            * On flash drive - replace drive letter with @DRIVE
            pathname = '@DRIVE':pathname[2,9999]
         end
      end
   end

   acc.rec = ''
   acc.rec<ACC$PATH> = pathname
   write acc.rec to acc.f, acc.name
   close acc.f

   @system.return.code = 0
   return

* ======================================================================

make.account:
   * Set up VOC

   display sysmsg(6015) ;* Creating VOC...

   create.file pathname:@ds:'VOC' dynamic on error
      @system.return.code = -6
      stop sysmsg(6016) ;* Unable to create VOC
   end

   openpath pathname:@ds:'VOC' to voc.f else
      @system.return.code = -status()
      stop sysmsg(6017) ;* Unable to open new VOC
   end

   openpath @qmsys:@ds:"NEWVOC" to newvoc.f else
      @system.return.code = -status()
      stop sysmsg(6018) ;* Cannot open QMSYS NEWVOC
   end

   select newvoc.f to 11
   loop
      readnext id from 11 else exit

      read rec from newvoc.f, id then
         rec<1> = if upcase(rec[1,1]) = 'P' then rec<1>[1,2] else rec[1,1]

         if upcase(rec<1>) = 'K' and rec<3> # '' then   ;* Keyword with other use
            s = rec<3>
            rec<3> = if upcase(s[1,1]) = 'P' then s<1>[1,2] else s[1,1]
         end

         write rec to voc.f, id
      end
   repeat

   close newvoc.f

   * Set up $COMMAND,STACK VOC entry

   write 'X' to voc.f, '$COMMAND.STACK'

   * Create $HOLD

   fn = '$HOLD'
   os.name = '$HOLD'
   descr = 'File for deferred prints'
   dict = @true
   gosub create.dir.file


   * Create $SAVEDLISTS

   fn = '$SAVEDLISTS'
   os.name = '$SVLISTS'
   descr = 'File for saved select lists'
   dict = @false
   gosub create.dir.file


   * Create private catalogue

   display sysmsg(6019) ;* Creating private catalogue directory..."

   s = pathname:@ds:'cat'
   if not(ospath(s, OS$EXISTS)) then
      create.file s directory on error
         @system.return.code = -ER$NOT.CREATED
         stop sysmsg(6020) ;* Unable to create private catalogue directory
      end
   end

   return

* ======================================================================

create.dir.file:
   display sysmsg(6021, fn) ;* Creating xx...

   create.file pathname:@ds:os.name directory on error
      @system.return.code = -ER$NOT.CREATED
      stop sysmsg(6022, fn) ;* Unable to create data part of xx
   end

   begin case
      case descr[1,1]= 'F'       ; voc.rec = descr
      case descr # ''            ; voc.rec = 'F ' : descr
      case 1                     ; voc.rec = 'F'
   end case

   voc.rec<2> = os.name

   if dict then
      create.file pathname:@ds:os.name:'.DIC' dynamic on error
         @system.return.code = -ER$NOT.CREATED
         stop sysmsg(6023, fn) ;* Unable to create dictionary part of xx
      end

      openpath pathname:@ds:os.name:'.DIC' to dict.f else
         @system.return.code = -status()
         stop sysmsg(6024, fn) ;* Unable to open dictionary part of xx
      end

      write raise('D0':fn:'10LS') to dict.f, '@ID'
      close dict.f

      voc.rec<3> = os.name:'.DIC'
   end

   write voc.rec to voc.f, fn

   return
end

* END-CODE
