view release on metacpan or  search on metacpan

lib/Scalar/Quote.pm  view on Meta::CPAN

package Scalar::Quote;

our $VERSION = '0.26';

use 5.006;
use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'quote' => [ qw( quote quote_number quote_cut quote_start ) ],
		     'diff' => [ qw( str_diff str_diffix ) ],
		     'short' => [ qw( Q N S D ) ] );
our @EXPORT_OK = (@{$EXPORT_TAGS{quote}},
		  @{$EXPORT_TAGS{diff}},
		  @{$EXPORT_TAGS{short}});
our @EXPORT = qw();

# converts a char to its hex representation
sub char_to_hex ($ ) {
  my $c=ord(shift);
  sprintf( ($c < 256 ? '\x%02x' : '\x{%x}'), $c);
}

my %esc = ( "\n" => '\n',
	    "\t" => '\t',
	    "\r" => '\r',
	    "\\" => '\\\\',
	    "\a" => '\a',
	    "\b" => '\b',
	    "\f" => '\f' );

sub escape_char($ ) {
    my $char=shift;
    exists $esc{$char} ? $esc{$char} : char_to_hex($char)
}

# converts unprintable chars to \x{XX} and also escapes '"' and '\' if
# required
sub Q ($ ) {
  my $s=shift;
  defined $s or return 'undef';
  if ($s=~s/([^!#&()*+,\-.\/0123456789:;<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]\^_`abcdefghijklmnopqrstuvwxyz{|}~ ])/escape_char($1)/ge) {
    return qq("$s");
  }
  return qq('$s');
}
*quote=\&Q;

# compares two strings and returns the position where they start to be
# diferent, i.e diffix('good morning', 'good afternoon') == 5

sub str_diffix ($$) {
  my ($a, $b)=@_;

  $a='' unless defined $a;
  $b='' unless defined $b;

  return -1 if $a eq $b;

  # my $c;
  # for (my $i=0;;$i++) {
  #   $c=substr($a,$i,1);
  #   return $i
  #     unless ( $c ne '' and $c eq substr($b,$i,1));
  # }

  my $la = length $a;
  my $lb = length $b;

  my $min = $la < $lb ? $la : $lb;

  my $c = substr($a, 0, $min) ^ substr($b, 0, $min);
  if ($c =~ m/[^\0]/g) {
      return pos($c) - 1;
  }
  return $min;
}

# quote_cut($string, $start, $len), like substr() but adds a head and a tail
# to the substring reported how many chars have been left alone. It
# also escapes the string.

sub quote_cut ($$$ ) {
    return 'undef' unless defined $_[0];
    my (undef, $start, $len)=@_;
    my $end=length($_[0])-$len-$start;
    if ($end<0) {
	$start+=$end;
	$end=0;
    }
    if ($start<0) {
	$start=0;
    }
    my $s=sprintf("[%d chars omitted]", $start);
    if (length $s>=$start) {
	$len+=$start;
	$start=0;
	$s='';
    }
    my $e=sprintf("[%d chars omitted]", $end);
    if (length $e>=$end) {
	$len+=$end;
	$e='';
    }
    quote($s.substr($_[0], $start, $len).$e);
}


# escape and quote string start operator, like Q but truncates the
# string if it is to long.
sub S ($;$ ) {
  my $len=defined $_[1] ? $_[1] : 32;
  quote_cut ($_[0], 0, $len);
}
*quote_start=\&S;

my $number_re=qr/^\s*[+-]?(?:\d+|\d*\.\d*)(?i:E[+-]?\d+)?\s*$/;

# quote number
sub N ($ ) {
  no warnings;
  if (defined $_[0]) {
    if ($_[0]=~/$number_re/o) {
      return sprintf("%f", $_[0]);
    }
    return sprintf("%f (str: %s)", $_[0], S($_[0]));
  }
  'undef'
}
*quote_number=\&N;

# D computes the difference between two strings.
sub D ($$;$$ ) {
    no warnings 'uninitialized';
    return () if $_[0] eq $_[1];

    my $len=defined $_[3] ? $_[3] : 32;
    my $start=(defined $_[2] ? $_[2] : -8)
	+ str_diffix($_[0], $_[1]);
    my $a=quote_cut($_[0], $start, $len);
    my $b=quote_cut($_[1], $start, $len);

    return ($a, $b) if (wantarray);

    {
	no strict 'refs';
	my $caller = caller;
	my $pa=$caller."::a";
	my $pb=$caller."::b";
	${$pa}=$a;
	${$pb}=$b;
    }
    return 1;
}
*str_diff=\&D;




1;
__END__

=head1 NAME

Scalar::Quote - Utility functions to quote Perl strings

=head1 SYNOPSIS

  use Scalar::Quote ':short';
  $_=pack('c',rand 127) for (@a[0..1000]);
  $s1=join '', @a;
  $_=pack('c',rand 127) for (@b[0..1000]);
  $s2=join '', @b;
  $_=pack('c',rand 127) for (@c[0..40]);
  $s3=join '', @c;

  print "Q(\$s1)=",Q($s1),"\n";
  print "S(\$a)=",S($a),"\n";
  D($s3.$s1, $s3.$s2);
  print "$a is not the same as $b\n";
  print N(0), N(1), N(undef), N("hello"), "\n";

=head1 ABSTRACT

Several subrutines to quote scalars and spot differences between strings.

Mostly useful for debugging purposes.

=head1 DESCRIPTION

=over 4

=item quote_number($n)