#!/usr/bin/perl

# T. Litt March 2016
# Copyright (C) 2016 Timothe Litt
#
# Input from unmessage of VMS VAX message files, generated by
# ftp://ftp.decuserve.org/decus/vms/sig_tapes/vax88b1/meadows/unmessage/unmessage.exe
#
# Because these don't include the message severity (well, they
# do, but they're all 0 ("warning"), we also take a concatenated
# .h file of all the random definition files we can find.
# These are parsed for #defines that look interesting, and those
# are used to correct the severity code.
# The .h file must come first to have any effect.
#
# message vms_msgdefs.h ods2.msg vms_msgdump.msg ssdef.h
#
# Also include the message file for ODS2 itself, as that simplifes
# generating its message catalog.
#
# Currently, the useful VMS messages have been reconstructed into
# vms_messages.msg (by this utility); that file + ods2.msg are the
# only files necessary to rebuild the english language version of
# ODS2. The long procedure (documented in the output file) is only
# useful if you  need to refresh the VMS-sourced messages, e.g.
# for an I18n translation.

our $VERSION = 0.1;

use warnings;
use strict;

use File::Copy qw(move);

use Getopt::Std;
$Getopt::Std::STANDARD_HELP_VERSION = 1;

# Facilities of interest

my %wanted = map { $_ => 1} (qw/DISM$ INIT$ MOUNT$ RMS$ SHR$ SS$ SYSTEM$/,
                             qw/COPY CREATE DELETE DIFF DIRECT DISM EXTEND/,
                             qw/HELP INIT IO MOUNT ODS2 RENAME SEARCH SHR TYPE/);
# Symbols NOT of interest
# These are known to have no text message for various reasons.

my %ign = map { $_ => 1 } (
    qw/SS$_CONTINUE SS$_WASCLR SS$_WASSET/,                       # Overlaid codes
    qw/SS$_NOPRIVSTRT SS$_NOPRIVEND SS$_EXQUOTASTRT SS$_EXQUOTAEND/,
    qw/SS$_SYSAPMAX SS$_SYSAPMIN/                                 # Range markers
);

our( $opt_b, $opt_h, $opt_m, $opt_q, $opt_t );

my $argv = join( ' ', @ARGV );

getopts( 'bhqmt' );

if( $opt_h ) {
    print( << 'HELP' );
message [-hmq] in out

in and out default to "-".

in is any mixture of .h and .msg files.

out will be a .h or .msg, the old version will be .bak or .bak.n.

CAUTION: if more than one file is specified, the last file will be
         over-written.  Use -b.

options:
 -b backup output file to .bak (or .bak.n)
 -h this message
 -m generate a reconstructed .msg file
 -q Suppress informational messages
 -t Include text in .h output

HELP

    exit;
}

my( $in, $out ) = ( \*STDIN, \*STDOUT );
my $infile = '-';
my $at;

my %symtab = ( fac => { name => {}, num => {}, }, # Facility name <=> number
               msgno => {},                       # By message number
               name => {},                        # By name
               literals => {},                    # Unresolved literal expressions
);

my $facname;
my $facno     = 0;
my $sharedfac = 0;
my $sysfac    = '';
my $nextmsgno = 1;
my $defsev;

# Magic numbers in condition codes:
#
# F000 0000  - Control bits, ignored here
# 0800 0000  - Customer-assigned code (not /SYSTEM, no $)
# 07FF 0000  - Facility number [0-2047]
# 0000 8000  - Message is facility-specific (not /SHARED)
# 0000 7FFC  - Message number [0-4095) (without facility-specific bit)
# 0000 0007  - Message severity code
#
# Within the DEC-controlled shared message space:
#  4096 - 8191 - Shared message numbers (SHR$ prefix, facility 0, no severity encoded)
#  0 - 4095, 8192 - 32767 - System service message number (SS$ prefix, facility 0)
#             - Note that >= 32768 for facility 0 are unshared, SYSTEM$ prefix, facility 0)
#
# Deviations from VMS Message:
#
#  - Continuation lines are not implemented,
#
#  - /PREFIX not supported - instead, the SYSTEM facility is treated as three separate
#            facilities: SS, SHR and SYSTEM
#
#  - .LITERAL supports limited syntax:
#             only symbol = expression
#             no right shift
#             Perl operators not detected, Perl precedence used.
#
#  - MESSAGE generates foo$_ FACILITY, even for customer facilities.  message generates
#            foo_FACILITY for customer facilities; this enables MOUNT$ and MOUNT to co-exist.
#
#  - Convention for SHR_foo is to encode severity by adding SHR_{WARN,SUCCESS,ERROR,INFO,SEVERE}
#    where used.  (e.g. .LITERAL FAC_foo = (FAC_FACILITY@16) + SHR_foo + SHR_SUCCESS
#


# Severity codes as input (includes abbreviations)

my %sev = ( warning => 0, warn => 0,
            success => 1,
            error => 2,
            info => 3, informational => 3,
            severe => 4, fatal => 4 );

# Severity codes as output

my %sevnam = reverse ( warning => 0, success => 1, error => 2,
                       info => 3, severe => 4, fatal => 4,
                       undef5 => 5, undef6 => 6, undef7 => 7 );

# Select output file, backing up output if requested

