moved nonpb.pm

[PsN.git] / lib / model / problem / record_subs.pm

# {{{ new
start new
    {
      # To construct an option you inly need to suply an array of
      # strings containg the record block. _read_option then parses
      # those strings.
      $this -> _read_options;
      delete $this -> {'record_arr'};
    }
end new
# }}}

# {{{ option_count

start option_count
    {
      # record::option_count returns the number of options of the
      # record.

      $return_value = 0;
      if( defined $self -> {'options'} )
          $return_value += @{$self -> {'options'}};
    }
end option_count

# }}}

# {{{ remove_option

start remove_option

my @options = @{$self -> {'options'}};
my @new_options = ();
foreach my $option ( @options ) {
  next if ( $option -> name eq $name );    
  
  next if ( $fuzzy_match and index( $name, $option -> name ) > -1 );

  push( @new_options, $option );
}
$self -> {'options'} = \@new_options;
end remove_option

# }}} remove_option

# {{{ _add_option
start _add_option
      {
        # Create a new option. $option_string should be of the form
        # "option=value". TODO catch any error from below.
        my $opt_obj = 
            model::problem::record::option -> new ( option_string => $option_string );
        push( @{$self -> {'options'}}, $opt_obj ) if( $opt_obj ); 
      }
end _add_option
# }}}

# {{{ _read_options

start _read_options
    {
      #
      # record::_read_options
      #

      # This is a tricky method that parses options. The basic parsing
      # is real easy, it loops over the records strings, for each
      # string it looks for options of the form "option=value" or
      # "option", those substrings are then used to creat options. But
      # while the parser does this it keeps count of the number of
      # options it has parsed, and pushes it on the "print_order"
      # array (which has a bit missleading name) when it finds a
      # comment. This is then used to remember where comments appear
      # in the NONMEM modelfile. Unfortunataly this only holds for
      # ordinary records, code records are cut verbatim from the
      # modelfile, so they will also have their comments in place, but
      # init records will loose any comments associated with them.

      # TODO This is a hack, I admit, a nicer way would be to store
      # comments with the option it was found near and defer
      # formatting to the option class.

      my @row = ();
      my $order = 0;
    
      # Loop over all given strings.
      for( my $i = 0; $i <= $#{$self -> {'record_arr'}}; $i++ ) {
        # Store it in $_ for all string matching to look nice
        $_ = $self -> {'record_arr'} -> [$i];

        if( /^\s*(\;.*)$/ ) {
          # This is a comment on a line of its own.
          if( $order == 0 ){
            push(@{$self -> {'comment'}}, $1 . "\n");
          } else {
            push(@{$self -> {'comment'}},"\n" . $1 . "\n");
          }
          # Record after which option the comment appeared.
          push( @{$self -> {'print_order'}}, $order );
        } else {
          # Get rid of $RECORD
          s/^\s*\$\w+//;
          # remove spaces near '=' and ','
          s/\s*([\=\,])\s*/$1/g;
          # remove spaces near paranthesis
          s/\s*\)/\)/g;
          s/\(\s*/\(/g;
          
          # Find trailing comments.
          my $comment;
          if( /(\;.*)$/ ) {
            # We find comments here, but we add it to 'the comment'
            # member after we have parsed all options. Only so we can
            # now how many options we found.

            $comment = ' ' . $1 . "\n";
            # Get rid of trailing comments
            s/\;.*$//g;
          }
          @row = split;
          for ( @row ) {
            # Create options.
            $self -> _add_option( option_string => $_ );
            $order++;
          }
          if( length( $comment ) > 0 ) {
            # This is a comment at the end of a line.
            push( @{$self -> {'comment'}},' ' . $1 . "\n" );
            push( @{$self -> {'print_order'}}, $order );
          }
        }
      }
    }
end _read_options

# }}}

# {{{ _format_record
start _format_record
      {

        # record::format_record
        # 

        # This method might be even more trickier than _read_options,
        # but don't worry, I'll walk you through it. You should read
        # the comments in _read_options first though, it might help.
        
        # Get the recordname from the class name.
        my @class_names = split('::',ref($self));
        my $fname = uc(pop(@class_names));

        # Get some members from the object.
        my @print_order = defined $self -> {'print_order'} ? @{$self -> {'print_order'}} : ();  
        my @comments = defined($self -> {'comment'}) ? @{$self -> {'comment'}} : () ;    
        my @options = defined($self -> {'options'}) ? @{$self -> {'options'}} : ();

        # Each element of @print_order is a number which says how many
        # options(since the previous comment was printed) that should
        # be processed before the next comment should be
        # printed. There will be one element in print order for each
        # comment. So here we intialize $opts_before_comment which is
        # the current number of options we should process. If
        # $opts_before_comment is -1 no more comments will be expected
        # nor printed.

        my $opts_before_comment = scalar @print_order > 0 ? shift @print_order : -1;

        # $last_is_option is a  boolean which is true if  we printed a
        # option in the last iteration  of the loop below and false if
        # we printed a comment. It is  used to see if we need to print
        # an extra  "\n" since comments  is expected to have their own
        # "\n" while options don't

        my $last_is_option = 1;
        my $line = 0;

        # Loop over all options. Actually we loop one step to long,
        # since we might have comments after the last option.
        for( my $i = 0; $i <= scalar @options; $i++ ){

          # See if we have processed enough options to print
          # commments. It is a loop since we might have multiple lines
          # of comments.
          while( $i == $opts_before_comment ){
            my $comment = shift(@comments);
            # Check and add a linebreak if necessarry.
            if ( length( $formatted[$line].' '.$comment ) > 70 ) {
              $formatted[$line] .= "\n";
              $line++;
            }
            # add the comment
            $formatted[$line++] .= $comment;

            # If we expect more options ($i <= $#options) and we have
            # printed the recordname ($i > 0) we indent before
            # printing the next option.
            if( $i <= $#options and $i > 0 ){
              $formatted[$line] .= ' ' x 11;
            }
            
            if( scalar @print_order > 0 ) {
              $opts_before_comment = shift @print_order;
            } else {
              unless( scalar @comments > 0 ){ 

                # If we have more comments, it likely mean that
                # someone has appended comments manually. TODO This
                # might become a mess and we should probably add a
                # feature to add commments before or after the record.

                $opts_before_comment = -1; 
              }
            }

            $last_is_option = 0;
          }

          # Print the record name (with indentation)
          if( $i == 0 ){
            push( @formatted , "\$".$fname . ' ' x (10 - length($fname)) );
          }
          
          # Check that we have not processed all options.
          if( $i <= $#options ){
            my $option = $options[$i];
            # Let the option class format the option.
            my $foption = $option -> _format_option;
            
            # Check and add linebreak if necesary.
            if ( length( $formatted[$line].' '.$foption ) > 70 ) {
              $formatted[$line] .= "\n";
              $line++;
              # Indent for next option
              push( @formatted, ' ' x 11 );
            }
            
            $formatted[$line] .= ' '.$foption;
            $last_is_option = 1;
          } 
        }

        # Print a line break if the last item was an option (as oposed
        # to a comment.
        if( $last_is_option ){
          $formatted[$line] .= "\n";
        }
      }
end _format_record
# }}}