view release on metacpan or  search on metacpan

Boulder/Stream.pm  view on Meta::CPAN

    foreach $key ($stone->tags) {
	@value = $stone->get($key);
	$key = $self->escapekey($key);
	foreach $value (@value) {
	    if (exists $value->{'.name'}) {
		$value = $self->escapeval($value);
		print $out ($indent,"$key$self->{delim}$value\n");
	    } else {
		print $out ($indent,"$key$self->{delim}$self->{subrec_start}\n");
		_write_nested($self,$level+1,$value);
	    }
	}
    }

    print $out ('  ' x ($level-1),$self->{'subrec_end'},"\n");
}

# Escape special characters.
sub escapekey {
    my($s,$toencode)=@_;
    return $toencode unless $s->{binary};
    my $specials=" $s->{delim}$s->{subrec_start}$s->{subrec_end}$s->{line_end}$s->{record_stop}%";
    $toencode=~s/([$specials])/uc sprintf("%%%02x",ord($1))/oge;
    return $toencode;
}

sub escapeval {
    my($s,$toencode)=@_;
    return $toencode unless $s->{binary};
    my $specials="$s->{delim}$s->{subrec_start}$s->{subrec_end}$s->{line_end}$s->{record_stop}%";
    $toencode=~s/([$specials])/uc sprintf("%%%02x",ord($1))/oge;
    return $toencode;
}

# Unescape special characters
sub unescapekey {
    unescape(@_);
}

sub unescapeval {
    unescape(@_);
}

# Unescape special characters
sub unescape {
    my($s,$todecode)=@_;
    return $todecode unless $s->{binary};
    $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
    return $todecode;
}

# utility routine to turn type globs, barewords, IO::File structs, etc into
# filehandles.
sub to_fh {
  my ($pack,$thingy,$write) = @_;
  return unless $thingy;
  return $thingy if defined fileno($thingy);

  my $caller;
  while (my $package = caller(++$caller)) {
    my $qualified_thingy = Symbol::qualify_to_ref($thingy,$package);
    return $qualified_thingy if defined fileno($qualified_thingy);
  }
  
  # otherwise try to open it as a file
  my $fh = Symbol::gensym();
  $thingy = ">$thingy" if $write;
  open ($fh,$thingy) || croak "$pack open of $thingy: $!";
  return \*$fh;
}

sub DESTROY {
    my $self = shift;
    my $out=$self->{OUT};
    print $out ($self->{'delim'},"\n")
	if !$self->{WRITE} && $self->{INVOKED} && !$self->{LEVEL} && $self->{'passthru'} && $self->{PASSED};
}


#####################################################################
###################### private routines #############################
sub rearrange {
    my($order,@param) = @_;
    return unless @param;
    my %param;

    if (ref $param[0] eq 'HASH') {
      %param = %{$param[0]};
    } else {
      return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');

      my $i;
      for ($i=0;$i<@param;$i+=2) {
        $param[$i]=~s/^\-//;     # get rid of initial - if present
        $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
      }

      %param = @param;                # convert into associative array
    }
    
    my(@return_array);
    
    local($^W) = 0;
    my($key)='';
    foreach $key (@$order) {
        my($value);
        if (ref($key) eq 'ARRAY') {
            foreach (@$key) {
                last if defined($value);
                $value = $param{$_};
                delete $param{$_};
            }
        } else {
            $value = $param{$key};
            delete $param{$key};
        }
        push(@return_array,$value);
    }
    push (@return_array,{%param}) if %param;
    return @return_array;