if( @ARGV > 1 ) {
    if( $ARGV[-1] ne '-' ) {
        if( $opt_b && -f $ARGV[-1] ) {
            my( $fn, $bak, $n ) = ( $ARGV[-1], '', 0 );
            while( -f ($fn . $bak) ) {
                $bak = '.bak';
                $bak .= '.' . $n if( $n );
                ++$n;
            }
            if( move( $ARGV[-1], $fn . $bak ) ) {
                print STDERR ( "Saved $ARGV[-1] as $fn$bak\n" ) unless( $opt_q );
            } else {
                print STDER( "Can't backup $ARGV[-1]: $!\n" );
                exit;
            }
        }
        if(  !open( $out, '>', $ARGV[-1] ) ) {
            print STDERR ( "Cant open $ARGV[-1]: $!\n" );
            exit;
        }
    }
    pop @ARGV;
}

# Read each input file

do {
    if( @ARGV ) {
        if( $ARGV[0] ne "-" ) {
            undef $in;
            if( !open( $in, '<', $ARGV[0] ) ) {
                print STDERR ( "Cant open $ARGV[0]: $!\n" );
                exit;
            }
            $infile = $ARGV[0];
            print STDERR ( "Processing $infile\n" ) unless( $opt_q );
        }
        shift @ARGV;
    }

    while( <$in> ) {
        s/\r//g;
        chomp;

        $at = sprintf( "at line %u of %s\n", $., $infile );

        # Facility names are the portion of a symbol name before
        # the first '_'.  Those ending in '$' are 'system" (DEC) facilities.
        # Others are customer-defined facilities.
        #
        # Process #define foo$_FACILITY and foo$_anything else.
        # This includes things that are not messages (such as item codes)
        # but those won't be used. Toss unwanted facilities.
        #
        # Only #define FOO$?_BAR n lines are recognized.  n can be a simple
        # decimal, octal or hex constant.
        #
        # Because decompiled message.exe files don't contain symbol or
        # severity information, the #defines pre-populate the symbol table.

        if( !defined($facname) &&
            m/^\s*#\s*define\s*(((\w+?)([\$]?))_(\w+))\s+((?i:0x)?[[:xdigit:]]+)/ ) {
            my( $symname, $facid, $facname, $factype, $id, $val ) =
              ( $1,       $2,     $3,       $4,       $5,  $6 );

            next if( $ign{$symname} || !$wanted{$facid} );

            if( $val =~ /^0/ ) {
                $val = oct( $val );
            } else {
                $val = 0+$val;
            }

            if( $id eq 'FACILITY' ) {
                $symtab{fac}{name}{$facid} = $val;
                $symtab{fac}{num}{$val} = $facid;
            } else {
                # Exact forward and reverse entries.
                # Tentative entry for fuzzy lookup

                $symtab{name}{$symname}{val} = $val;
                $symtab{msgno}{$val}{exact} = $symname;
                my $msgno = $val & 0x0FFFFFF8;
                $symtab{msgno}{$msgno}{default}{sev} = $val & 0x7;
                $symtab{msgno}{$msgno}{default}{sym} = $symname;
                $symtab{msgno}{$msgno}{default}{fac} = $facid;
                $symtab{msgno}{$msgno}{default}{ft} = $factype;
            }

            next;
        }

        # Process message compiler directives.  These don't look like
        # anything that might be found in a .h file, so there's no test
        # for file type.  Only process data between .FACILITY and .END
        # This is a subset of the VMS Message language.

        # Blank and comment lines

        next if( m/^\s*(?:!.*)?$/ );

        if( s{^\s*\.FACILITY\s+([^,]+),\s*([^\s/]+)}{}i ) {
            $facname = uc $1;
            $facno = decodenum( $2, '.FACILITY' );
            unless( defined $facno ) {
                undef $facname;
                next;
            }
            if( $facno >= 2048 ) {
                print STDERR ("$facname facility number ($facno) is too big $at" );
                undef $facname;
                next;
            }
            if( s,/SHARED,,i ) {
                $sharedfac = 1;
            } else {
                $sharedfac = 0;
            }
            if( s,/SYSTEM,,i ) {
                $sysfac = '$';
            } else {
                $sysfac = '';
            }
            s/\s*!.*$//;
            s/\s+//g;

            if( length ) {
                print STDERR ( "Unrecognized .FACILITY directive content '$_' for $facname $at\n" );
            }
            $facno |= 0x0800 unless( $sysfac );

            my @fac = ( $facname );
            push @fac, ( qw/SS SHR/ ) if( $sysfac &&
                                          ( $facname eq 'SYSTEM' ||
                                            $facname eq 'SHR' ) );
            foreach my $fac (@fac ) {
                my $facid = $fac . $sysfac;
                if( $wanted{$facid} ) {
                    $symtab{fac}{name}{$facid} = $facno;
                    $symtab{fac}{num}{$facno} = $facid;
                } elsif( !$opt_q ) {
                    printf STDERR ( ".FACILITY %s is not wanted, will not process $at", $facid );
                }
            }
            $nextmsgno = 1;
            undef $defsev;
            next;
        }

        if( defined($facname) && m/^\s*\.END\b/i ) {
            undef $facname;
            next;
        }
        next unless( defined $facname && $wanted{$facname.$sysfac} );

        if( m/^\s*\.IDENT\b.*$/i ) {
            next;
        }

        if( m/^\s*\.PAGE\b.*$/i ) {
            next;
        }

        if( m/^\s*\.TITLE\b.*$/i ) {
            next;
        }

        if( s/^\s*\.BASE\s+(\S+)//i ) {
            $nextmsgno = decodenum( $1, '.BASE' );
            unless( defined $nextmsgno ) {
                undef $facname;
                next;
            }
            if( $nextmsgno > 4095 ) {
                undef $facname;
                printf STDERR ("Message number too big for .BASE $at");
                next;
            }
            s/\s*!.*$//;
            s/\s+//g;
            if( length ) {
                printf STDERR ("Unrecognized content in .BASE directive $at");
                undef $facname;
                next;
            }
            next;
        }

        if( s/^\s*\.SEVERITY\s+(WARNING|SUCCESS|ERROR|INFO|SEVERE)\b//i ) {
            unless( exists $sev{lc $1} ) {
                print STDERR ("Unknown severity $1 in .SEVERITY $at" );
                undef $facname;
                next;
            }
            s/\s*!.*$//;
            s/\s+//g;
            if( length ) {
                printf STDERR ("Unrecognized content in .SEVERITY $at");
                undef $facname;
                next;
            }

            $defsev = $sev{lc $1};
            next;
        }

        if( m/^\s*\.LITERAL\s+([\$\w]+)\s*=\s*(.+?)\s*(?:!.*)?$/i ) { # Subset
            my( $symname, $expr ) = ( uc $1, uc $2 );

            # Save the original expression.
            # Evaluate any simple constant, converting to decimal.
            # If only simple constants, make a symbol table entry.
            # Otherwise, queue for evaluation.

            my $oe = $expr;
            $expr =~ s/\^[dD]0*(\d+)/$1/g;
            $expr =~ s/\^[xX]([[:xdigit:]]+)/oct( '0x' . $1 )/ge;
            $expr =~ s/\^[oO]([0-7]+)/oct( '0' . $1 )/ge;
            # Shift operator - n.b. only left shift supported here.
            $expr =~ s/\@/<</g;

            # See if whe have a constant
            my $tmp = $expr;
            $tmp =~ s/\s+//g;

            # Remove any paired ()
            1 while( $tmp =~ s/^\((.*)\)\s*$/$1/ );

            if( $tmp =~ /^\d+$/ ) {
                my $val = 0 + $tmp;
                my( undef, $facid, $facname, $factype, $id ) =
                    $symname =~ /^(((\w+?)([\$]?))_(\w+))$/;

                $factype ||= '';
                if( $id eq 'FACILITY' ) {
                    $symtab{fac}{name}{$facid} = $val;
                    $symtab{fac}{num}{$val} = $facid;
                } else {
                    $symtab{name}{$symname}{val} = $val;

                    my $msgno = $val & 0x0FFFFFF8;
                    $symtab{msgno}{$val}{exact} = $symname;
                    $symtab{msgno}{$msgno}{default}{sev} = $val & 0x7;
                    $symtab{msgno}{$msgno}{default}{sym} = $symname;
                    if( defined $facid ) {
                        $symtab{msgno}{$msgno}{default}{fac} = $facid;
                        $symtab{msgno}{$msgno}{default}{ft} = $factype;
                    }
                }
            } else {
                $symtab{literals}{uc $symname}{expr} = $expr;
                $symtab{literals}{uc $symname}{oe} = $oe;
                $symtab{literals}{uc $symname}{at} = $at;
            }
            next;
        }

        # Evaluate message lines

        my( $id, $symname, $msgno, $text, $mods);

        # Names are assigned sequentially following last or .BASE
        # message compiled.  The symbols from decompiled .MSG files
        # are simply the message number in hex preceeded by _.  As these are
        # not useful to humans, we don't treat those as "real" symbols, and
        # attempt to find a better name.
        #
        # Simplification: Qualifiers are only processed after the message text.

        if( s/^\s*(\w+)\s+<([^>]+)>\s*(.*)$// ||
            s/^\s*(\w+)\s+"([^"]+)"\s*(.*)$// ) {
            if( $nextmsgno > 4096 ) {
                undef $facname;
                printf STDERR ("Message number $nextmsgno too big $at");
                next;
            }
            $msgno = ($nextmsgno << 3) | ($facno << 16) | (!$sharedfac << 15);
            $nextmsgno = (($msgno & 0x7FF8) >> 3) +1;
            $symname = uc $1;
            $text = $2;
            $mods = uc $3;
            undef $symname if( $symname =~ /^_[[:xdigit:]]{8}$/ );
        } else {
            printf STDERR ( "Ignored unrecognized line '$_' in message definitions $at" );
            next;
        }

        my( $fac, $facid, $shrmsg );
        my( $mt, $msgsev, $fao, $other );

        # Classify message as system or user and shared or not

        $mt = ($msgno & 0x08000000)? '': '$';

        $shrmsg = !($msgno & 0x8000);
        if( $shrmsg && $mt eq '$' ) {
            if( $msgno >= 4096 && $msgno < 8192 ) {
                $fac = 'SHR';
            } else {
                $fac = 'SS';
            }
        } elsif( $facno == 0 ) {
            $fac = 'SYSTEM';
        } else {
            $fac = $facname;
        }
        $facid = $fac . $mt;

        # Qualifiers:

        # Assign message ID, which is the symbol name unless /IDENT specified

        $id = $symname;
        if( $mods =~ s,/IDENT(?:IFICATION)?[=:](\S+),,i ) {
            $id = $1;
        }

        # Severity: from .SEVERITY or qualifier
        # May be updated later from a registered symbol

        $msgsev = $defsev;
        if( $mods =~ s,/(SUCCESS|INFO(?:RMATIONAL)|WARN(?:ING)|ERROR|SEVERE|FATAL),,i ) {
            $msgsev = $sev{lc $1};
        }

        # FAO argument count

        $fao = 0;
        if( $mods =~ s,/FAO(?:_COUNT)?[=:]([^\s/]+),,i ) {
            $fao = decodenum( $1, '/FAO_COUNT' );
            unless( defined $fao ) {
                undef $facname;
                next;
            }
        }

        # Catch any unimplemented or unrecognized qualifiers

        $mods =~ s/^\s+//g;
        $mods =~ s/\s*!.*$//;
        $mods = s/\s+$//g;

        if( length $mods ) {
            printf STDERR ("Unrecognized content '$mods' in message definition $at");
            undef $facname;
            next;
        }

        if( !defined $msgsev ) {
            print STDERR ( "No .SEVERITY or /<severity> found for message $symname $at" );
            undef $facname;
            next;
        }

        $msgno |= 0+$msgsev;

        # Grab the real severity and symbol from a #define if we have one.

        if( defined( $symname ) ) {
            $symname = $facid . '_' . $symname;
        } elsif( exists $symtab{msgno}{$msgno}{exact} ) {
            $symname = $symtab{msgno}{$msgno}{exact};
            $msgno = ($msgno & ~0x7) | $symtab{msgno}{$msgno}{default}{sev};
        } elsif( exists $symtab{msgno}{$msgno}{default} ) {
            my $def = $symtab{msgno}{$msgno}{default};
            if( $def->{fac} eq $facid ) {
                $symname = $def->{sym};
                $msgno = ($msgno & ~0x7) | $def->{sev};
            }
        }

        # At this point, the symbol name should have been found.
        # It's undefined if it came from an unmessage symbol.
        # Otherwise, it's either explicit in the definition line,
        # or found in the symbol table.

        if( !defined $symname ) {
            if( !defined( $id ) ) {
                print STDERR ( "Neither symbol nor id found in $_ in $facname at line $.\n" );
                undef $facname;
                next;
            }
            $symname = $facid . '_' . $id;
        }

        # Ignore handles the wierd cases of message codes without text
        # aliased to numbers that have text.  SS$_WASSET is the classic.

        next if( $ign{$symname} );

        unless( $opt_m ) {
            # Attempt to convert FAO directives to printf.  These aren't
            # exact.  N.B. FAO count == 0 can still have other directives.

            # Quote %, \ and " for C

            $text =~ s/%/%%/g;
            $text =~ s,\\,\\\\,g;
            $text =~ s,",\\",g;

            # ASCII directives map to %s

            # -- one arg: Counted, Descriptor, ASCIZ
            $text =~ s/!(\d+)?A[CSZ]/'%' . (defined $1? "-$1": '') . 's'/ge;

            # -- len, addr: ASCII, Formatted ASCII
            $text =~ s/!(\d+)?A[DF]/'%' . (defined $1? "-$1": '') . '.*s'/ge;

            # Numeric: PRIxN codes must be listed in genmsg

            # Octal of various sizes, 0-fill, signed, optional field width
            # Oddly, there is no space-fill or minimal width directive for
            # octal or hex.

            $text =~ s/!(\d+)?OB/'%0' . (defined $1? $1:3)  . '"PRIo8"'/ge;
            $text =~ s/!(\d+)?OW/'%0' . (defined $1? $1:6)  . '"PRIo16"'/ge;
            $text =~ s/!(\d+)?OL/'%0' . (defined $1? $1:11) . '"PRIo32"'/ge;
            $text =~ s/!(\d+)?OQ/'%0' . (defined $1? $1:22) . '"PRIo64"'/ge;
            $text =~ s/!(\d+)?OA/'%0' . (defined $1? $1:11) . '%p"'/ge;

            # Decimal signed

            $text =~ s/!(\d+)?ZB/'%0' . (defined $1? $1:3)  . '"PRIu8"'/ge;
            $text =~ s/!(\d+)?ZW/'%0' . (defined $1? $1:6)  . '"PRIu16"'/ge;
            $text =~ s/!(\d+)?ZL/'%0' . (defined $1? $1:11) . '"PRIu32"'/ge;
            $text =~ s/!(\d+)?ZQ/'%0' . (defined $1? $1:22) . '"PRIu64"'/ge;
            $text =~ s/!(\d+)?ZA/'%0' . (defined $1? $1:11) . '%p"'/ge;

            # Hex

            $text =~ s/!(\d+)?XB/'%0' . (defined $1? $1:2)  . '"PRIX8"'/ge;
            $text =~ s/!(\d+)?XW/'%0' . (defined $1? $1:4)  . '"PRIX16"'/ge;
            $text =~ s/!(\d+)?XL/'%0' . (defined $1? $1:8)  . '"PRIX32"'/ge;
            $text =~ s/!(\d+)?XQ/'%0' . (defined $1? $1:16) . '"PRIX64"'/ge;


            # Unsigned, space fill

            $text =~ s/!(\d+)?UB/'%' . (defined $1? $1:'') . '"PRIu8"'/ge;
            $text =~ s/!(\d+)?UW/'%' . (defined $1? $1:'') . '"PRIu16"'/ge;
            $text =~ s/!(\d+)?UL/'%' . (defined $1? $1:'') . '"PRIu32"'/ge;
            $text =~ s/!(\d+)?UQ/'%' . (defined $1? $1:'') . '"PRIu64"'/ge;

            # Decimal, space fill

            $text =~ s/!(\d+)?SB/'%' . (defined $1? $1:'') . '"PRId8"'/ge;
            $text =~ s/!(\d+)?SW/'%' . (defined $1? $1:'') . '"PRId16"'/ge;
            $text =~ s/!(\d+)?SL/'%' . (defined $1? $1:'') . '"PRId32"'/ge;
            $text =~ s/!(\d+)?SQ/'%' . (defined $1? $1:'') . '"PRId64"'/ge;

            # CR-LF

            $text =~ s/!\//\\n/g;

            # Arg number movements (Not supported, but remove the directive)
            # Might handle with %n$, but that's not supported everwhere, and
            # fortunately, no message that we use requires it.

            $text =~ s/!(?:\d+)?(?:\+|--)//g;

            # Character expansion

            $text =~ s/!(\d+)?\*(.)/defined $1? ($2 x $1) : $1/ge;

            # Special items: Date, Time, plural, UIC
            # The %% is because of the % substitution earlier

            $text =~ s/!%%D/%s/g;
            $text =~ s/!%%T/%s/g;
            $text =~ s/!%%S/(s)/g;
            $text =~ s/!%%U/[%o,%o]/g;

            # n-ary IF / ELSE /FI
            if( 0 ) {
                $text =~ s/!(\d+)%%C//g;
                $text =~ s/!%%E//g;
                $text =~ s/!%%F//g;
            }

            # !! => !
            $text =~ s/!!/!/g;

            if( $text =~ /!/ ) {
                print STDERR ( "Unknown \$FAO code in $text\n" );
            }
        }

        # Detect duplicate symbols
        # Ignore differences caused by fuzzy symbol entries.

        if( exists $symtab{name}{$symname} &&
            $symtab{name}{$symname}{val} != $msgno ) {
            my( $v1, $v2 ) = ( $symtab{name}{$symname}{val}, $msgno );

            if( (($v1 ^ $v2) & 0x0FFFFFF8) ||
                ((($v1 ^ $v2)& 0x7) != 0 && ($v1 & 0x7) != 0) ) {
                my $n = ++$symtab{name}{$symname}{dups};

                my $len;
                unless( $opt_q ) {
                    printf STDERR ( "Duplicate symbol $symname, using $symname.$n instead $at" );
                    $len = length( $symname . $n );
                    printf STDERR ( "  %-*s %08x %u\n", $len, $symname,
                                    $symtab{name}{$symname}{val},
                                    $symtab{name}{$symname}{val} );
                }
                $symname .= $n;
                unless( $opt_q ) {
                    printf STDERR ( "  %-*s %08x %u\n", $len, $symname, $msgno, $msgno );
                    printf STDERR ( "  %-*s %08x\n", $len, 'XOR', ($v1+0) ^ ($v2+0) );
                }
            }
        }

        # Create symbol table entry for this message

        $symtab{name}{$symname}{val} = $msgno;

        $symtab{msgno}{$msgno}{default}{fac} = $facid;
        $symtab{msgno}{$msgno}{default}{ft} = $mt;
        $symtab{msgno}{$msgno}{default}{sev} = $msgno & 0x7;
        $symtab{msgno}{$msgno}{exact} = $symname;

        $symtab{msgno}{$msgno}{sym} = $symname;
        $symtab{msgno}{$msgno}{text} = $text;
        $symtab{msgno}{$msgno}{fao} = $fao;
        $symtab{msgno}{$msgno}{id} = $id;
    } # Each line of file

    if( $in != \*STDIN ) {
        close( $in );
        printf STDERR ("\n" ) unless( $opt_q );
        undef $infile;
    }

    undef $facname;
    $facno = 0;
    $sharedfac = 0;
    $nextmsgno = 1;
    undef $defsev;
} while( @ARGV );

