view release on metacpan or  search on metacpan

lib/App/cpanminus/fatscript.pm  view on Meta::CPAN

  }
  
  
  ###
  # Dumper functions:
  
  # Save an object to a file
  sub _dump_file {
      my $self = shift;
  
      require Fcntl;
  
      # Check the file
      my $file = shift or $self->_error( 'You did not specify a file name' );
  
      my $fh;
      # flock if available (or warn if not possible for OS-specific reasons)
      if ( _can_flock() ) {
          # Open without truncation (truncate comes after lock)
          my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
          sysopen( $fh, $file, $flags );
          unless ( $fh ) {
              $self->_error("Failed to open file '$file' for writing: $!");
          }
  
          # Use no translation and strict UTF-8
          binmode( $fh, ":raw:encoding(UTF-8)");
  
          flock( $fh, Fcntl::LOCK_EX() )
              or warn "Couldn't lock '$file' for reading: $!";
  
          # truncate and spew contents
          truncate $fh, 0;
          seek $fh, 0, 0;
      }
      else {
          open $fh, ">:unix:encoding(UTF-8)", $file;
      }
  
      # serialize and spew to the handle
      print {$fh} $self->_dump_string;
  
      # close the file (release the lock)
      unless ( close $fh ) {
          $self->_error("Failed to close file '$file': $!");
      }
  
      return 1;
  }
  
  # Save an object to a string
  sub _dump_string {
      my $self = shift;
      return '' unless ref $self && @$self;
  
      # Iterate over the documents
      my $indent = 0;
      my @lines  = ();
  
      eval {
          foreach my $cursor ( @$self ) {
              push @lines, '---';
  
              # An empty document
              if ( ! defined $cursor ) {
                  # Do nothing
  
              # A scalar document
              } elsif ( ! ref $cursor ) {
                  $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
  
              # A list at the root
              } elsif ( ref $cursor eq 'ARRAY' ) {
                  unless ( @$cursor ) {
                      $lines[-1] .= ' []';
                      next;
                  }
                  push @lines, $self->_dump_array( $cursor, $indent, {} );
  
              # A hash at the root
              } elsif ( ref $cursor eq 'HASH' ) {
                  unless ( %$cursor ) {
                      $lines[-1] .= ' {}';
                      next;
                  }
                  push @lines, $self->_dump_hash( $cursor, $indent, {} );
  
              } else {
                  die \("Cannot serialize " . ref($cursor));
              }
          }
      };
      if ( ref $@ eq 'SCALAR' ) {
          $self->_error(${$@});
      } elsif ( $@ ) {
          $self->_error($@);
      }
  
      join '', map { "$_\n" } @lines;
  }
  
  sub _has_internal_string_value {
      my $value = shift;
      my $b_obj = B::svref_2object(\$value);  # for round trip problem
      return $b_obj->FLAGS & B::SVf_POK();
  }
  
  sub _dump_scalar {
      my $string = $_[1];
      my $is_key = $_[2];
      # Check this before checking length or it winds up looking like a string!
      my $has_string_flag = _has_internal_string_value($string);
      return '~'  unless defined $string;
      return "''" unless length  $string;
      if (Scalar::Util::looks_like_number($string)) {
          # keys and values that have been used as strings get quoted
          if ( $is_key || $has_string_flag ) {
              return qq['$string'];
          }
          else {
              return $string;
          }
      }
      if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
          $string =~ s/\\/\\\\/g;
          $string =~ s/"/\\"/g;
          $string =~ s/\n/\\n/g;
          $string =~ s/[\x85]/\\N/g;
          $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
          $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
          return qq|"$string"|;
      }
      if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
          $QUOTE{$string}
      ) {
          return "'$string'";
      }
      return $string;
  }
  
  sub _dump_array {
      my ($self, $array, $indent, $seen) = @_;
      if ( $seen->{refaddr($array)}++ ) {
          die \"CPAN::Meta::YAML does not support circular references";
      }
      my @lines  = ();
      foreach my $el ( @$array ) {
          my $line = ('  ' x $indent) . '-';
          my $type = ref $el;