Changeset 2597 in ProjectBuilder for devel


Ignore:
Timestamp:
Apr 3, 2020, 8:07:12 PM (5 years ago)
Author:
Bruno Cornec
Message:

Fix YAML module usage in setupv

File:
1 edited

Legend:

Unmodified
Added
Removed

  • devel/pb-modules/lib/ProjectBuilder/YAML.pm

    r2495 r2597  
    22use strict;
    33use warnings;
     4use Data::Dumper;
     5
    46# Original is YAML::Tiny git description: v1.72-7-g8682f63
    57# We rename it here to allow embedded usage during setupv
    … …  
    1921# exports:
    2022
     23use vars qw(@ISA @EXPORT);
    2124use Exporter;
     25
    2226our @ISA       = qw{ Exporter  };
    23 our @EXPORT    = qw{ pb_Load pb_Dump };
    24 our @EXPORT_OK = qw{ pb_LoadFile pb_DumpFile freeze thaw };
     27our @EXPORT    = qw{ pb_Dump pb_LoadFile };
     28
     29
     30# The commented out form is simpler, but overloaded the Perl regex
     31# engine due to recursion and backtracking problems on strings
     32# larger than 32,000ish characters. Keep it for reference purposes.
     33# qr/\"((?:\\.|[^\"])*)\"/
     34my $re_capture_double_quoted;
     35my $re_capture_single_quoted;
     36# unquoted re gets trailing space that needs to be stripped
     37my $re_capture_unquoted_key ;
     38my $re_trailing_comment     ;
     39my $re_key_value_separator  ;
     40
     41sub pb_yaml_init {
     42$re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
     43$re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
     44# unquoted re gets trailing space that needs to be stripped
     45$re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
     46$re_trailing_comment      = qr/(?:\s+\#.*)?/;
     47$re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;
     48}
     49
    2550
    2651###
    … …  
    2853
    2954sub pb_Dump {
    30     return ProjectBuilder::YAML->new(@_)->_dump_string;
    31 }
    32 
    33 # XXX-INGY Returning last document seems a bad behavior.
    34 # XXX-XDG I think first would seem more natural, but I don't know
    35 # that it's worth changing now
    36 sub pb_Load {
    37     my $self = ProjectBuilder::YAML->_load_string(@_);
     55    pb_yaml_init();
     56    return _dump_string(@_);
     57}
     58
     59sub pb_LoadFile {
     60    pb_yaml_init();
     61    my $file = shift;
     62    my $ret = _load_file($file);
    3863    if ( wantarray ) {
    39         return @$self;
    40     } else {
    41         # To match YAML.pm, return the last document
    42         return $self->[-1];
    43     }
    44 }
    45 
    46 # XXX-INGY Do we really need freeze and thaw?
    47 # XXX-XDG I don't think so.  I'd support deprecating them.
    48 BEGIN {
    49     *freeze = \&pb_Dump;
    50     *thaw   = \&pb_Load;
    51 }
    52 
    53 sub pb_DumpFile {
    54     my $file = shift;
    55     return ProjectBuilder::YAML->new(@_)->_dump_file($file);
    56 }
    57 
    58 sub pb_LoadFile {
    59     my $file = shift;
    60     my $self = ProjectBuilder::YAML->_load_file($file);
    61     if ( wantarray ) {
    62         return @$self;
     64        return @$ret;
    6365    } else {
    6466        # Return only the last document to match YAML.pm,
    65         return $self->[-1];
    66     }
    67 }
    68 
    69 
    70 ###
    71 # Object Oriented API:
    72 
    73 # Create an empty ProjectBuilder::YAML object
    74 # XXX-INGY Why do we use ARRAY object?
    75 # NOTE: I get it now, but I think it's confusing and not needed.
    76 # Will change it on a branch later, for review.
    77 #
    78 # XXX-XDG I don't support changing it yet.  It's a very well-documented
    79 # "API" of ProjectBuilder::YAML.  I'd support deprecating it, but Adam suggested
    80 # we not change it until YAML.pm's own OO API is established so that
    81 # users only have one API change to digest, not two
    82 sub new {
    83     my $class = shift;
    84     bless [ @_ ], $class;
    85 }
    86 
    87 # XXX-INGY It probably doesn't matter, and it's probably too late to
    88 # change, but 'read/write' are the wrong names. Read and Write
    89 # are actions that take data from storage to memory
    90 # characters/strings. These take the data to/from storage to native
    91 # Perl objects, which the terms dump and load are meant. As long as
    92 # this is a legacy quirk to ProjectBuilder::YAML it's ok, but I'd prefer not
    93 # to add new {read,write}_* methods to this API.
    94 
    95 sub read_string {
    96     my $self = shift;
    97     $self->_load_string(@_);
    98 }
    99 
    100 sub write_string {
    101     my $self = shift;
    102     $self->_dump_string(@_);
    103 }
    104 
    105 sub read {
    106     my $self = shift;
    107     $self->_load_file(@_);
    108 }
    109 
    110 sub write {
    111     my $self = shift;
    112     $self->_dump_file(@_);
    113 }
    114 
    115 
     67        return $ret->[-1];
     68    }
     69}
    11670
    11771
    … …  
    146100};
    147101
    148 # The commented out form is simpler, but overloaded the Perl regex
    149 # engine due to recursion and backtracking problems on strings
    150 # larger than 32,000ish characters. Keep it for reference purposes.
    151 # qr/\"((?:\\.|[^\"])*)\"/
    152 my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
    153 my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
    154 # unquoted re gets trailing space that needs to be stripped
    155 my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
    156 my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
    157 my $re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;
    158 
    159 
    160102
    161103
    … …  
    173115# Create an object from a file
    174116sub _load_file {
    175     my $class = ref $_[0] ? ref shift : shift;
    176 
    177117    # Check the file
    178     my $file = shift or $class->_error( 'You did not specify a file name' );
    179     $class->_error( "File '$file' does not exist" )
     118    #print("SPECIAL: loadfile ".Dumper(@_)."\n");
     119    my $file = shift or _error( 'You did not specify a file name' );
     120    _error( "File '$file' does not exist" )
    180121        unless -e $file;
    181     $class->_error( "'$file' is a directory, not a file" )
     122    _error( "'$file' is a directory, not a file" )
    182123        unless -f _;
    183     $class->_error( "Insufficient permissions to read '$file'" )
     124    _error( "Insufficient permissions to read '$file'" )
    184125        unless -r _;
    185126
    … …  
    187128    open( my $fh, "<:unix:encoding(UTF-8)", $file );
    188129    unless ( $fh ) {
    189         $class->_error("Failed to open file '$file': $!");
     130        _error("Failed to open file '$file': $!");
    190131    }
    191132
    … …  
    203144    };
    204145    if ( my $err = $@ ) {
    205         $class->_error("Error reading from file '$file': $err");
     146        _error("Error reading from file '$file': $err");
    206147    }
    207148
    208149    # close the file (release the lock)
    209150    unless ( close $fh ) {
    210         $class->_error("Failed to close file '$file': $!");
    211     }
    212 
    213     $class->_load_string( $contents );
     151        _error("Failed to close file '$file': $!");
     152    }
     153
     154    _load_string( $contents );
    214155}
    215156
    216157# Create an object from a string
    217158sub _load_string {
    218     my $class  = ref $_[0] ? ref shift : shift;
    219     my $self   = bless [], $class;
     159        #print("SPECIAL: loadstring ".Dumper(@_)."\n");
     160    my $self   = [];
    220161    my $string = $_[0];
     162    print("string var: $string\n");
    221163    eval {
    222164        unless ( defined $string ) {
    … …  
    240182
    241183        # Check for some special cases
    242         return $self unless length $string;
     184        return [] unless length $string;
    243185
    244186        # Split the file into lines
    … …  
    258200                if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
    259201                    push @$self,
    260                         $self->_load_scalar( "$1", [ undef ], \@lines );
     202                        _load_scalar( "$1", [ undef ], \@lines );
    261203                    next;
    262204                }
    … …  
    281223                my $document = [ ];
    282224                push @$self, $document;
    283                 $self->_load_array( $document, [ 0 ], \@lines );
     225                _load_array( $document, [ 0 ], \@lines );
    284226
    285227            } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
    … …  
    287229                my $document = { };
    288230                push @$self, $document;
    289                 $self->_load_hash( $document, [ length($1) ], \@lines );
     231                _load_hash( $document, [ length($1) ], \@lines );
    290232
    291233            } else {
    … …  
    302244    my $err = $@;
    303245    if ( ref $err eq 'SCALAR' ) {
    304         $self->_error(${$err});
     246        _error(${$err});
    305247    } elsif ( $err ) {
    306         $self->_error($err);
     248        _error($err);
    307249    }
    308250
    … …  
    311253
    312254sub _unquote_single {
    313     my ($self, $string) = @_;
     255    my ($string) = @_;
    314256    return '' unless length $string;
    315257    $string =~ s/\'\'/\'/g;
    … …  
    318260
    319261sub _unquote_double {
    320     my ($self, $string) = @_;
     262    my ($string) = @_;
    321263    return '' unless length $string;
    322264    $string =~ s/\\"/"/g;
    … …  
    329271# Load a YAML scalar string to the actual Perl scalar
    330272sub _load_scalar {
    331     my ($self, $string, $indent, $lines) = @_;
    332 
     273        #print("SPECIAL: loadscalar ".Dumper(@_)."\n");
     274    my ($string, $indent, $lines) = @_;
     275
     276    #print("SPECIAL: string ***$string***\n");
    333277    # Trim trailing whitespace
    334278    $string =~ s/\s*\z//;
     279    #print("SPECIAL: string ***$string***\n");
    335280
    336281    # Explitic null/undef
    337282    return undef if $string eq '~';
    338283
     284    #print("SPECIAL: string ***$string***\n");
     285    #print("SPECIAL: re_capture_double_quoted ***$re_capture_double_quoted***\n");
     286    #print("SPECIAL: re_capture_single_quoted ***$re_capture_single_quoted***\n");
     287    #print("SPECIAL: re_trailing_comment ***$re_trailing_comment***\n");
    339288    # Single quote
    340289    if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
    341         return $self->_unquote_single($1);
    342     }
    343 
     290        return _unquote_single($1);
     291    }
     292
     293    #print("SPECIAL: string ***$string***\n");
    344294    # Double quote.
    345295    if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
    346         return $self->_unquote_double($1);
    347     }
    348 
     296        return _unquote_double($1);
     297    }
     298
     299    #print("SPECIAL: string ***$string***\n");
    349300    # Special cases
    350301    if ( $string =~ /^[\'\"!&]/ ) {
    … …  
    354305    return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
    355306
     307    #print("SPECIAL: string ***$string***\n");
    356308    # Regular unquoted string
    357309    if ( $string !~ /^[>|]/ ) {
    … …  
    363315    }
    364316
     317    #print("SPECIAL: string ***$string***\n");
    365318    # Error
    366319    die \"ProjectBuilder::YAML failed to find multi-line scalar content" unless @$lines;
    … …  
    388341# Load an array
    389342sub _load_array {
    390     my ($self, $array, $indent, $lines) = @_;
     343        #print("SPECIAL: loadarray ".Dumper(@_)."\n");
     344    my ($array, $indent, $lines) = @_;
    391345
    392346    while ( @$lines ) {
    … …  
    412366            $lines->[0] =~ s/-/ /;
    413367            push @$array, { };
    414             $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
     368            _load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
    415369
    416370        } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
    … …  
    428382                    # Naked indenter
    429383                    push @$array, [ ];
    430                     $self->_load_array(
     384                    _load_array(
    431385                        $array->[-1], [ @$indent, $indent2 ], $lines
    432386                    );
    … …  
    435389            } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
    436390                push @$array, { };
    437                 $self->_load_hash(
     391                _load_hash(
    438392                    $array->[-1], [ @$indent, length("$1") ], $lines
    439393                );
    … …  
    446400            # Array entry with a value
    447401            shift @$lines;
    448             push @$array, $self->_load_scalar(
     402            push @$array, _load_scalar(
    449403                "$2", [ @$indent, undef ], $lines
    450404            );
    … …  
    470424# Load a hash
    471425sub _load_hash {
    472     my ($self, $hash, $indent, $lines) = @_;
     426        #print("SPECIAL: loadhash ".Dumper(@_)."\n");
     427    my ($hash, $indent, $lines) = @_;
    473428
    474429    while ( @$lines ) {
    … …  
    496451            s/^\s*$re_capture_single_quoted$re_key_value_separator//
    497452        ) {
    498             $key = $self->_unquote_single($1);
     453            $key = _unquote_single($1);
    499454        }
    500455        elsif ( $lines->[0] =~
    501456            s/^\s*$re_capture_double_quoted$re_key_value_separator//
    502457        ) {
    503             $key = $self->_unquote_double($1);
     458            $key = _unquote_double($1);
    504459        }
    505460        elsif ( $lines->[0] =~
    … …  
    523478        if ( length $lines->[0] ) {
    524479            # Yes
    525             $hash->{$key} = $self->_load_scalar(
     480            $hash->{$key} = _load_scalar(
    526481                shift(@$lines), [ @$indent, undef ], $lines
    527482            );
    … …  
    535490            if ( $lines->[0] =~ /^(\s*)-/ ) {
    536491                $hash->{$key} = [];
    537                 $self->_load_array(
     492                _load_array(
    538493                    $hash->{$key}, [ @$indent, length($1) ], $lines
    539494                );
    … …  
    545500                } else {
    546501                    $hash->{$key} = {};
    547                     $self->_load_hash(
     502                    _load_hash(
    548503                        $hash->{$key}, [ @$indent, length($1) ], $lines
    549504                    );
    … …  
    560515# Dumper functions:
    561516
    562 # Save an object to a file
    563 sub _dump_file {
    564     my $self = shift;
    565 
    566     require Fcntl;
    567 
    568     # Check the file
    569     my $file = shift or $self->_error( 'You did not specify a file name' );
    570 
    571     my $fh;
    572     # flock if available (or warn if not possible for OS-specific reasons)
    573     if ( _can_flock() ) {
    574         # Open without truncation (truncate comes after lock)
    575         my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
    576         sysopen( $fh, $file, $flags )
    577             or $self->_error("Failed to open file '$file' for writing: $!");
    578 
    579         # Use no translation and strict UTF-8
    580         binmode( $fh, ":raw:encoding(UTF-8)");
    581 
    582         flock( $fh, Fcntl::LOCK_EX() )
    583             or warn "Couldn't lock '$file' for reading: $!";
    584 
    585         # truncate and spew contents
    586         truncate $fh, 0;
    587         seek $fh, 0, 0;
    588     }
    589     else {
    590         open $fh, ">:unix:encoding(UTF-8)", $file;
    591     }
    592 
    593     # serialize and spew to the handle
    594     print {$fh} $self->_dump_string;
    595 
    596     # close the file (release the lock)
    597     unless ( close $fh ) {
    598         $self->_error("Failed to close file '$file': $!");
    599     }
    600 
    601     return 1;
    602 }
    603 
    604517# Save an object to a string
    605518sub _dump_string {
     519        #print("SPECIAL: dumpstring ".Dumper(@_)."\n");
    606520    my $self = shift;
    607521    return '' unless ref $self && @$self;
    … …  
    621535            # A scalar document
    622536            } elsif ( ! ref $cursor ) {
    623                 $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
     537                $lines[-1] .= ' ' . _dump_scalar( $cursor );
    624538
    625539            # A list at the root
    … …  
    629543                    next;
    630544                }
    631                 push @lines, $self->_dump_array( $cursor, $indent, {} );
     545                push @lines, _dump_array( $cursor, $indent, {} );
    632546
    633547            # A hash at the root
    … …  
    637551                    next;
    638552                }
    639                 push @lines, $self->_dump_hash( $cursor, $indent, {} );
     553                push @lines, _dump_hash( $cursor, $indent, {} );
    640554
    641555            } else {
    … …  
    645559    };
    646560    if ( ref $@ eq 'SCALAR' ) {
    647         $self->_error(${$@});
     561        _error(${$@});
    648562    } elsif ( $@ ) {
    649         $self->_error($@);
     563        _error($@);
    650564    }
    651565
    … …  
    660574
    661575sub _dump_scalar {
     576        #print("SPECIAL: dumpscalar ".Dumper(@_)."\n");
    662577    my $string = $_[1];
    663578    my $is_key = $_[2];
    … …  
    693608
    694609sub _dump_array {
    695     my ($self, $array, $indent, $seen) = @_;
     610        #print("SPECIAL: dumparray ".Dumper(@_)."\n");
     611    my ($array, $indent, $seen) = @_;
    696612    if ( $seen->{refaddr($array)}++ ) {
    697613        die \"ProjectBuilder::YAML does not support circular references";
    … …  
    702618        my $type = ref $el;
    703619        if ( ! $type ) {
    704             $line .= ' ' . $self->_dump_scalar( $el );
     620            $line .= ' ' . _dump_scalar( $el );
    705621            push @lines, $line;
    706622
    … …  
    708624            if ( @$el ) {
    709625                push @lines, $line;
    710                 push @lines, $self->_dump_array( $el, $indent + 1, $seen );
     626                push @lines, _dump_array( $el, $indent + 1, $seen );
    711627            } else {
    712628                $line .= ' []';
    … …  
    717633            if ( keys %$el ) {
    718634                push @lines, $line;
    719                 push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
     635                push @lines, _dump_hash( $el, $indent + 1, $seen );
    720636            } else {
    721637                $line .= ' {}';
    … …  
    732648
    733649sub _dump_hash {
    734     my ($self, $hash, $indent, $seen) = @_;
     650        #print("SPECIAL: dumphash ".Dumper(@_)."\n");
     651    my ($hash, $indent, $seen) = @_;
    735652    if ( $seen->{refaddr($hash)}++ ) {
    736653        die \"ProjectBuilder::YAML does not support circular references";
    … …  
    739656    foreach my $name ( sort keys %$hash ) {
    740657        my $el   = $hash->{$name};
    741         my $line = ('  ' x $indent) . $self->_dump_scalar($name, 1) . ":";
     658        my $line = ('  ' x $indent) . _dump_scalar($name, 1) . ":";
    742659        my $type = ref $el;
    743660        if ( ! $type ) {
    744             $line .= ' ' . $self->_dump_scalar( $el );
     661            $line .= ' ' . _dump_scalar( $el );
    745662            push @lines, $line;
    746663
    … …  
    748665            if ( @$el ) {
    749666                push @lines, $line;
    750                 push @lines, $self->_dump_array( $el, $indent + 1, $seen );
     667                push @lines, _dump_array( $el, $indent + 1, $seen );
    751668            } else {
    752669                $line .= ' []';
    … …  
    757674            if ( keys %$el ) {
    758675                push @lines, $line;
    759                 push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
     676                push @lines, _dump_hash( $el, $indent + 1, $seen );
    760677            } else {
    761678                $line .= ' {}';
    … …  
    782699sub _error {
    783700    require Carp;
    784     $errstr = $_[1];
    785     $errstr =~ s/ at \S+ line \d+.*//;
     701    $errstr = $_[0];
     702    #print("SPECIAL: error: ".Dumper(@_)."\n");
     703    #$errstr =~ s/ at \S+ line \d+.*//;
    786704    Carp::croak( $errstr );
    787705}
Note: See TracChangeset for help on using the changeset viewer.