# Decode Message language number
# ^D - decimal
# ^O - octal
# ^X - hex
#
# Default is decimal
#
# Not supported: ^O( 10 + 10 ); (^O10 + ^O10) is OK

sub decodenum {
    my $num = shift;
    my $thing = shift;

    if( $num =~ /^\s*\^[xX]([[:xdigit:]]+)\s*(?:!.*)?$/ ) {
        return oct( '0x' . $1);
    }
    if( $num =~ /^\s*\^[oO]([0-7]+)\s*(?:!.*)?$/ ) {
        return oct( '0' . $1);
    }
    if( $num =~ /^\s*(?:\^[dD])?0*([0-9]+)\s*(?:!.*)?$/ ) {
        return 0+$num;
    }
    printf STDERR ( "Unrecognized value for $thing $at" );
    return undef;
}

sub msgsort { # Increasing group shared, then severity, msg # within group
    return
        ($a & 0x8000) <=> ($b & 0x8000) ||
        ($b & 1)      <=> ($a & 1)  ||
        ($a & 6)      <=> ($b & 6)  ||
        ($a & 0xFFF8) <=> ($b & 0xFFF8);
}

# Resolve literal expressions
#
# This isn't a full implementation of the VMS message language.
# The more important points:
#   No right shift (- @)
#   Perl precedence - and Perl operators illegal in Message accepted
#   No multiple assignments/directive or default values
# This is intended to be just enough to allow expressions of
# the form ( (foo$_facility@16) + SHR$_bar + 4
# to enable defining symbols so shared messages can be used.

