Caché システムのカスタマイズ

 Set fmt = ##class(%SYS.NLS.Format).%New("jpnw")

  Set Info = ##class(%SYS.NLS.Locale).%New()
  Set Items = "Name" _
              "/Description" _
              "/Country" _
              "/CountryAbbr" _
              "/Language" _
              "/LanguageAbbr" _
              "/Currency" _
              "/CharacterSet"
  
  Write !
  For i = 1 : 1 : $LENGTH(Items, "/")
  {
    Set Item = $PIECE(Items, "/", i)
    Write $JUSTIFY(Item, 15),": ", $PROPERTY(Info, Item), !
  }

  Znspace "%SYS"
  Set locales = ##class(%Library.ResultSet).%New("Config.NLS.Locales:List")
  If $IsObject(locales) {
    Set locales.RuntimeMode = 1
    Set sc = locales.Execute("*")
    If $SYSTEM.Status.IsOK(sc) {
      Write !
      While locales.Next() {
        Write locales.Data("Name"), " - ", locales.Data("Description"), !
      }
    }
  }

  Set IOTables = "Process" _
                 "/CacheTerminal" _
                 "/OtherTerminal" _
                 "/File" _
                 "/Magtape" _
                 "/TCPIP" _
                 "/DSMDDP" _
                 "/DTMDCP" _
                 "/SystemCall" _
                 "/Printer"
  Set IntTables = "PatternMatch" _
                  "/Identifier" _
                  "/Uppercase" _
                  "/Lowercase" _
                  "/Titlecase" _
                  "/Collation" _
                  "/XYAction"
  
  // iterate over the systems, and then the process data
  For Type = "System", "Process"
  {
    Write !
    Set Table = ##class(%SYS.NLS.Table).%New(Type)
    Write "Type: ", Type, !
    
    Write "I/O Tables", !
    For i = 1 : 1 : $LENGTH(IOTables, "/")
    {
      Set PropName = $PIECE(IOTables, "/", i)
      Write $JUSTIFY(PropName, 15), ": ", $PROPERTY(Table, PropName), !
    }
    
    Write "Internal Tables", !
    For i = 1 : 1 : $LENGTH(IntTables, "/")
    {
      Set PropName = $PIECE(IntTables, "/", i)
      Write $JUSTIFY(PropName, 15), ": ", $PROPERTY(Table, PropName), !
    }
  }

  // display the current defaults
  // date is 10 April 2005
  // time is 6 minutes 40 seconds after 11 in the morning
  Write $ZDATE("60000,40000"), !
  
  // now change the separators and display it again
  Set fmt = ##class(%SYS.NLS.Format).%New()
  Set fmt.DateSeparator = "_"
  Set fmt.TimeSeparator = "^"
  Write !, $ZDATE("60000,40000")

  // get the format class instance
  Set fmt = ##class(%SYS.NLS.Format).%New()
  
  // define the month names
  Set Names = " AAA BBB CCC DDD EEE FFF GGG HHH III JJJ KKK LLL"
  Set fmt.MonthAbbr = Names
  Set rtn = ##class(%SYS.NLS.Format).SetFormatItem("DATEFORMAT", 2) 
  
  // show the result
  Write $ZDATE(60000, 2)

  // give the baseline display
  Write $Number("123,456.78"), !
  
  Set fmt = ##class(%SYS.NLS.Format).%New()
  // use "/" for groups of digits
  Set fmt.NumericGroupSeparator = "."
  
  // group digits in blocks of 4
  Set fmt.NumericGroupSize = 4
  
  // use ":" for separating integer and fractional parts
  Set fmt.DecimalSeparator = ","
  
  // try interpreting again
  Write $Number("12.3456,78"), !

  // show the process default translation (RAW, no translation performed)
  Set Tbl = ##class(%SYS.NLS.Table).%New("Process")
  Write "Process default translation: ", Tbl.File, !
  
  // create and open a temporary file
  // use XML for the translation
  Set TempName = ##class(%Library.File).TempFilename("log")
  Set TempFile = ##class(%Library.File).%New(TempName)
  Do TempFile.Open("WSNK\XML\")
  Write "Temp file: ", TempFile.CanonicalNameGet(), !
  
  // write a few characters to show the translation
  // then close it
  Do TempFile.WriteLine(("--" _ $CHAR(38) _ "--"))
  Do TempFile.Close()
  
  // now re-open it in raw mode and show content
  Do TempFile.Open("RSK\RAW\")
  Do TempFile.Rewind()
  Set MaxChars = 50
  Set Line = TempFile.Read(.MaxChars)
  Write "Contents: """, Line, """", !
  
  // finish
  Do TempFile.Close()
  Do ##class(%Library.File).Delete(TempName)
  Set TempFile = "" 

  // use the query in Config.NLS to get the locales
  ZNspace "%SYS"
  Set Query = ##class(%Library.ResultSet).%New("Config.NLS.Locales:List")
  Set code = Query.Execute("*")
  If (##class(%SYSTEM.Status).IsError(code))
  {
    Do ##class(%SYSTEM.Status).DisplayError(Code)
    Quit
  }
  
  // display each of them in turn
  Write "Available locales and descriptions", !
  While (Query.Next(.code))
  {
    If (##class(%SYSTEM.Status).IsError(code))
    {
      Do ##class(%SYSTEM.Status).DisplayError(Code)
      Quit
    }
    Write Query.Get("Name"), ": ", Query.Get("Description"), !
  }

  ZNspace "%SYS"
  
  // establish the locale identifier, try
  // United States - English - Unicode
  // United States - English - 8-bit
  Set Loc = "enuw"
  Do ##class(Config.NLS.Locales).Exists(Loc, .Ref, .Code)
  If (##class(%SYSTEM.Status).IsError(Code))
  {
    Set Loc = "enu8"
    Do ##class(Config.NLS.Locales).Exists(Loc, .Ref, .Code)
    If (##class(%SYSTEM.Status).IsError(Code))
    {
      Do ##class(%SYSTEM.Status).DisplayError(Code)
      Quit
    }
  }
  
  // get the local array of table names
  Write "Tables for locale: ", Loc, !
  Do Ref.GetTables(.Tables)
  Set Type = $ORDER(Tables(""))
  While (Type '= "")
  {
    Set Name = $ORDER(Tables(Type, ""))
    While (Name '= "")
    {
      Set Mod = $ORDER(Tables(Type, Name, ""))
      While (Mod '= "")
      {
        Write Type, " - ", Name, " - ", Mod, !
        Set Mod = $ORDER(Tables(Type, Name, Mod))
      }
      Set Name = $ORDER(Tables(Type, Name))
    }
    Set Type = $ORDER(Tables(Type))
  }

  // Names for the new SubTables (save for later)
  Set nam1 = "XLT-Latin1-yEBCDIC"
  Set nam2 = "XLT-yEBCDIC-Latin1"

  // Delete existing SubTables instances with same ids
  Do ##class(Config.NLS.SubTables).Delete(nam1)
  Do ##class(Config.NLS.SubTables).Delete(nam2)

  // Create two SubTable objects
  Set sub1 = ##class(Config.NLS.SubTables).%New()
  Set sub2 = ##class(Config.NLS.SubTables).%New()

  // Set Name and Description
  Set sub1.Name = nam1
  Set sub1.Description = "ICU Latin-1->EBCDIC sub-table"
  Set sub2.Name = nam2
  Set sub2.Description = "ICU EBCDIC ->Latin-1 sub-table"

  // Set Type (single-to-single)
  Set sub1.Type = 0
  Set sub2.Type = 0
  
  // Initialize FromTo arrays
  For i = 0 : 1 : 255
  {
    Do sub1.FromTo.SetAt(i, i)
    Do sub2.FromTo.SetAt(i, i)
  }

  // Assume file is in the mgr directory
  Set file = "glibc-EBCDIC_US-2.1.2.ucm"

  // Set EOF exit trap
  Set $ZTRAP = "EOF"
  
  // Make that file the default device
  Open file
  Use file
  For
  {
    Read x
    If x?1"<U"4AN1">".E
    {
      Set uni = $ZHEX($E(x,3,6)),ebcdic = $ZHEX($E(x,12,13))
      Do sub1.FromTo.SetAt(ebcdic,uni)
      Do sub2.FromTo.SetAt(uni,ebcdic)
     }
  }

EOF  // No further data
  Set $ZT = ""
  Close file

  // Save SubTable objects
  Do sub1.%Save()
  Do sub2.%Save()

  // Delete existing Tables instances with same ids
  Do ##class(Config.NLS.SubTables).Delete("XLT", "Latin1", "yEBCDIC")
  Do ##class(Config.NLS.SubTables).Delete("XLT", "yEBCDIC", "Latin1")

  // Create two Table objects
  Set tab1 = ##class(Config.NLS.Tables).%New()
  Set tab2 = ##class(Config.NLS.Tables).%New()

  // Set description
  Set tab1.Description = "ICU loaded Latin-1 -> EBCDIC table"
  Set tab2.Description = "ICU generated EBCDIC -> Latin-1 table"

  // Set From/To encodings
  Set tab1.NameFrom = "Latin1"
  Set tab1.NameTo = "yEBCDIC"
  Set tab2.NameFrom = "yEBCDIC"
  Set tab2.NameTo = "Latin1"

  // Set SubTable
  Set tab1.SubTableName = nam1
  Set tab2.SubTableName = nam2

  // Set Type
  Set tab1.Type = "XLT"
  Set tab2.Type = "XLT"

  // Set Default Action
  // 1 = Replace with replacement value
  Set tab1.XLTDefaultAction = 1
  Set tab2.XLTDefaultAction = 1

  // Set Replacement value of "?"
  Set tab1.XLTReplacementValue = $ASCII("?")
  Set tab2.XLTReplacementValue = $ASCII("?")

  // Set Reversibility
  // 1 = Reversible
  // 2 = Generated
  Set tab1.XLTReversibility = 1
  Set tab2.XLTReversibility = 2

  // Set Translation Type
  // 0 = non-modal to non-modal
  Set tab1.XLTType = 0
  Set tab2.XLTType = 0

  // Save Table objects
  Do tab1.%Save()
  Do tab2.%Save()

  // Delete existing Locales instance with the same id
  Do ##class(Config.NLS.Locales).Delete("yen8")
  
  // Open source locale
  Set oldloc = ##class(Config.NLS.Locales).%OpenId("enu8")
  
  // Create clone
  Set newloc = oldloc.%ConstructClone()
  
  // Set new Name and Description
  Set newloc.Name = "yen8"
  Set newloc.Description = "New locale with EBCDIC table"

  // Add new table to locale
  Set component = $LISTBUILD("yEBCDIC", "Latin1", "Latin1", "yEBCDIC")
  Do newloc.XLTTables.SetAt(component, "EBCDIC")

  // Set default for Magnetic Tapes
  Set newloc.TranMagTape = "EBCDIC"
  
  // Save the changes
  Do newloc.%Save()

  // Check locale consistency
  If '##class(Config.NLS.Locales).IsValid("yen8", .Errors, .Warns)
  {
    Write !,"Errors: "
    ZWrite Errors
    Write !,"Warnings: "
    ZWrite Warns
    Quit
  }
  
  // Compile new locale
  Set status = ##class(Config.NLS.Locales).Compile("yen8")
  If (##class(%SYSTEM.Status).IsError(status))
  {
    Do $System.OBJ.DisplayError(status)
  }
  Else 
  { 
    Write !,"Locale yen8 successfully created."
  }

%ZSSUtil ;
    ; this routine packages a set of subroutines 
    ; used by the %ZSTART and %ZSTOP entry points
    ; 
    ; does not do anything if invoked directly
    quit
    
#Define Empty ""
#Define OprLog 1
    
WriteConsole(LineText) PUBLIC ;
    ; write the line to the console log
    ; by default the file cconsole.log in the MGR directory
    new SaveIO
    
    ; save the current device and open the operator console
    ; set up error handling to cope with errors
    ; there is little to do if an error happens
    set SaveIO = $IO
    set $ZTRAP = "WriteConsoleExit"
    open $$$OprLog
    use $$$OprLog
    ; we do not need an "!" for line termination
    ; because each WRITE statement becomes its 
    ; own console record (implicit end of line)
    write LineText
    ; restore the previous io device
    close $$$OprLog
    ; pick up here in case of an error
WriteConsoleExit ;
    set $ZTRAP = ""
    use SaveIO
    quit
    
WriteLog(rtnname, entryname, items) PUBLIC ;
    ; write entries into the log file
    ; the log is presumed to be open as 
    ; the default output device
    ; 
    ; rtnname: distinguishes between ZSTART & ZSTOP
    ; entryname: the name of the entry point we came from
    ; items: a $LIST of name-value pairs
    new ThisIO, ThisLog
    new i, DataString
    
    ; preserve the existing $IO device reference
    ; set up error handling to cope with errors
    ; there is little to do if an error happens
    set ThisIO = $IO
    set $ZTRAP = "WriteLogExit"

    ; construct the name of the file
    ; use the month and day as part of the name so that 
    ; it will create a separate log file each day
    set ThisLog = "ZSS"
                _ "-"
                _ $EXTRACT($ZDATE($HOROLOG, 3), 6, 10)
                _".log"
    
    ; and change $IO to point to our file
    open ThisLog:"AWS":0
    use ThisLog
    
    ; now loop over the items writing one line per item pair
    for i = 1 : 2 : $LISTLENGTH(items)
    {
        set DataString = $LISTGET(items, i, "*MISSING*")
        if ($LISTGET(items, (i + 1), $$$Empty) '= $$$Empty)
        {
            set DataString = DataString
                           _ ": "
                           _ $LISTGET(items, (i + 1))
        }
        write $ZDATETIME($HOROLOG, 3, 1),
              ?21, rtnname,
              ?28, entryname,
              ?35, DataString, !
    }
    
    ; stop using the log file and switch $IO back
    ; to the value saved on entry
    close $IO
    ; pick up here in case of an error
WriteLogExit ;
    set $ZTRAP = ""
    use ThisIO
    quit

%ZSTART ; User startup routine. 
 
#Define ME "ZSTART"
#Define BgnSet "Start"
#Define Empty ""

    ; cannot be invoked directly
    quit
 
SYSTEM ;
    ; Cache starting
    new EntryPoint, Items
     
     set EntryPoint = "SYSTEM"
    
     ; record the fact we got started in the console log
     do WriteConsole^%ZSSUtil((EntryPoint
                               _ "^%"
                               _ $$$ME
                               _ " called @ "
                               _ $ZDATETIME($HOROLOG, 3)))
    
    ; log the data accumulate results
     set Items = $LISTBUILD($$$BgnSet, $ZDATETIME($HOROLOG, 3),
                           "Job", $JOB,
                           "Computer", $ZUTIL(110),
                           "Version", $ZVERSION,
                           "StdIO", $PRINCIPAL,
                           "Namespace", $ZUTIL(5),
                           "CurDirPath", $ZUTIL(12),
                           "CurNSPath", $ZUTIL(12, ""),
                           "CurDevName", $ZUTIL(67, 7, $JOB),
                           "JobType", $ZUTIL(67, 10, $JOB),
                           "JobStatus", $ZHEX($ZJOB),
                           "StackFrames", $STACK,
                           "AvailStorage", $STORAGE,
                           "UserName", $ZUTIL(67, 11, $JOB))
    do WriteLog^%ZSSUtil($$$ME, EntryPoint, Items)
    
    quit

LOGIN ;
    ; a user logs into Cache
    new EntryPoint, Items
    
    set EntryPoint = "LOGIN"
     set Items = $LISTBUILD($$$BgnSet, $ZDATETIME($HOROLOG, 3))
    do WriteLog^%ZSSUtil($$$ME, EntryPoint, Items)
    quit
    
JOB ;
    ; JOB'd process begins
    new EntryPoint, Items
    
     set EntryPoint = "JOB"
     set Items = $LISTBUILD($$$BgnSet, $ZDATETIME($HOROLOG, 3))
    do WriteLog^%ZSSUtil($$$ME, EntryPoint, Items)
    quit
     
CALLIN ;
    ; a process enters via CALLIN interface
    new EntryPoint, Items
    
     set EntryPoint = "CALLIN"
     set Items = $LISTBUILD($$$BgnSet, $ZDATETIME($HOROLOG, 3))
    do WriteLog^%ZSSUtil($$$ME, EntryPoint, Items)
    quit

%ZSTOP ; User shutdown routine. 
 
#Define ME "ZSTOP"
#Define EndSet "End"
#Define Empty ""

    ; cannot be invoked directly
    quit
 
SYSTEM ; Cache stopping
    new EntryPoint
    
    set EntryPoint = "SYSTEM"
    ; record termination in the console log
    do WriteConsole^%ZSSUtil((EntryPoint
        _ "^%"
        _ $$$ME
        _ " called @ "
        _ $ZDATETIME($HOROLOG, 3)))
    ; write the standard log information
    do Logit(EntryPoint, $$$ME)
    quit
    
LOGIN ; a user logs out of Cache
    new EntryPoint
    
    set EntryPoint = "LOGIN"
    do Logit(EntryPoint, $$$ME)
    quit
    
JOB ; JOB'd process exits. 
    new EntryPoint
    
    set EntryPoint = "JOB"
    do Logit(EntryPoint, $$$ME)
    quit
     
CALLIN ; process exits via CALLIN interface. 
    new EntryPoint
    
    set EntryPoint = "CALLIN"
    do Logit(EntryPoint, $$$ME)
    quit
    
Logit(entrypoint, caller) PRIVATE ;
    ; common logging for exits
    
    new items
    
    set items = $LISTBUILD($$$EndSet, $ZDATETIME($HOROLOG, 3))
    do WriteLog^%ZSSUtil(caller, entrypoint, items)
    quit