#!/usr/bin/perl # # rose2xml.pl - convert Rational Rose mdl/cat/sub files to XML # # Options - shall be given first, before any file arguments: # # -? or -h or --help # Prints short help text on options. # # -x By default, the program attempts to load controlled unit # files referenced if they can be found. # Separate XML files will be generated for these cases. # The option "-x" switches off all processing of controlled # units. # # -X # Similar to "-x" but switches off loading of only those # units listed in the given . # The shall contain the controlled # units, one unit per line, in the format as appears # in the referencing Rose file. For example, for the Rose # file snippet: # logical_models (list unit_reference_list # (object Class_Category "APF" # is_unit TRUE # is_loaded FALSE # file_name "$APF_ROOT\\APF\\APF.cat" # the exclusions file would contain a line: # $APF_ROOT\\APF\\APF.cat # # -i Switches on integration of controlled units into the main # output file. By default, controlled units are not integrated # into the main output file. Instead, if they are physically # available then they will be parsed separately and equivalent # XML files will be generated at equivalent subdirectories in # the output directory. # Note that the options "-i" and "-x" are mutually exclusive; # providing both will make the program exit prematurely with an # error. # # -curoot # Controlled unit root directory - this option applies to the # case that the controlled units referenced share a common # directory prefix. The prefix will be removed on writing the # output files. This is done to support the output directory # being different from the input directory ("out of source"). # # -relcup Relativize controlled unit paths - for use in conjunction # with -curoot : At references to controlled units transform # the file_name attribute to become relative to the value # given with the -curoot option. # # -nocv Do not transfer the Component View to the output file. # # -nopres Do not transfer diagrams to the output file. # # -s Use only spaces for indentation instead of tabs/spaces mix. # # -cta Condense Trivial Attribute: elements where the # "value" attribute is a short, simple (single word) value # will be compressed from multi line style to single line. # Example: # (object Attribute # tool "Cplusplus" # name "Inline" # value TRUE) # without "-cta" will be transformed to: # # # with "-cta" will be transformed to: # # # -v Verbose mode produces basic messages on program execution. # # -vv Very Verbose mode produces detailed messages on execution. # # Copyright (C) 2016-2022, O. Kellogg # # This program is distributed under the Perl Artistic License, see # https://opensource.org/licenses/Artistic-2.0 # # $Log: rose2xml.pl,v $ # Revision 2.2 2022/05/14 09:10:24 okellogg # - Switch license from GPL to Perl Artistic. # - Add option -h (--help) printing help text on options. # - In sub xmlEsc replace carriage return ("\r") by # - In sub parseNested at examples add `collaborators', Instantiated_Class, # Instantiated_Class_Utility, Parameterized_{Class,Class_Utility}, # origin_attachment, terminal_attachment. # - In sub sub write_outfile, if $abspath_filename ends in ".mdl" then do # not carry the extension forward to $xmlFile. I.e. for a file my.mdl # the XML filename is now my.xml instead of my.mdl.xml. # # Revision 2.1 2021/01/30 21:30:45 okellogg # Command line option "-cta" condenses a trivial into a single line. # # Revision 2.0 2021/01/16 07:03:07 okellogg # - In sub addNested, # - push @nest onto @$nestsRef before evaluating whether to append '>' onto # $nestsRef->[$last]; # - return true if @nest contains an XML tag. # - New sub hasUnterminatedString returns true if the number of non escaped # quotation marks in the string argument is odd. # - In sub parseNested while-loop, # - if hasUnterminatedString($line) returns true then read the next line # from file and append it onto $line; # - evaluate return value from calls to sub addNested; if true then push # end-tag onto @nests, else append "/>" onto $nests[-1]; # - handle multi line text on encountering any standalone keyword, not just # "documentation"/"label"/"type". # - In sub closeScope, on indexing last element in @{$attrsRef} use -1 in lieu # of scalar(@$attrsRef) - 1. # # Revision 1.9 2020/10/08 06:30:35 okellogg # - Remove unused sub closeTag. # - Add global @petalHdr (filled by sub skipPetalHeader). # - New sub dumpPetalHeader dumps @petalHdr to the list passed in # by reference if @petalHdr is non empty. # - In sub skipPetalHeader, # - remove third argument, it is obsoleted by the new global @petalHdr; # - if $curoot is set then remove it from the start of $inFileName. # # Revision 1.8 2019/11/21 06:31:04 okellogg # - New command line switch "-i" switches on integration of controlled # units into the main file. By default, controlled units are no longer # integrated into the main output file. Instead, if they are physically # available then they will be parsed separately and equivalent files # will be generated at equivalent subdirectories in output directory. # Options "-i" and "-x" are mutually exclusive. # - In sub report, only print line number if available. # - In sub load and sub parseNested, use `report' in lieu of `warn' for # printing info messages and warnings. # - In sub load : # - On regex-comparing against /\.sub$/ fix typo on variable $roseFile; # - On grepping over @exclusions use $roseFile in the per-element block; # - Use separate variable $result_fname for the subroutine return value; # - In case !$integrateControlledUnits, # - in case $relcup case (scalar(@refPathSeg) <= scalar(@fPathSeg)) # fix if-condition for reassigning $relPath from join of @fPathSeg; # - add "else" part handling case !$relcup in which $result_fname is # assigned from $xmlFile. # # Revision 1.7 2019/11/14 20:40:42 okellogg # - Add option "-vv" for Very Verbose mode. # - New sub report implements "-v" mode. # - Existing sub gab is changed to implement "-vv" mode. # Additionally, the current file and line number are printed before $msg. # - In "-relcup" mode, file_name values at references to controlled units # are changed to relative paths. # - New global @referencingFile helps materialize the relative paths in # "-relcup" mode: # - In the main program, a given mdl file is pushed onto @referencingFile. # - In sub load, a given $filename is pushed onto @referencingFile before # the call to parseNested, and is popped off again after return from the # call. # - New sub pathSegments expects a filename with absolute path as argument # and returns the path relative to $curoot as a list. # This helps materialize the relative paths in "-relcup" mode. # - In sub load: # - Fix bug in detection of .sub file in "-nocv" mode. # - In case !$integrateControlledUnits implement the "-relcup" change for # generating relative paths. # - In sub parseNested call `report' showing $fnameOut computed by load(). # - In sub write_outfile: # - Rename argument $rose_filename to $abspath_filename. # - In case $curoot, # - fix typo on variable $rootLen at condition # if (length($path) > $curootLen [...] # - use File::Basename::basename($xmlFile) on assigning to $basename. # # Revision 1.6 2019/10/31 20:44:49 okellogg # - New option "-curoot " set a controlled unit root directory. # This directory is assumed to be the common root of all controlled unit # paths. It will will be removed on writing the output files. # This is done to support output directories deviating from the input # directory ("out of source"). # - New option "-relcup" switches on relativization of controlled unit paths # for use in conjunction with "-curoot". At references to controlled units, # the file_name attribute is transformed to become relative to the value # given at the -curoot option. # - New option "-i" switches on integration of controlled units into the # main output file. This was the default behavior in previous versions. # In the current version, by default controlled units are not integrated # into the main output file. Instead, if they are physically available # then they will be parsed separately and equivalent XML files will be # generated at equivalent subdirectories in the output directory. # Note that the options "-i" and "-x" are mutually exclusive; providing # both will make the program exit prematurely with an error. # - The options "-x" and "-X" are swapped: Option "-x" switches off loading # of controlled units while option "-X" takes the # argument. # - New sub write_outfile factors creation of and writing to output files. # - sub skipPetalHeader gets a new second argument, the input file name. # If $outListRef is provided then the $inFileName is added in the XML # header comment. # - The list returned by sub load has an added first element: the output # filename which was computed from the input file name. # I.e. the returned list now always has a least 1 element. # - Global $excludeAllControlledUnits is renamed to $excludeControlledUnits. # - Global boolean $integrateControlledUnits helps materialize option "-i". # - Global string $curoot helps materialize option "-curoot". # - Global boolean $relcup helps materialize option "-relcup". # - Due to added capabilities the program now requires the module File::Path. # # Revision 1.5 2019/10/26 05:41:01 okellogg # - New sub gab factors printing of $verbose messages. # - In sub load return immediately if $nocv is true and we are dealing with # a SUB file. # - In sub parseNested add examples for cases 1 to 4 and the catch-all case. # # Revision 1.4 2019/10/16 03:44:26 okellogg # In sub parseNested case "Handle everything else", # - at the if-statement testing ($attr eq "class") add an elsif-part # testing ($attr eq "quidu") pushing $value embedded in a "" # element onto @nests and setting local $seen_module_quidu true; # - change else-part of `if ($specialKey)' into # elsif (!$seen_module_quidu) # to exclude the module quidu from being generated as an attribute. # # Revision 1.3 2019/10/14 18:10:36 okellogg # - New command line option "-v" increases verbosity. # - In sub parseNested case "Handle everything else", split the if-condition # ($is_module && !$is_Module_Visibility_Relationship && $attr eq "class") # into # if ($is_module) { # if (!$is_Module_Visibility_Relationship && $attr eq "class") { # and add an else-part to the outer if-statement. The else-part handles # the case ($attr eq "module") such that module/quidu attribute pairs of # Classes are joined into a synthetic tag as done for component # modules. # # Revision 1.2 2019/10/13 19:21:02 okellogg # - Add command line options : # "-X" implemented using $excludeAllControlledUnits; # "-x " implemented using @exclusions; # "-nocv" implemented using $nocv; # "-nopres" implemented using $nopres and sub diagramSuppression; # "-s" implemented using $useSpacesForIndentation. # - In sub parseNested : # - At object Case 1 assignment to $nameClause exclude delimiting quotation # marks from $rest and apply xmlEsc to $rest; # - At object Case 2 assignment to $name exclude delimiting quotation marks # from $3 and apply xmlEsc to $3; # - At object Case 3, # - at assignment to $name exclude delimiting quotation marks from $4 and # apply xmlEsc to $4; # - simplify handling of $tag. # - Replace tabs in comment by spaces. # # Revision 1.1 2019/10/06 06:50:13 okellogg # - In sub xmlEsc switch off conversion of ' ' (space) to ' '. # - Fix modification of v1.0 for multiply defined attributes "class" and # "quidu" generated for multiple SubSystem module assignments of those # attributes: # - Global $is_Module_Visibility_Relationship is set true in sub parseNested # on encountering object case 4 / $objType Module_Visibility_Relationship # before call to addNested, and is reset false after the call. # - In sub parseNested case "Handle everything else", before pushing an # attribute onto @attrs : # - Extend test of $is_module and ($attr eq "class") to require # $is_Module_Visibility_Relationship to be false. This is done because # Module_Visibility_Relationship has a "quidu" attribute which confuses # the special handling of the module class and quidu. # - If the test evaluates to true then place the class and quidu attribute # pair into a synthetic tag. # # Revision 1.0 2019/07/07 06:58:00 okellogg # Fix for multiply defined XML attributes "class" and "quidu" generated for # multiple SubSystem module assignments of those attributes: # - Global $is_module is set true in sub parseNested on encountering object # case 2 (ObjType Name Type Part [Tag]) Name="module" before call to # addNested, and is reset false after the call. # - In sub parseNested case "Handle everything else", before pushing an # attribute onto @attrs test whether $is_module is true and the attribute # name is "class" or "quidu". If so, # - add terminating ">" on $attrs[-1]; # - on pushing onto @attrs use XML tagged element syntax # "<$attr>$value", "Do not load units listed in " ], [ "-i", "Integrate controlled units into the main unit" ], [ "-curoot ", "Controlled unit root directory" ], [ "-relcup", "Relativize controlled unit paths (for use with -curoot)" ], [ "-nocv", "Do not transfer Component View to output file" ], [ "-nopres", "Do not transfer diagrams to output file" ], [ "-s", "Use only spaces for indentation" ], [ "-cta", "Condense trivial Attribute onto single XML line" ], [ "-v", "Verbose" ], [ "-vv", "Very Verbose" ] ); foreach (@options) { my ($switch, $helptext) = @$_; printf("%-21s %s\n", $switch, $helptext); } exit 0; } while ($ARGV[0] =~ /^-/) { my $option = $ARGV[0]; if ($option eq "-x") { shift @ARGV; $excludeControlledUnits = 1; } elsif ($option eq "-X") { # load exclusions file shift @ARGV; my $xfile = shift @ARGV; open(EX, "<", $xfile) or die "-X : Cannot open file $xfile\n"; while () { chomp; s/\r//g; my $l = $_; $l =~ /^\s*$/ and next; $l =~ /^\s*#/ and next; push @exclusions, $l; } close EX; } elsif ($option eq "-i") { shift @ARGV; $integrateControlledUnits = 1; } elsif ($option eq "-curoot") { shift @ARGV; $curoot = shift @ARGV; } elsif ($option eq "-relcup") { shift @ARGV; $relcup = 1; } elsif ($option eq "-nocv") { shift @ARGV; $nocv = 1; } elsif ($option eq "-nopres") { shift @ARGV; $nopres = 1; } elsif ($option eq "-cta") { shift @ARGV; $cta = 1; } elsif ($option eq "-s") { shift @ARGV; $useSpacesForIndentation = 1; } elsif ($option eq "-v") { shift @ARGV; $verbose = 1; } elsif ($option eq "-vv") { shift @ARGV; $verbose = 2; } else { die("Unknown option $option\n"); } } if ($excludeControlledUnits && $integrateControlledUnits) { die "ERROR: Options -x and -i are mutually exclusive\n"; } foreach my $mdl (@ARGV) { open my $IN, '< :encoding(windows-1252)', $mdl or die "Cannot open file $mdl\n"; my @out = (''); push @referencingFile, Cwd::abs_path($mdl); my $infileWithoutPath = $mdl; $infileWithoutPath =~ s@^.*/@@; my($object, $name) = skipPetalHeader($IN, $infileWithoutPath); unless ($object) { warn "$mdl does not appear to be a Rose model file\n"; close $IN; next; } dumpPetalHeader(\@out); $gi = ""; push @out, "<$object name=$name"; push @out, parseNested($IN); push @out, ""; close $IN; write_outfile($infileWithoutPath, \@out); pop @referencingFile; } # Read a line from $IN, including `chomp' and removal of DOS carriage return. # Return `undef' on encountering end of file. sub getline { my $IN = shift; my $line = <$IN>; defined($line) or return undef; chomp $line; $line =~ s/\r$//; return $line; } sub report { my $msg = shift; $verbose or return; print $referencingFile[-1]; if ($.) { print " line $."; } print " : $msg\n"; } sub gab { my $msg = shift; $verbose == 2 or return; print($referencingFile[-1] . " line $. : $msg\n"); } # Skip the "(object Petal" version header. # First argument: Input file handle. # Second argument: Input file name. # Third argument: Optional reference to output list. # If given then the petal header will be pushed onto the list # as an XML comment. If the petal header is not found before the # next object declaration then nothing is pushed. # Return value: Tuple of object type and name of the next object (following the # petal header if the petal header was found). # If no object declaration is found then returns a tuple of empty # values (this is an error). sub skipPetalHeader { my $IN = shift; my $inFileName = shift; my($line, $object, $name); while (defined($line = getline($IN))) { if ($line =~ /\(object Petal/) { my($version, $written, $charSet); while (defined($line = getline($IN))) { if ($line =~ /version\s+(\d+)/) { $version = $1; } elsif ($line =~ /_written\s+"([^"]+)"/) { $written = $1; } elsif ($line =~ /charSet\s+(\d+)/) { $charSet = $1; } last if ($line =~ /\)\s*$/); } if ($curoot) { $inFileName =~ s@^$curoot/@@; } push @petalHdr, ""; } elsif ($line =~ /^\(object (\w+) (.+)$/) { $object = $1; $name = $2; last; } } return ($object, $name); } sub dumpPetalHeader { my $outRef = shift; if (@petalHdr) { push @$outRef, @petalHdr; @petalHdr = (); } } sub xmlEsc { my $text = shift; $text =~ s/&/&/g; $text =~ s/"/"/g; $text =~ s//>/g; $text =~ s/\r/ /g; return $text; } # Returns true if nested elements were parsed. # Returns false if only attributes were parsed, no nested elements. sub addNested { my($nestsRef, $infile) = @_; my @nest = parseNested($infile); my $last = scalar(@$nestsRef) - 1; push @$nestsRef, @nest; if ($nest[0] =~ /^ +[$last] =~ />$/) { $nestsRef->[$last] .= '>'; } } return grep /[<>]/, @nest; } # Given a filename with absolute path, returns the path relative to # $curoot as a list. sub pathSegments { my $filename = shift; my $filePath = File::Basename::dirname($filename); $filePath = substr($filePath, length($curoot) + 1); # +1 : '/' my @fPathSeg = split /\//, $filePath; return @fPathSeg; } # Returns list where # - the first element is the file name derived from the $roseFile argument; # - the further elements are the file content as list, one element per line, # without terminating "\n" at line ends. # The further elements will only be present if we are using "-i" (integrate # controlled units) and the file could be loaded. sub load { my $roseFile = shift; # given in Rose syntax (DOS-like) $roseFile =~ s/^"//; $roseFile =~ s/"$//; if ($nocv and $roseFile =~ /\.sub$/) { return ($roseFile); } if ($excludeControlledUnits or grep { $_ eq $roseFile } @exclusions) { return ($roseFile); } my $filename = $roseFile; $filename =~ s@\\\\@/@g; my $result_fname = $filename; if ($filename =~ /^\$(\w+)/) { my $pathVar = $1; unless (exists $ENV{$pathVar}) { report "load($roseFile) : Environment variable $pathVar is not defined"; return ($roseFile); } my $pathValue = $ENV{$pathVar}; $filename =~ s/\$(\w+)/$pathValue/; } unless (-e "$filename") { report("load($roseFile) : No such file $filename"); return ($roseFile); } open my $IN, '< :encoding(windows-1252)', $filename or die "Cannot open file $filename\n"; my($object, $name) = skipPetalHeader($IN, $filename); unless ($object) { report "$filename does not appear to be a Rose model file"; close $IN; return ($roseFile); } my @out; unless ($integrateControlledUnits) { dumpPetalHeader(\@out); push @out, "<$object name=$name"; } # The line "<$object name=$name" was already printed by the caller, as were the # lines with "is_unit" and "is_loaded". # In "-i" mode we need to skip the latter two lines. my $line; $line = getline($IN); if ($line =~ /^\s+is_unit\s+(\w+)/) { unless ($integrateControlledUnits) { push @out, ' is_unit="' . lc($1) . '"'; } $line = getline($IN); if ($line =~ /^\s+is_loaded\s+(\w+)/) { unless ($integrateControlledUnits) { push @out, ' is_loaded="' . lc($1) . '"'; } } else { report "load($roseFile) : Expecting is_loaded, found $line"; push @out, ""; } } else { report "load($roseFile) : Expecting is_unit, found $line\n"; push @out, ""; } push @referencingFile, $filename; # Load the rest of the file. push @out, parseNested($IN); close $IN; pop @referencingFile; unless ($integrateControlledUnits) { # Not using "-i" (integrate controlled units) push @out, ""; my $xmlFile = write_outfile($filename, \@out); report "load($roseFile) : Wrote file $xmlFile"; if ($relcup) { $filename .= ".xml"; my $basename = File::Basename::basename($filename); my @refPathSeg = pathSegments($referencingFile[-1]); my @fPathSeg = pathSegments($filename); my $equalSegments = 0; if (scalar(@refPathSeg) <= scalar(@fPathSeg)) { for (my $i = 0; $i < scalar(@refPathSeg); ++$i) { my $rSeg = $refPathSeg[$i]; my $fSeg = $fPathSeg[$i]; $rSeg eq $fSeg or last; $equalSegments = $i + 1; } if ($equalSegments) { splice(@fPathSeg, 0, $equalSegments); } my $relPath = ""; if (@fPathSeg) { $relPath = join('/', @fPathSeg) . '/'; } $result_fname = $relPath . $basename; } else { for (my $i = 0; $i < scalar(@fPathSeg); ++$i) { my $rSeg = $refPathSeg[$i]; my $fSeg = $fPathSeg[$i]; $rSeg eq $fSeg or last; $equalSegments = $i + 1; } if ($equalSegments) { # Example: # refPath = a/b/c/d/e/f/g # fPath = a/b/x/y/z # relPath = ../../../../../x/y/z splice(@fPathSeg, 0, $equalSegments); splice(@refPathSeg, 0, $equalSegments); } my $upDirs = "../" x scalar(@refPathSeg); my $relPath = join('/', @fPathSeg); $result_fname = $upDirs . $relPath . '/' . $basename; } } elsif ($curoot) { $result_fname = $xmlFile; } @out = (); } return ($result_fname, @out); } # Returns true if switch "-nopres" is used and the given attribute # identifies a diagram. sub diagramSuppression { my $attr = shift; $nopres or return 0; return grep { $attr eq $_ } ("logical_presentations", "statediagrams", "physical_presentations", "ProcsNDevs"); } sub hasUnterminatedString { my $line = shift; if ($line !~ /"/) { return 0; } my $len = length($line); my $in_string = 0; for (my $i = 0; $i < $len; ++$i) { my $c = substr($line, $i, 1); if ($c eq "\\") { if ($in_string) { if ($i == $len - 1) { return 1; } ++$i; } } elsif ($c eq '"') { $in_string = !$in_string; } } return $in_string; } # Argument : Input file handle. # Return value: # List of attributes or empty list in case of error. sub parseNested { my $IN = shift; my @attrs; my @nests; my $line; while (defined($line = getline($IN))) { if (hasUnterminatedString($line)) { my $l = getline($IN); report "Line has unterminated string: Appending following line ($l)"; $line .= ' ' . $l; } $line =~ s/\t/ /g; # Handle list types: if ($line =~ /^( +)(\w+) +\(list (\w+)\)(\)*)$/) { my($ind, $attr, $objType) = ($1, $2, $3); $closeParenth = $4; push @nests, "$gi$ind<$attr type=\"$objType\"/>"; if (closeScope(\@attrs, \@nests)) { return @attrs; } } elsif ($line =~ /^( +)(\w+) +\(list Compartment$/) { # Example: # compartmentItems (list Compartment ...) report "Not yet implemented: $2 (list Compartment ...)"; while (defined($line = getline($IN))) { $line =~ /\)$/ and last; } $line =~ s/^.*?(\)+)$/$1/; $line =~ s/\)$//; # remove one closing parenth (list Compartment) $closeParenth = $line; if (closeScope(\@attrs, \@nests)) { return @attrs; } } elsif ($line =~ /^( +)(\w+) +\(list( \w+)?$/) { my($ind, $attr, $objType) = ($1, $2, $3); my $objTypeClause = ""; if ($objType) { $objType =~ s/^ //; $objTypeClause = " type=\"$objType\""; } my $diagramListSuppressionStartIndex; if (diagramSuppression($attr)) { # The diagram list containers are: # logical_presentations, statediagrams, physical_presentations, ProcsNDevs. $diagramListSuppressionStartIndex = scalar(@nests); } push @nests, "$gi$ind<$attr$objTypeClause>"; push @nests, parseNested($IN); push @nests, "$gi$ind"; if ($diagramListSuppressionStartIndex) { gab("Suppressing $attr due to switch -nopres"); splice(@nests, $diagramListSuppressionStartIndex); } if (closeScope(\@attrs, \@nests)) { return @attrs; } # Handle object types: # Here are the possible object cases which must be handled. # Items in brackets are optional. # If multiple optional items appear then they appear in the order given # here, and they are syntactically distinguishable. # E.g. a Tag always begins with @ and can thus be distinguished from # a Name which always begins with ". # # 1. attribute ObjType [Name][Tag] # - Handles: ObjType, ObjType Name, ObjType Tag, ObjType Name Tag # - Note: Allow fuzz at Name (may contain embedded ") # # 2. ObjType Name Type Part [Tag] # - Note: Allow fuzz at Name (may contain embedded ") # - Note: This occurs only for "module" and "ModView" # # 3. ObjType Type Name Tag # - Note: Allow fuzz at Name (may contain embedded ") # # 4. ObjType [Name][Tag] # - Handles: ObjType, ObjType Name, ObjType Tag, ObjType Name Tag # - Note: Allow fuzz at Name (may contain embedded ") # Case 1: attribute ObjType [Name][Tag] # Examples: # action (object action "..." # ActionTime (object ActionTime # collaborators (list link_list # compartment (object Compartment # defaultFont (object Font # defaults (object defaults # Event (object Event "..." # Focus_Of_Control (object Focus_Of_Control "..." @[0-9]+ # font (object Font # label (object ItemLabel # label (object SegLabel @[0-9]+ # process_structure (object Processes # properties (object Properties # root_category (object Class_Category "Logical View" # root_subsystem (object SubSystem "Component View" # root_usecase_package (object Class_Category "Use Case View" # semantics (object Semantic_Info # sendEvent (object sendEvent # statediagram (object State_Diagram "..." # statemachine (object State_Machine # stereotype (object ItemLabel # stereotype (object SegLabel @[0-9]+ # sendEvent (object sendEvent } elsif ($line =~ /^( +)(\w+) +\(object (\w+)(.*)$/) { my($ind, $attr, $objType, $rest) = ($1, $2, $3, $4); gab "Case1: $attr (object $objType $rest"; my $nameClause = ""; my $tagClause = ""; if ($rest) { if ($rest =~ / +(@\d+)$/) { $tagClause = " tag=\"$1\""; $rest =~ s/ +@\d+$//; } if ($rest) { $rest =~ s/^ +"//; $rest =~ s/"$//; $nameClause = ' name="' . xmlEsc($rest) . '"'; } } my $suppressionStartIndex; if ( ($nocv && $attr eq "root_subsystem") # Component View || ($nopres && $attr eq "statediagram") ) { # State Diagram $suppressionStartIndex = scalar(@nests); } push @nests, "$gi$ind<$attr type=\"$objType\"$nameClause$tagClause"; my $haveNested = addNested(\@nests, $IN); if ($haveNested) { push @nests, "$gi$ind"; } else { $nests[-1] .= "/>"; } if ($suppressionStartIndex) { # root_subsystem (object SubSystem "Component View" # statediagram (object State_Diagram "" gab("Suppressing $attr due to switch -nocv"); splice(@nests, $suppressionStartIndex); } if (closeScope(\@attrs, \@nests)) { return @attrs; } # Case 2: ObjType Name Type Part [Tag] # The only observed examples are in object SubSystem: # - In physical_models, # (object module "..." "NotAModuleType" "NotAModulePart" # - In physical_presentations, # (object ModView "..." "NotAModuleType" "NotAModulePart" @123 } elsif ($line =~ /^( +)\(object (\w+) "(.*?)" ("[^"]*") ("[^"]*")( @\d+)?$/) { my($ind, $objType, $name, $type, $part, $tag) = ($1, $2, &xmlEsc($3), $4, $5, $6); gab "Case2: (object $objType \"$name\" $type $part$tag"; my $tagClause = ""; if ($tag) { $tag =~ s/^ //; $tagClause = " tag=\"$tag\""; } $is_module = ($objType eq "module"); push @nests, "$gi$ind<$objType name=\"$name\" type=$type part=$part$tagClause"; addNested(\@nests, $IN); push @nests, "$gi$ind"; $is_module = 0; if (closeScope(\@attrs, \@nests)) { return @attrs; } # Case 3: ObjType Type Name Tag # Examples: # (object ClassView "Class" "Logical View::..." @[0-9]+ # (object ClassView "Class" "Use Case View::..." @[0-9]+ # (object ClassView "Class" "..." @[0-9]+ # (object ClassView "ClassUtility" "Logical View::..." @[0-9]+ # (object ClassView "MetaClass" "Logical View::..." @[0-9]+ # (object StateView "StartState" "..." @[0-9]+ # (object StateView "Normal" "..." @[0-9]+ # (object StateView "EndState" "..." @[0-9]+ } elsif ($line =~ /^( +)\(object (\w+) ("[^"]*") "(.*?)" (@\d+)$/) { my($ind, $objType, $type, $name, $tag) = ($1, $2, $3, &xmlEsc($4), $5); gab "Case3: (object $objType $type \"$name\" $tag"; push @nests, "$gi$ind<$objType type=$type name=\"$name\" tag=\"$tag\""; addNested(\@nests, $IN); push @nests, "$gi$ind"; if (closeScope(\@attrs, \@nests)) { return @attrs; } # Case 4: ObjType [Name][Tag] # Examples: # (object action "..." # (object ActivityDiagram "..." # (object ActivityState "..." # (object ActivityStateView "..." @[0-9]+ # (object AssocAttachView "..." @[0-9]+ # (object Association "..." # (object AssociationViewNew "..." @[0-9]+ # (object AttachView "..." @[0-9]+ # (object Attribute # (object CategoryView "Logical View::..." @[0-9]+ # (object Class "..." # (object ClassAttribute "..." # (object Class_Category "..." # (object Class_Utility "..." # (object ClassDiagram "..." # (object DataFlowView "..." @[0-9]+ # (object Decision "..." # (object DecisionView "..." @[0-9]+ # (object Dependency_Relationship # (object DependencyView "..." @[0-9]+ # (object external_doc # (object ImportView "..." @[0-9]+ # (object Inheritance_Relationship # (object InheritTreeView "..." @[0-9]+ # (object InheritView "..." @[0-9]+ # (object Instantiated_Class "..." # (object Instantiated_Class_Utility "..." # (object InteractionDiagram "..." # (object InterMessView "..." @[0-9]+ # (object InterObjView "..." @[0-9]+ # (object Label @[0-9]+ # (object Link # (object LinkSelfView "..." @[0-9]+ # (object LinkView "..." @[0-9]+ # (object Mechanism @[0-9]+ # (object Message "..." # (object MessView "..." @[0-9]+ # (object Metaclass "..." # (object Module_Diagram "..." # (object ModVisView "..." @[0-9]+ # (object NoteView @[0-9]+ # (object Object "..." # (object ObjectDiagram "..." # (object ObjectView "..." @[0-9]+ # (object Operation "... # (object Parameter "..." # (object Parameterized_Class "..." # (object Parameterized_Class_Utility "..." # (object Partition "..." # (object Process_Diagram "Deployment View..." # (object Realize_Relationship # (object RealizeView "..." @[0-9]+ # (object Role "..." # (object RoleView "..." @[0-9]+ # (object SelfMessView "..." @[0-9]+ # (object SelfTransView "..." @[0-9]+ # (object sendEvent # (object State "..." # (object State_Diagram "..." # (object State "..." # (object State_Transition # (object SubSystem "..." # (object SubSysView "Component View..." @[0-9]+ # (object Swimlane "..." @[0-9]+ # (object SynchronizationState "..." # (object TransView "..." @[0-9]+ # (object UseCaseDiagram "..." # (object UseCase "..." # (object UseCaseView "Use Case View..." @[0-9]+ # (object Uses_Relationship # (object UsesView "..." @[0-9]+ # (object Visibility_Relationship } elsif ($line =~ /^( +)\(object (\w+)(.*)$/) { my($ind, $objType, $rest) = ($1, $2, $3); gab "Case4: (object $objType$rest"; my $nameClause = ""; my $tagClause = ""; if ($rest) { if ($rest =~ / +(@\d+)$/) { $tagClause = " tag=\"$1\""; $rest =~ s/ +@\d+$//; } if ($rest) { $rest =~ s/^ +"//; $rest =~ s/"$//; $nameClause = ' name="' . xmlEsc($rest) . '"'; } } elsif ($objType eq "Module_Visibility_Relationship") { # Module_Visibility_Relationship has a quidu. # This confuses the special transformation of SubSystem physical_models # unit_reference_list module attributes "class" and "quidu" into subtag # "assign" (see the case "Handle everything else" below). $is_Module_Visibility_Relationship = 1; } push @nests, "$gi$ind<$objType$nameClause$tagClause"; my $haveNested = addNested(\@nests, $IN); if ($haveNested) { push @nests, "$gi$ind"; } else { $nests[-1] .= "/>"; } $is_Module_Visibility_Relationship = 0; if ($gcmt) { $nests[-1] .= " $gcmt"; $gcmt = ""; } if (closeScope(\@attrs, \@nests)) { return @attrs; } # Handle value types: } elsif ($line =~ /( +)(\w+) +\(value (\w+) "([^"]*)"\)(\)*)$/) { my($ind, $attr, $type) = ($1, $2, $3); my $value = $4; $closeParenth = $5; $value = '"' . xmlEsc($value) . '"'; push @attrs, "$gi$ind$attr=$value"; if (closeScope(\@attrs, \@nests)) { return @attrs; } } elsif ($line =~ /( +)(\w+) +\(value Text *$/) { my($ind, $attr) = ($1, $2); my $value = ""; while (defined($line = getline($IN))) { if ($line =~ /^\s*\)(\)*)$/) { $closeParenth = $1; last; } $line =~ s/^\|//; $value .= xmlEsc($line) . ' '; } push @nests, "$gi$ind<$attr type=\"text\">$value"; if (closeScope(\@attrs, \@nests)) { return @attrs; } } elsif ($line =~ /^( +)value + \(([^)]+)\)(\)*)$/) { # attribute assignment my $ind = $1; my $value = xmlEsc($2); $closeParenth = $3; push @nests, "$gi$ind$value"; if (closeScope(\@attrs, \@nests)) { return @attrs; } # Multi line verbatim text is introduced by a standalone keyword. # The multi line text will be found on the lines following the # standalone keyword, and will be prefixed by "|" in column 1. # Examples of standalone keyword: # client # condition # Constraints # documentation # initv # label # PDL # supplier # title # type } elsif ($line =~ /^( +)(\w+) *$/) { my($ind, $attr) = ($1, $2); my $value = ""; while (defined($line = getline($IN))) { if ($line =~ /^\s*(\)*)$/) { $closeParenth = $1; last; } $line =~ s/^\|//; $value .= xmlEsc($line) . ' '; } push @nests, "$gi$ind<$attr type=\"text\">$value"; if (closeScope(\@attrs, \@nests)) { return @attrs; } # Handle location: } elsif ($line =~ /^( +)(\w+) +\(([-\d]+, [-\d]+)\)(\)*)$/) { # location my($ind, $attr, $value) = ($1, $2, $3); $closeParenth = $4; push @attrs, "$gi$ind$attr=\"$value\""; if (closeScope(\@attrs, \@nests)) { return @attrs; } # Handle point: } elsif ($line =~ /^( +)\(([-\d]+, [-\d]+)\)(\)*)$/) { # point my($ind, $value) = ($1, $2); $closeParenth = $3; push @attrs, "$gi$ind$value"; if (closeScope(\@attrs, \@nests)) { return @attrs; } # Handle everything else. # Examples: # abstract TRUE # anchor [0-9]+ # anchor_loc [0-9]+ # annotation [0-9]+ # AssociationClass "Logical View::..." # autoResize TRUE # bold FALSE # bottomMargin 0.500000 # category "Logical View" # charSet 162 # class "Logical View::..." # class "Use Case View::..." # client @[0-9]+ # client "Logical View::..." # client "$UNNAMED$123" # client_containment "By Value" # client_quidu "3CE2518A0352" [ 12 digit hex number ] # clipIconLabels TRUE # color [0-9]+ # concurrency "Sequential" # condition # condition "..." # Constraints "..." # Containment "By Reference" # creation FALSE # creationObj FALSE # DataFlowView @[0-9]+ # default_color FALSE # derived TRUE # dir 1 # dir -1 # dir "FromClientToSupplier" # dir "ToClientFromSupplier" # documentation "..." # drawSupplier @[0-9]+ # enforceClosureAutoLoad FALSE # exceptions "Logical View::..." # exportControl "Implementation" # exportControl "Private" # exportControl "Protected" # exportControl "Public" # external_doc_path "..." # face "Arial Narrow" # file_name "..." # file_name "$FRAMEWORK_PATH\\Shared Components\\org12.sub" # fill_color [0-9]+ # Focus_Entry @[0-9]+ # Focus_Src @[0-9]+ # frequency "Aperiodic" # frequency "Periodic" # friend TRUE # global TRUE # gridX [0-9]+ # gridY [0-9]+ # height [0-9]+ # hidden TRUE # icon "..." # icon_height [0-9]+ # icon_style "Icon" # icon_style "Label" # icon_style "None" # icon_width [0-9]+ # icon_y_offset [0-9]+ # IncludeAttribute TRUE # IncludeOperation TRUE # initv "..." # InterObjView @[0-9]+ # is_aggregate TRUE # is_loaded FALSE # is_navigable TRUE # is_unit TRUE # italics FALSE # justify 0 # label "..." # language "ANSI C++" # language "C++" # language "CORBA" # language "Java" # leftMargin 0.250000 # line_color [0-9]+ # line_style [0-9]+ # max_height [0-9]+ # max_width [0-9]+ # mechanism_ref @[0-9]+ # MessView @[0-9]+ # module "Component View::..." # multi FALSE # name "..." # Nested FALSE # nlines [0-9]+ # notation "Unified" # object_arc @[0-9]+ # Operation "..." # opExportControl "Implementation" # opExportControl "Private" # opExportControl "Public" # ordinal [0-9]+ # orientation 0 # origin_attachment (1110, 885) # origin_x [0-9]+ # origin_y [0-9]+ # pageOverlap 0.250000 # parameters "..." # Parent_View @[0-9]+ # pctDist 0.000170 # pctDist -0.001463 # persistence "Persistent" # persistence "Static" # persistence "Transient" # quid "............" [ 12 digit hex number ] # quidflow "............" [ 12 digit hex number ] # quidstate "............" [ 12 digit hex number ] # quidu "............" [ 12 digit hex number ] # result "..." # rightMargin 0.250000 # sequence "" # sequence "1.1.1.2" # showClassOfObject TRUE # ShowCompartmentStereotypes TRUE # showMessageNum 1 # ShowOperationSignature TRUE # size [0-9]+ # snapToGrid FALSE # State "..." # static TRUE # stereotype "..." # stereotype FALSE # strike FALSE # subobjects 0 # subsystem "Component View" # supplier @[0-9]+ # supplier "Logical View::..." # supplier "..." # supplier_quidu "............" [ 12 digit hex number ] # SuppressAttribute TRUE # SuppressOperation TRUE # sync_flow_direction [0-9]+ # synchronization "Return" # synchronization "Simple" # synchronization "Synchronous" # sync_is_horizontal FALSE # target "..." # terminal_attachment (1110, 803) # title # title "..." # tool "..." # topMargin 0.250000 # type "..." # uid 0 # underline FALSE # value "..." # when "Activity" # when "Entry" # when "Exit" # when "UponEvent" # width [0-9]+ # x_offset -0.080000 # x_offset FALSE # y_coord -[0-9]+ # y_coord [0-9]+ # y_offset 0.110000 # zoom [0-9]+ } elsif ($line =~ /^( +)(\w+) +(.+?)(\)*)$/) { # logical_models (list unit_reference_list # (object Class_Category "APF" # is_unit TRUE # is_loaded FALSE # file_name "$APF_ROOT\\APF\\APF.cat" # quid "4B04F9DD0110") my($ind, $attr) = ($1, $2); my $value = $3; $closeParenth = $4; gab "CatchAll: $attr $value"; if ($attr eq "file_name") { my $gi_save = $gi; if ($integrateControlledUnits) { $gi .= $ind; $gi =~ s/ $//; } else { $gi = ""; } my ($fnameOut, @controlled) = load($value); report "load($value) returns filename: $fnameOut"; $gi = $gi_save; if (@controlled) { if ($attrs[-1] =~ /is_loaded/) { # Change is_loaded="false" to is_loaded="true". # sub load skips the redundant lines at the beginning of the # controlled unit. if ($attrs[-1] =~ /false/) { $attrs[-1] =~ s/false/true/; # $attrs[-1] .= " "; } } else { report("Expecting is_loaded at " . $attrs[-1] . "\n"); } push @attrs, "$gi$ind$attr=\"$fnameOut\""; push @attrs, @controlled; # Skip tail push @attrs, "$gi$ind"; my $fname = $value; $fname =~ s@^.*[\\/]@@; $fname =~ s@"$@@; $gcmt = " "; if (closeScope(\@attrs, \@nests)) { return @attrs; } next; } $value = $fnameOut; } if ($value =~ /^"(.*?)"$/) { $value = xmlEsc($1); } elsif ($value eq 'FALSE' || $value eq 'TRUE') { $value = lc $value; } my $specialKey = ""; my $specialVal = ""; my $seen_module_quidu = 0; if ($is_module) { if (!$is_Module_Visibility_Relationship && $attr eq "class") { # SubSystem physical_models unit_reference_list module attributes "class" and # "quidu" may appear multiple times which is not legitimate for XML attributes. # Thus we transform them into attributes of synthetic nested tags. # The encapsulation in a synthetic XML element is done because class and quidu # always appear together as a pair. # $attrs[-1] .= '>'; $specialKey = "class"; $specialVal = $value; } elsif ($attr eq "quidu") { push @nests, "$gi$ind$value"; $seen_module_quidu = 1; } } elsif ($attr eq "module") { # Similar case in Class - see previous comment $specialKey = "module"; $specialVal = $value; } if ($specialKey) { # Read the quidu line. $line = getline($IN); if ($line =~ /^\s+quidu\s+"(\w+)"(\)*)$/) { $value = $1; $closeParenth = $2; push @nests, "$gi$ind"; } else { report "Expecting quidu after $specialKey \"$specialVal\", found $line"; } } elsif (!$seen_module_quidu) { push @attrs, "$gi$ind$attr=\"$value\""; } if (closeScope(\@attrs, \@nests)) { return @attrs; } } else { report "Not yet implemented: $line"; } } if (@nests) { if (@attrs and $attrs[-1] !~ />$/) { $attrs[-1] .= '>'; } dumpPetalHeader(\@attrs); push @attrs, @nests; } else { $attrs[-1] .= '/>'; dumpPetalHeader(\@attrs); } return @attrs; } sub closeScope { my($attrsRef, $nestsRef) = @_; $closeParenth or return 0; $closeParenth =~ s/.$//; if (@$attrsRef) { unless ($attrsRef->[-1] =~ />$/) { $attrsRef->[-1] .= '>'; } } dumpPetalHeader($attrsRef); if (@$nestsRef) { push @$attrsRef, @$nestsRef; } else { # report "closeScope: Empty nestsRef"; } return 1; } # Return input argument trimmed of whitespace at left sub ltrim { my $line = shift; $line =~ s/^\s+//; return $line; } sub write_outfile { my ($abspath_filename, $ref_to_lines) = @_; my $xmlFile = $abspath_filename; $xmlFile =~ s/\.mdl$//; $xmlFile .= ".xml"; if ($curoot) { my $path = $xmlFile; $path =~ s@/[^/]+$@@; my $rootLen = length($curoot); if (length($path) > $rootLen && substr($path, 0, $rootLen) eq $curoot) { $path = substr($path, $rootLen + 1); # +1 : skip '/' after $curoot unless (-e "$path") { File::Path::make_path($path); } my $basename = File::Basename::basename($xmlFile); $xmlFile = $path . '/' . $basename; } } open(OUT, '> :encoding(UTF-8)', $xmlFile) or die "Cannot open output file $xmlFile\n"; for (my $i = 0; $i < scalar(@$ref_to_lines); ++$i) { my $line = $ref_to_lines->[$i]; if (!$useSpacesForIndentation and $line =~ /^( {8} *)/) { my $indentation = $1; $indentation =~ s/ {8}/\t/g; $line =~ s/^ +//; $line = $indentation . $line; } if ($cta and $line =~ /^\s+[$i + 4] =~ /^\s+<\/Attribute>$/) { my $l1 = ltrim($ref_to_lines->[$i + 1]); my $l2 = ltrim($ref_to_lines->[$i + 2]); my $l3 = ltrim($ref_to_lines->[$i + 3]); my $ttLen = length($l1) + length($l2) + length($l3); if ($ttLen < 60 and $l1 =~ /^\w+="[\w. ]*"/ and $l2 =~ /^\w+="[\w. ]*"/ and $l3 =~ /^\w+="[\w. ]*"/) { $l3 =~ s/>$//; $line .= " $l1 $l2 $l3/>"; $i += 4; } } print OUT "$line\n"; } close OUT; return $xmlFile; } 1; # The End.