sub symval {
    my( $v, $pass ) = @_;

    if( $v =~ /^\d+$/ ) {
        return 0+$v;
    }

    if( exists $symtab{name}{$v} &&
        exists $symtab{name}{$v}{val} ) {
        return $symtab{name}{$v}{val};
    }

    if( $v =~ /^([^_]+)_FACILITY$/ && exists $symtab{fac}{name}{$1} ) {
        return $symtab{fac}{name}{$1};
    }

    return $v if( $pass < 2 );

    return "Undef";
}

for( my $pass = 1; $pass <= 2; $pass++ ) {
    foreach my $symname (keys%{$symtab{literals}}) {
        my( $expr, $oe, $at ) = @{$symtab{literals}{$symname}}{qw/expr oe at/};

        $expr =~ s{\b([\$\w]+)\b}{symval($1, $pass)}gex;

        if( $expr =~ m{[^()+*\@/\d\s-]} && $pass < 2 ) {
            $symtab{literals}{$symname}{expr} = $expr;
            next;
        }

        if( $expr =~ /Undef/ ) {
            chomp $at;
            printf STDERR ( "Undefined symbol in expression $at: $oe => $expr\n" );
        } else {
            my $val = eval "$expr";
            if( $@ ) {
                chomp $at;
                printf STDERR ( "Unable to evaluate expression $at: $oe => $expr: $@\n" );
            } else {
                my( undef, $facid, $facname, $factype, $id ) =
                    $symname =~ /^(((\w+?)([\$]?))_(\w+))$/;
                $factype ||= '';
                unless( defined $id ) {
                    print STDERR ( "$symname can't be parsed (should be facility$?_id) $at" );
                    next;
                }
                if( $id eq 'FACILITY' ) {
                    $symtab{fac}{name}{$facid} = $val;
                    $symtab{fac}{num}{$val} = $facid;
                } else {
                    $symtab{name}{$symname}{val} = $val;

                    my $msgno = $val & 0x0FFFFFF8;
                    $symtab{msgno}{$val}{exact} = $symname;
                    $symtab{msgno}{$msgno}{default}{sev} = $val & 0x7;
                    $symtab{msgno}{$msgno}{default}{sym} = $symname;
                    if( defined $facid ) {
                        $symtab{msgno}{$msgno}{default}{fac} = $facid;
                        $symtab{msgno}{$msgno}{default}{ft} = $factype;
                    }
                }
            }
        }
    }
}

if( $opt_m ) {
    # Generate a .msg file as output
    # Sort and format for human consumption.
    printf( << 'HEADING', $VERSION, $argv );
! This is an automatically-generated file.  message version %s
!
! Command: message %s
!
! It uses a subset of the VMS Message utility language.
! The message definitions can be processed by the message
! Perl script, which will compile them into a .h file usable
! by sysmsg.c and all the ODS2 modules that rely on condition
! codes.
!
! This technlology was developed by Timothe Litt, and is
! free to use with the ODS2 package, originally developed by
! Paul Nankervis <Paulnank@au1.ibm.com>.
!
! ODS2 may be freely distributed within the VMS community
! providing that the contributions of the original author and
! subsequent contributors are acknowledged in the help text and
! source files.  This is free software; no warranty is offered,
! and while we believe it to be useful, you use it at your own risk.
!

HEADING

    my $infac;

    foreach my $facid ( sort keys %{$symtab{fac}{name}} ) {
        my $facno = $symtab{fac}{name}{$facid};

        my( $facname, $sharedfac, $nextmsgno, $lastsev );
        $facname = $facid;
        $facname =~ s/\$$//;

        $sharedfac = 100;
        $nextmsgno = 1;
        $lastsev = 99;

        foreach my $msgno (sort msgsort grep {
            exists $symtab{msgno}{$_}{default}{fac} &&
                $symtab{msgno}{$_}{default}{fac} eq $facid }
                           keys %{ $symtab{msgno}}) {

            my $msg = $symtab{msgno}{$msgno};
            my $mshr = (~(0+$msgno)) & 0x8000;

            # New facility (also if /SHARED changes)

            my $mt = ($facno & 0x0800)? '': '$';
            if( $mshr != $sharedfac ) {
                print( "\n        .END\n" ) if ($infac );
                printf( "\n        .FACILITY %s,%u",
                        $facname,
                        $facno & ~0x0800 );
                if( !($facno & 0x0800) ) {
                    print( " /SYSTEM" );
                }
                if( $mshr ) {
                    print( " /SHARED" );
                }
                print( "\n" );
                $sharedfac = $mshr;
                $infac = 1;
            }

            # Generate .LITERAL for symbols without message text

            if( !exists $msg->{text} ) { # Typ. Shared message codes
                next if( exists $msg->{default}{sev} && # This partial def was resolved
                         exists $symtab{msgno}{($msgno & ~7) |
                                                   $msg->{default}{sev}}{text} );

                my $symnam =  $msg->{default}{sym};
                printf( "        .LITERAL %-*s = (",
                        (length($facid)+1+15),
                        $symnam );
                # Try to create a symbolic expression for the value
                my( $mfac, $mnum, $msev ) = (
                    ($msgno & 0x0FFF0000) >> 16,
                    ($msgno & 0xFFF8),
                    $msgno & 7 );
                my $expr = '';
                if( !($msgno & 0x8000) ) {
                    if( $mfac ) {
                        my $fs = $mfac;
                        $fs = $symtab{fac}{num}{$mfac} . '_FACILITY'
                            if( exists $symtab{fac}{num}{$mfac} );

                        $msev = $symtab{msgno}{$msgno}{default}{sev}
                            if( exists $symtab{msgno}{$msgno}{default}{sev} );

                        $expr .= '(' . $fs . '@16)';
                        if( exists
                            $symtab{msgno}{$msgno}{exact} &&
                            $symtab{msgno}{$msgno}{exact} ne $symnam ) {
                            $expr .= ' + '.  $symtab{msgno}{$msgno}{exact};
                        } elsif( exists
                                 $symtab{msgno}{$mnum | $msev}{exact} &&
                                 $symtab{msgno}{$mnum | $msev}{exact} ne $symnam ) {
                            $expr .= ' + '.
                                $symtab{msgno}{$mnum | $msev}{exact};
                        } elsif( exists
                                 $symtab{msgno}{$mnum}{exact} &&
                                 $symtab{msgno}{$mnum}{exact} ne $symnam ) {
                            $expr .= ' + '.
                                $symtab{msgno}{$mnum}{exact};
                            $expr .= ' + '. $msev;
                        } elsif( $mnum ) {
                            $expr .= sprintf( ' + (^D%u@3) + %u',
                                              ($mnum >> 3), $msev );
                        } else {
                            $expr .= sprintf( '+ %u', $msev );
                        }
                    }
                }
                unless( length $expr ) {
                    if( exists $msg->{default}{sev} ) {
                        $expr = ($msgno & ~7) | $msg->{default}{sev};
                    } else {
                        $expr = $msgno;
                    }
                }

                $expr .= ')';
                printf( "%-50s ! 0x%08x %s\n", $expr,
                        ($mfac << 16) | $mnum | $msev, ucfirst $sevnam{$msev} );

                if( $msgno & 0x8000 || $symtab{fac}{name}{$facid} == 0 ) {
                    print STDERR ( "No text found for $msg->{default}{sym}\n" );
                    next;
                }
                next;
            }

            # See if a new .SEVERITY is necessary

            my $thissev = $msgno & 7;
            my $nl = 1;
            if( $thissev != $lastsev ) {
                printf( "\n        .SEVERITY %s\n", uc $sevnam{$thissev} );
                $lastsev = $thissev;
                $nl = 0;
            }

            # Or a new .BASE

            my $mno = ($msgno & 0x7FFF) >> 3;
            if( $mno != $nextmsgno ) {
                if( $nl ) {
                    print( "\n" );
                    $nl = 0;
                }
                printf( "        .BASE %u\n", $mno );
            }
            $nextmsgno = $mno + 1;

            # Message definition line

            {
                my @delim = $msg->{text} =~ /[<>]/? ('"', '"'): ('<', '>');
                my( $symname, $facid, $facname, $factype, $sid ) =
                    $msg->{sym} =~ /^(((\w+?)([\$]?))_(\w+))$/;

                printf( "%-16s %s%s%s",
                        $sid,
                        $delim[0], $msg->{text}, $delim[1] );
                if( $msg->{id} ne $sid ) {
                    printf( " /IDENT=%s", $msg->{id} );
                }
            }
            if( $msg->{fao} ) {
                printf( " /FAO=%u", $msg->{fao} );
            }
            print( "\n" );
        } # each message number in facility

        print( "\n        .END\n" ) if( $infac );
        $infac = 0;
        print ("\n" );
    } # each facility

    exit;
}

# Output the header file in sections:
#
# Prolog
# Standard macro definitions for condition names
# Entries for the facility definition structure
# Entries for the message text definition structure
#
# The last two are enabled by a magic #define in the caller.

printf( << '__EOF', $VERSION, $argv );
#ifndef _SDEF_H
#define _SSDEF_H
/* ** MACHINE GENERATED FILE by message version %s: ODS2 Message catalog */

/* Command: message %s
 */
/*
 *      This is part of ODS2 written by Paul Nankervis,
 *      email address:  Paulnank@au1.ibm.com
 *
 *      ODS2 may be freely distributed within the VMS community
 *      providing that the contributions of the original author and
 *      subsequent contributors are acknowledged in the help text and
 *      source files.  This is free software; no warranty is offered,
 *      and while we believe it to be useful, you use it at your own risk.
 *
__EOF

print( << '__EOF' ) if( $opt_t );
 * This file contains #defines for condition codes as well as initialization
 * data for the structures used to print them.  It is compiled from VMS
 * Message utility language, however the translations from $FAO to printf
 * are approximate, which means that those messages sourced from VMS
 * may not work in exactly the same way if compiled with VMS Message.
 *
__EOF

printf( << '__EOF' );
 * Note: This file was automatically generated, and may contain many
 * messages that are not used by ODS2.  It was easier than finding each one.
 * To rebuild it using the VMS files, you need some sources from a standard
 * VMS system.  But you can probably skip to the SHORT procedure...unless
 * you are producing an I18n translation, and want the translated VMS messages...
 *
 * The full procedure is:
 *
 * On a VMS system:
 * Obtain unmessage for VMS from a SIG tape, Freeware CD, or
 * ftp://ftp.decuserve.org/decus/vms/sig_tapes/vax88b1/meadows/unmessage/unmessage.exe
 *
 * $ set command unmessage.cld
 * $ unmessage sys$message:sysmsg.exe /output=vms_msgdump.msg
 *
 * $ copy sys$library:*.h vms_msgdefs.h
 *
 * The rest of the process does not require a VMS system:
 *
 * You can run the Perl script "message" on any convenient machine.
 *
 *   perl message -b vms_msgdefs.h ods2.msg vms_msgdump.msg ssdef.h
 *
 * Note "ods2.msg" in the middle; this is the ODS2 message catalog and
 * ssdef.h (the last file) is the output.
 *
 * Symbols come from the #defines in the .h files, which also contribute the
 * message severity codes.  The output is this .h file, which includes the
__EOF

if( $opt_t ) {
    printf( << '__EOF' );
 * #defines and table data used by sysmsg.c.
__EOF
} else {
    printf( << '__EOF' );
 * #defines for message codes.  To get the message definitions, use message -t.
__EOF
}

printf( << '__EOF' );
 *
 * The compiler can also produce a .msg file as output (use -m).  This
 * provides a reconstructed .msg file with the correct severity codes and
 * IDENT mappings.  This can be used to populate ods2msg.msg by removing
 * unsused messages
 *
 *   perl message -bm vms_msgdefs.h vms_msgdump.msg vms_messages.msg
 *
 * At this point, you can get just the VMS messages in ssdef.h form with:
 *   perl message -b vms_messages.msg vms_messages.h
 *
 * But you really want the ODS2 version:
 *   perl message -b vms_messages.msg ods2.msg ssdef.h
 *
 * Currently, the interesting VMS messages are distributed as vms_messages.msg,
 * so the SHORT procedure is:
 *     perl message -b vms_message.msg ods2.msg ssdef.h.
 *
 */

__EOF

# define foo$?_FACILITY

my $maxflen = 0;
foreach my $facid (keys %{$symtab{fac}{name}} ) {
    my $len = length( $facid . '_FACILITY' );

    $maxflen = $len if( $len  > $maxflen );
}

foreach my $facid ( sort keys %{$symtab{fac}{name}} ) {
    printf( "#define %-*s %u\n", $maxflen,
            $facid . '_FACILITY', $symtab{fac}{name}{$facid} );
}

# define other symbols

my $maxslen = 0;
foreach my $symname (keys %{$symtab{name}}) {
    my $len = length $symname;
    $maxslen = $len if( $len > $maxslen );
}

foreach my $symname (sort keys %{$symtab{name}}) {
    my $val =  $symtab{name}{$symname}{val};

    unless( defined $val ) {
        print STDERR ("Undefined value for $symname\n");
        next;
    }
    printf( "#define %-*s %9u", $maxslen, $symname, $val );

    printf( " /* %08x %s */", $val, ucfirst $sevnam{$val & 7} );

    print( "\n" );
}

print( "#endif\n" );

exit unless( $opt_t );

# Facility table

print( "#ifdef GENERATE_FACTAB\n#undef GENERATE_FACTAB\n/* { code, \"string\" }, */\n" );
foreach my $facid ( sort keys %{$symtab{fac}{name}} ) {
    my $facno = $symtab{fac}{name}{$facid};

    printf( "FAC(%-*s, %-*s) /* %-4u",
            $maxflen, $facid . '_FACILITY',
            $maxflen, ($facid =~ /\$$/)? substr( $facid, 0, -1 ): $facid,
            $facno & 0x07FF );
    if( $facno & 0x0800 ) {
        printf( " + customer = %-4u", $symtab{fac}{name}{$facid} );
    } else {
        print(  "                  " );
    }
    print (" */\n" );
}
print( "#endif\n" );

# Message table

print( "#ifdef GENERATE_MSGTAB\n#undef GENERATE_MSGTAB\n/* MSG( code, facility, \"text \", #args) */\n" );

my $maxilen = 0;
$maxslen = 0;
foreach my $msgno (keys %{$symtab{msgno}}) {
    my $msg = $symtab{msgno}{$msgno};

    if( exists $msg->{text} ) {
        my $len = length $msg->{id};
        $maxilen = $len if( $len > $maxilen );
        $len = length $msg->{sym};
        $maxslen = $len if( $len > $maxslen );
    }
}

foreach my $msgno (sort msgsort keys %{$symtab{msgno}}) {
    my $msg = $symtab{msgno}{$msgno};

    if( exists $msg->{text} ) {
        my $symname;

        my $m = 'MSG(' . $msg->{sym} . (' ' x ($maxslen - length $msg->{sym})) .
                    ', ' . $msg->{id} . ( ' ' x ($maxilen - length $msg->{id})) .
                    ', "' . $msg->{text} . '", ' . $msg->{fao} . ')';

        if( length $m > 95 ) {
            $m .= "\n" . (' ' x 95 );
        } else {
            $m .= ' ' x (95 - length( $m ));
        }
        $m .= sprintf( "/* %08x %s */\n", $msgno, ucfirst $sevnam{$msgno & 0x7} );
        print( $m );
    }
}
print( "#endif\n" );
exit;