home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _3cb024d83cc03d252eff5a911e9dea34 < prev    next >
Text File  |  2004-06-01  |  23KB  |  912 lines
  1. package Unicode::String;
  2.  
  3. # Copyright 1997-1999, Gisle Aas.
  4.  
  5. use strict;
  6. use vars qw($VERSION @ISA @EXPORT_OK $UTF7_OPTIONAL_DIRECT_CHARS);
  7. use Carp;
  8.  
  9. require Exporter;
  10. require DynaLoader;
  11. @ISA = qw(Exporter DynaLoader);
  12.  
  13. @EXPORT_OK = qw(utf16 utf8 utf7 ucs2 ucs4 latin1 uchr uhex byteswap2 byteswap4);
  14.  
  15. $VERSION = '2.07'; # $Id: String.pm,v 1.27 2000/05/19 12:00:45 gisle Exp $
  16.  
  17. $UTF7_OPTIONAL_DIRECT_CHARS ||= 1;
  18.  
  19. bootstrap Unicode::String $VERSION;
  20.  
  21. use overload '""'   => \&as_string,
  22.          'bool' => \&as_bool,
  23.          '0+'   => \&as_num,
  24.          '.='   => \&append,
  25.              '.'    => \&concat,
  26.              'x'    => \&repeat,
  27.          '='    => \©,
  28.              'fallback' => 1;
  29.  
  30. my %stringify = (
  31.    unicode => \&utf16,
  32.    utf16   => \&utf16,
  33.    ucs2    => \&utf16,
  34.    utf8    => \&utf8,
  35.    utf7    => \&utf7,
  36.    ucs4    => \&ucs4,
  37.    latin1  => \&latin1,
  38.   'hex'    => \&hex,
  39. );
  40.  
  41. my $stringify_as = \&utf8;
  42.  
  43. # some aliases
  44. *ucs2 = \&utf16;
  45. *uhex = \&hex;
  46. *uchr = \&chr;
  47.  
  48. sub new
  49. {
  50.     #_dump_arg("new", @_);
  51.     my $class = shift;
  52.     my $str;
  53.     my $self = bless \$str, $class;
  54.     &$stringify_as($self, shift) if @_;
  55.     $self;
  56. }
  57.  
  58.  
  59. sub repeat
  60. {
  61.     my($self, $count) = @_;
  62.     my $class = ref($self);
  63.     my $str = $$self x $count;
  64.     bless \$str, $class;
  65. }
  66.  
  67.  
  68. sub _dump_arg
  69. {
  70.     my $func = shift;
  71.     print "$func(";
  72.     print join(",", map { if (defined $_) {
  73.                              my $x = overload::StrVal($_);
  74.                  $x =~ s/\n/\\n/g;
  75.                  $x = '""' unless length $x;
  76.                  $x;
  77.              } else {
  78.                  "undef"
  79.              }
  80.                         } @_);
  81.     print ")\n";
  82. }
  83.  
  84.  
  85. sub concat
  86. {
  87.     #_dump_arg("concat", @_);
  88.     my($self, $other, $reversed) = @_;
  89.     my $class = ref($self);
  90.     unless (UNIVERSAL::isa($other, 'Unicode::String')) {
  91.     $other = Unicode::String->new($other);
  92.     }
  93.     my $str = $reversed ? $$other . $$self : $$self . $$other;
  94.     bless \$str, $class;
  95. }
  96.  
  97.  
  98. sub append
  99. {
  100.     #_dump_arg("append", @_);
  101.     my($self, $other) = @_;
  102.     unless (UNIVERSAL::isa($other, 'Unicode::String')) {
  103.     $other = Unicode::String->new($other);
  104.     }
  105.     $$self .= $$other;
  106.     $self;
  107. }
  108.  
  109.  
  110. sub copy
  111. {
  112.     my($self) = @_;
  113.     my $class = ref($self);
  114.     my $copy = $$self;
  115.     bless \$copy, $class;
  116. }
  117.  
  118.  
  119. sub as_string
  120. {
  121.     #_dump_arg("as_string", @_);
  122.     &$stringify_as($_[0]);
  123. }
  124.  
  125.  
  126. sub as_bool
  127. {
  128.     # This is different from perl's normal behaviour by not letting
  129.     # a U+0030  ("0") be false.
  130.     my $self = shift;
  131.     $$self ? 1 : "";
  132. }
  133.  
  134.  
  135. sub as_num
  136. {
  137.     # Should be able to use the numeric property from Unidata
  138.     # in order to parse a large number of numbers.  Currently we
  139.     # only convert it to a plain string and let perl's normal
  140.     # num-converter do the job.
  141.     my $self = shift;
  142.     my $str = $self->utf8;
  143.     $str + 0;
  144. }
  145.  
  146.  
  147. sub stringify_as
  148. {
  149.     my $class;
  150.     if (@_ > 1) {
  151.     $class = shift;
  152.     $class = ref($class) if ref($class);
  153.     } else {
  154.     $class = "Unicode::String";
  155.     }
  156.     my $old = $stringify_as;
  157.     if (@_) {
  158.     my $as = shift;
  159.     croak("Don't know how to stringify as '$as'")
  160.         unless exists $stringify{$as};
  161.     $stringify_as = $stringify{$as};
  162.     }
  163.     $old;
  164. }
  165.  
  166.  
  167. sub utf16
  168. {
  169.     my $self = shift;
  170.     unless (ref $self) {
  171.     my $u = new Unicode::String;
  172.     $u->utf16($self);
  173.     return $u;
  174.     }
  175.     my $old = $$self;
  176.     if (@_) {
  177.     $$self = shift;
  178.     if ((length($$self) % 2) != 0) {
  179.         warn "Uneven UTF16 data" if $^W;
  180.         $$self .= "\0";
  181.     }
  182.     if ($$self =~ /^\xFF\xFE/) {
  183.         # the string needs byte swapping
  184.         $$self = pack("n*", unpack("v*", $$self));
  185.     }
  186.     }
  187.     $old;
  188. }
  189.  
  190.  
  191.  
  192. sub utf7   # rfc1642
  193. {
  194.     my $self = shift;
  195.     unless (ref $self) {
  196.     # act as ctor
  197.     my $u = new Unicode::String;
  198.     $u->utf7($self);
  199.     return $u;
  200.     }
  201.     my $old;
  202.     if (defined wantarray) {
  203.     # encode into $old
  204.     $old = "";
  205.     pos($$self) = 0;
  206.     my $len = length($$self);
  207.     while (pos($$self) < $len) {
  208.             if (($UTF7_OPTIONAL_DIRECT_CHARS &&
  209.          $$self =~ /\G((?:\0[A-Za-z0-9\'\(\)\,\-\.\/\:\?\!\"\#\$\%\&\*\;\<\=\>\@\[\]\^\_\`\{\|\}\s])+)/gc)
  210.             || $$self =~ /\G((?:\0[A-Za-z0-9\'\(\)\,\-\.\/\:\?\s])+)/gc)
  211.             {
  212.         #print "Plain ", utf16($1)->latin1, "\n";
  213.         $old .= utf16($1)->latin1;
  214.         }
  215.             elsif (($UTF7_OPTIONAL_DIRECT_CHARS &&
  216.                     $$self =~ /\G((?:[^\0].|\0[^A-Za-z0-9\'\(\)\,\-\.\/\:\?\!\"\#\$\%\&\*\;\<\=\>\@\[\]\^\_\`\{\|\}\s])+)/gsc)
  217.                    || $$self =~ /\G((?:[^\0].|\0[^A-Za-z0-9\'\(\)\,\-\.\/\:\?\s])+)/gsc)
  218.             {
  219.         #print "Unplain ", utf16($1)->hex, "\n";
  220.         if ($1 eq "\0+") {
  221.             $old .= "+-";
  222.         } else {
  223.             require MIME::Base64;
  224.             my $base64 = MIME::Base64::encode($1, '');
  225.             $base64 =~ s/=+$//;
  226.             $old .= "+$base64-";
  227.             # XXX should we determine when the final "-" is
  228.             # unnecessary? depends on next char not being part
  229.             # of the base64 char set.
  230.         }
  231.         } else {
  232.         die "This should not happen, pos=" . pos($$self) .
  233.                                             ":  "  . $self->hex . "\n";
  234.         }
  235.     }
  236.     }
  237.     
  238.     if (@_) {
  239.     # decode
  240.     my $len = length($_[0]);
  241.     $$self = "";
  242.     while (pos($_[0]) < $len) {
  243.         if ($_[0] =~ /\G([^+]+)/gc) {
  244.         $self->append(latin1($1));
  245.         } elsif ($_[0] =~ /\G\+-/gc) {
  246.         $$self .= "\0+";
  247.         } elsif ($_[0] =~ /\G\+([A-Za-z0-9+\/]+)-?/gc) {
  248.         my $base64 = $1;
  249.         my $pad = length($base64) % 4;
  250.         $base64 .= "=" x (4 - $pad) if $pad;
  251.         require MIME::Base64;
  252.         $$self .= MIME::Base64::decode($base64);
  253.         if ((length($$self) % 2) != 0) {
  254.             warn "Uneven UTF7 base64-data" if $^W;
  255.             chop($$self); # correct it
  256.         }
  257.             } elsif ($_[0] =~ /\G\+/gc) {
  258.         warn "Bad UTF7 data escape" if $^W;
  259.         $$self .= "\0+";
  260.         } else {
  261.         die "This should not happen " . pos($_[0]);
  262.         }
  263.     }
  264.     }
  265.     $old;
  266. }
  267.  
  268.  
  269. sub hex
  270. {
  271.     my $self = shift;
  272.     unless (ref $self) {
  273.     my $u = new Unicode::String;
  274.     $u->hex($self);
  275.     return $u;
  276.     }
  277.     my $old;
  278.     if (defined($$self) && defined wantarray) {
  279.     $old = unpack("H*", $$self);
  280.     $old =~ s/(....)/U+$1 /g;
  281.     $old =~ s/\s+$//;
  282.     }
  283.     if (@_) {
  284.     my $new = shift;
  285.     $new =~ tr/0-9A-Fa-f//cd;  # leave only hex chars
  286.     croak("Hex string length must be multiple of four")
  287.         unless (length($new) % 4) == 0;
  288.     $$self = pack("H*", $new);
  289.     }
  290.     $old;
  291. }
  292.  
  293.  
  294. sub length
  295. {
  296.     my $self = shift;
  297.     int(length($$self) / 2);
  298. }
  299.  
  300. sub byteswap
  301. {
  302.    my $self = shift;
  303.    byteswap2($$self);
  304.    $self;
  305. }
  306.  
  307. sub unpack
  308. {
  309.     my $self = shift;
  310.     unpack("n*", $$self)
  311. }
  312.  
  313.  
  314. sub pack
  315. {
  316.     my $self = shift;
  317.     $$self = pack("n*", @_);
  318.     $self;
  319. }
  320.  
  321.  
  322. sub ord
  323. {
  324.     my $self = shift;
  325.     return () unless defined $$self;
  326.  
  327.     my $array = wantarray;
  328.     my @ret;
  329.     my @chars;
  330.     if ($array) {
  331.         @chars = CORE::unpack("n*", $$self);
  332.     } else {
  333.     @chars = CORE::unpack("n2", $$self);
  334.     }
  335.  
  336.     while (@chars) {
  337.     my $first = shift(@chars);
  338.     if ($first >= 0xD800 && $first <= 0xDFFF) {     # surrogate
  339.         my $second = shift(@chars);
  340.         #print "F=$first S=$second\n";
  341.         if ($first >= 0xDC00 || $second < 0xDC00 || $second > 0xDFFF) {
  342.         carp(sprintf("Bad surrogate pair (U+%04x U+%04x)",
  343.                  $first, $second));
  344.         unshift(@chars, $second);
  345.         next;
  346.         }
  347.         push(@ret, ($first-0xD800)*0x400 + ($second-0xDC00) + 0x10000);
  348.     } else {
  349.         push(@ret, $first);
  350.     }
  351.     last unless $array;
  352.     }
  353.     $array ? @ret : $ret[0];
  354. }
  355.  
  356.  
  357. sub name
  358. {
  359.     my $self = shift;
  360.     require Unicode::CharName;
  361.     if (wantarray) {
  362.     return map { Unicode::CharName::uname($_) } $self->ord;
  363.     } else {
  364.         return Unicode::CharName::uname(scalar($self->ord));
  365.     }
  366. }
  367.  
  368.  
  369. sub chr
  370. {
  371.     my($self,$val) = @_;
  372.     unless (ref $self) {
  373.     # act as ctor
  374.     my $u = new Unicode::String;
  375.     return $u->uchr($self);
  376.     }
  377.     if ($val > 0xFFFF) {
  378.     # must be represented by a surrogate pair
  379.     return undef if $val > 0x10FFFF;  # Unicode limit
  380.     $val -= 0x10000;
  381.     my $h = int($val / 0x400) + 0xD800;
  382.     my $l = ($val % 0x400) + 0xDC00;
  383.     $$self = CORE::pack("n2", $h, $l);
  384.     } else {
  385.     $$self = CORE::pack("n", $val);
  386.     }
  387.     $self;
  388. }
  389.  
  390.  
  391. sub substr
  392. {
  393.     my($self, $offset, $length, $substitute) = @_;
  394.     $offset ||= 0;
  395.     $offset *= 2;
  396.     my $substr;
  397.     if (defined $substitute) {
  398.     unless (UNIVERSAL::isa($substitute, 'Unicode::String')) {
  399.         $substitute = Unicode::String->new($substitute);
  400.     }
  401.     if (defined $length) {
  402.         $substr = substr($$self, $offset, $length*2) = $$substitute;
  403.     } else {
  404.         $substr = substr($$self, $offset) = $$substitute;
  405.     }
  406.     } else {
  407.     if (defined $length) {
  408.         $substr = substr($$self, $offset, $length*2);
  409.     } else {
  410.         $substr = substr($$self, $offset);
  411.     }
  412.     }
  413.     bless \$substr, ref($self);
  414. }
  415.  
  416.  
  417. sub index
  418. {
  419.     my($self, $other, $pos) = @_;
  420.     $pos ||= 0;
  421.     $pos *= 2;
  422.     $other = Unicode::String->new($other) unless ref($other);
  423.     $pos++ while ($pos = index($$self, $$other, $pos)) > 0 && ($pos%2) != 0;
  424.     $pos /= 2 if $pos > 0;
  425.     $pos;
  426. }
  427.  
  428.  
  429. sub rindex
  430. {
  431.     my($self, $other, $pos) = @_;
  432.     $pos ||= 0;
  433.     die "NYI";
  434. }
  435.  
  436.  
  437. sub chop
  438. {
  439.     my $self = shift;
  440.     if (CORE::length $$self) {
  441.     my $chop = chop($$self);
  442.     $chop = chop($$self) . $chop;
  443.     return bless \$chop, ref($self);
  444.     }
  445.     undef;
  446. }
  447.  
  448.  
  449. # XXX: Ideas to be implemented
  450. sub scan;
  451. sub reverse;
  452.  
  453. sub lc;
  454. sub lcfirst;
  455. sub uc;
  456. sub ucfirst;
  457.  
  458. sub split;
  459. sub sprintf;
  460. sub study;
  461. sub tr;
  462.  
  463.  
  464. 1;
  465.  
  466. __END__
  467.  
  468. =head1 NAME
  469.  
  470. Unicode::String - String of Unicode characters (UCS2/UTF16)
  471.  
  472. =head1 SYNOPSIS
  473.  
  474.  use Unicode::String qw(utf8 latin1 utf16);
  475.  $u = utf8("The Unicode Standard is a fixed-width, uniform ");
  476.  $u .= utf8("encoding scheme for written characters and text");
  477.  
  478.  # convert to various external formats
  479.  print $u->ucs4;      # 4 byte characters
  480.  print $u->utf16;     # 2 byte characters + surrogates
  481.  print $u->utf8;      # 1-4 byte characters
  482.  print $u->utf7;      # 7-bit clean format
  483.  print $u->latin1;    # lossy
  484.  print $u->hex;       # a hexadecimal string
  485.  
  486.  # all these can be used to set string value or as constructor
  487.  $u->latin1("┼ vµre eller σ ikke vµre");
  488.  $u = utf16("\0┼\0 \0v\0µ\0r\0e");
  489.  
  490.  # string operations
  491.  $u2 = $u->copy;
  492.  $u->append($u2);
  493.  $u->repeat(2);
  494.  $u->chop;
  495.  
  496.  $u->length;
  497.  $u->index($other);
  498.  $u->index($other, $pos);
  499.  
  500.  $u->substr($offset);
  501.  $u->substr($offset, $length);
  502.  $u->substr($offset, $length, $substitute);
  503.  
  504.  # overloading
  505.  $u .= "more";
  506.  $u = $u x 100;
  507.  print "$u\n";
  508.  
  509.  # string <--> array of numbers
  510.  @array = $u->unpack;
  511.  $u->pack(@array);
  512.  
  513.  # misc
  514.  $u->ord;
  515.  $u = uchr($num);
  516.  
  517. =head1 DESCRIPTION
  518.  
  519. A I<Unicode::String> object represents a sequence of Unicode
  520. characters.  The Unicode Standard is a fixed-width, uniform encoding
  521. scheme for written characters and text.  This encoding treats
  522. alphabetic characters, ideographic characters, and symbols
  523. identically, which means that they can be used in any mixture and with
  524. equal facility.  Unicode is modeled on the ASCII character set, but
  525. uses a 16-bit encoding to support full multilingual text.
  526.  
  527. Internally a I<Unicode::String> object is a string of 2 byte values in
  528. network byte order (big-endian).  The class provide various methods to
  529. convert from and to various external formats, and all string
  530. manipulations are made on strings in this the internal 16-bit format.
  531.  
  532. The functions utf16(), utf8(), utf7(), ucs2(), ucs4(), latin1(),
  533. uchr() can be imported from the I<Unicode::String> module and will
  534. work as constructors initializing strings of the corresponding
  535. encoding.  The ucs2() and utf16() are really aliases for the same
  536. function.
  537.  
  538. The I<Unicode::String> objects overload various operators, so they
  539. will normally work like plain 8-bit strings in Perl.  This includes
  540. conversions to strings, numbers and booleans as well as assignment,
  541. concatenation and repetition.
  542.  
  543. =head1 METHODS
  544.  
  545. The following methods are available:
  546.  
  547. =over 4
  548.  
  549. =item Unicode::String->stringify_as( [$enc] )
  550.  
  551. This class method specify which encoding will be used when
  552. I<Unicode::String> objects are implicitly converted to and from plain
  553. strings.  It define which encoding to assume for the argument of the
  554. I<Unicode::String> constructor new().  Without an encoding argument,
  555. stringify_as() returns the current encoding ctor function.  The
  556. encoding argument ($enc) is a string with one of the following values:
  557. "ucs4", "ucs2", "utf16", "utf8", "utf7", "latin1", "hex".  The default
  558. is "utf8".
  559.  
  560. =item $us = Unicode::String->new( [$initial_value] )
  561.  
  562. This is the customary object constructor.  Without argument, it
  563. creates an empty I<Unicode::String> object.  If an $initial_value
  564. argument is given, it is decoded according to the specified
  565. stringify_as() encoding and used to initialize the newly created
  566. object.
  567.  
  568. Normally you create I<Unicode::String> objects by importing some of
  569. the encoding methods below as functions into your namespace and
  570. calling them with an appropriate encoded argument.
  571.  
  572. =item $us->ucs4( [$newval] )
  573.  
  574. The UCS-4 encoding use 32 bits per character.  The main benefit of this
  575. encoding is that you don't have to deal with surrogate pairs.  Encoded
  576. as a Perl string we use 4-bytes in network byte order for each
  577. character.
  578.  
  579. The ucs4() method always return the old value of $us and if given an
  580. argument decodes the UCS-4 string and set this as the new value of $us.
  581. The characters in $newval must be in the range 0x0 .. 0x10FFFF.
  582. Characters outside this range is ignored.
  583.  
  584. =item $us->ucs2( [$newval] )
  585.  
  586. =item $us->utf16( [$newval] )
  587.  
  588. The ucs2() and utf16() are really just different names for the same
  589. method.  The UCS-2 encoding use 16 bits per character.  The UTF-16
  590. encoding is identical to UCS-2, but includes the use of surrogate
  591. pairs.  Surrogates make it possible to encode characters in the range
  592. 0x010000 .. 0x10FFFF with the use of two consecutive 16-bit chars.
  593. Encoded as a Perl string we use 2-bytes in network byte order for each
  594. character (or surrogate code).
  595.  
  596. The ucs2() method always return the old value of $us and if given an
  597. argument set this as the new value of $us.
  598.  
  599. =item $us->utf8( [$newval] )
  600.  
  601. The UTF-8 encoding use 8-bit for the encoding of characters in the
  602. range 0x0 .. 0x7F, 16-bit for the encoding of characters in the range
  603. 0x80 .. 0x7FF, 24-bit for the encoding of characters in the range
  604. 0x800 .. 0xFFFF and 32-bit for characters in the range 0x01000
  605. .. 0x10FFFF.  Americans like this encoding, because plain US-ASCII
  606. characters are still US-ASCII.  Another benefit is that the character
  607. '\0' only occurs as the encoding of 0x0, thus the normal
  608. NUL-terminated strings (popular in the C programming language) can
  609. still be used.
  610.  
  611. The utf8() method always return the old value of $us encoded using
  612. UTF-8 and if given an argument decodes the UTF-8 string and set this as
  613. the new value of $us.
  614.  
  615. =item $us->utf7( [$newval] )
  616.  
  617. The UTF-7 encoding only use plain US-ASCII characters for the
  618. encoding.  This makes it safe for transport through 8-bit stripping
  619. protocols.  Characters outside the US-ASCII range are base64-encoded
  620. and '+' is used as an escape character.  The UTF-7 encoding is
  621. described in RFC1642.
  622.  
  623. The utf7() method always return the old value of $us encoded using
  624. UTF-7 and if given an argument decodes the UTF-7 string and set this as
  625. the new value of $us.
  626.  
  627. If the (global) variable $Unicode::String::UTF7_OPTIONAL_DIRECT_CHARS
  628. is TRUE, then a wider range of characters are encoded as themselves.
  629. It is even TRUE by default.  The characters affected by this are:
  630.  
  631.    ! " # $ % & * ; < = > @ [ ] ^ _ ` { | }
  632.  
  633. =item $us->latin1( [$newval] )
  634.  
  635. The first 256 codes of Unicode is identical to the ISO-8859-1 8-bit
  636. encoding, also known as Latin-1.  The latin1() method always return
  637. the old value of $us and if given an argument set this as the new
  638. value of $us.  Characters outside the 0x0 .. 0xFF range are ignored
  639. when returning a Latin-1 string.  If you want more control over the
  640. mapping from Unicode to Latin-1, use the I<Unicode::Map8> class.  This
  641. is also the way to deal with other 8-bit character sets.
  642.  
  643. =item $us->hex( [$newval] )
  644.  
  645. This method() return a plain ASCII string where each Unicode character
  646. is represented by the "U+XXXX" string and separated by a single space
  647. character.  This format can also be used to set the value of $us (in
  648. which case the "U+" is optional).
  649.  
  650. =item $us->as_string;
  651.  
  652. Converts a I<Unicode::String> to a plain string according to the
  653. setting of stringify_as().  The default stringify_as() method is
  654. "utf8".
  655.  
  656. =item $us->as_num;
  657.  
  658. Converts a I<Unicode::String> to a number.  Currently only the digits
  659. in the range 0x30 .. 0x39 are recognized.  The plan is to eventually
  660. support all Unicode digit characters.
  661.  
  662. =item $us->as_bool;
  663.  
  664. Converts a I<Unicode::String> to a boolean value.  Only the empty
  665. string is FALSE.  A string consisting of only the character U+0030 is
  666. considered TRUE, even if Perl consider "0" to be FALSE.
  667.  
  668. =item $us->repeat( $count );
  669.  
  670. Returns a new I<Unicode::String> where the content of $us is repeated
  671. $count times.  This operation is also overloaded as:
  672.  
  673.   $us x $count
  674.  
  675. =item $us->concat( $other_string );
  676.  
  677. Concatenates the string $us and the string $other_string.  If
  678. $other_string is not an I<Unicode::String> object, then it is first
  679. passed to the Unicode::String->new constructor function.  This
  680. operation is also overloaded as:
  681.  
  682.   $us . $other_string
  683.  
  684.  
  685. =item $us->append( $other_string );
  686.  
  687. Appends the string $other_string to the value of $us.  If
  688. $other_string is not an I<Unicode::String> object, then it is first
  689. passed to the Unicode::String->new constructor function.  This
  690. operation is also overloaded as:
  691.  
  692.   $us .= $other_string
  693.  
  694. =item $us->copy;
  695.  
  696. Returns a copy of the current I<Unicode::String> object.  This
  697. operation is overloaded as the assignment operator.
  698.  
  699. =item $us->length;
  700.  
  701. Returns the length of the I<Unicode::String>.  Surrogate pairs are
  702. still counted as 2.
  703.  
  704. =item $us->byteswap;
  705.  
  706. This method will swap the bytes in the internal representation of the
  707. I<Unicode::String> object.
  708.  
  709. Unicode reserve the character U+FEFF character as a byte order mark.
  710. This works because the swapped character, U+FFFE, is reserved to not
  711. be valid.  For strings that have the byte order mark as the first
  712. character, we can guaranty to get the byte order right with the
  713. following code:
  714.  
  715.    $ustr->byteswap if $ustr->ord == 0xFFFE;
  716.  
  717. =item $us->unpack;
  718.  
  719. Returns a list of integers each representing an UTF-16 character code.
  720.  
  721. =item $us->pack( @uchr );
  722.  
  723. Sets the value of $us as a sequence of UTF-16 characters with the
  724. characters codes given as parameter.
  725.  
  726. =item $us->ord;
  727.  
  728. Returns the character code of the first character in $us.  The ord()
  729. method deals with surrogate pairs, which gives us a result-range of
  730. 0x0 .. 0x10FFFF.  If the $us string is empty, undef is returned.
  731.  
  732. =item $us->chr( $code );
  733.  
  734. Sets the value of $us to be a string containing the character assigned
  735. code $code.  The argument $code must be an integer in the range 0x0
  736. .. 0x10FFFF.  If the code is greater than 0xFFFF then a surrogate pair
  737. created.
  738.  
  739. =item $us->name
  740.  
  741. In scalar context returns the official Unicode name of the first
  742. character in $us.  In array context returns the name of all characters
  743. in $us.  Also see L<Unicode::CharName>.
  744.  
  745. =item $us->substr( $offset, [$length, [$subst]] )
  746.  
  747. Returns a sub-string of $us.  Works similar to the builtin substr
  748. function, but because we can't make LVALUE subs yet, you have to pass
  749. the string you want to assign to the sub-string as the 3rd parameter.
  750.  
  751. =item $us->index( $other, [$pos] );
  752.  
  753. Locates the position of $other within $us, possibly starting the
  754. search at position $pos.
  755.  
  756. =item $us->chop;
  757.  
  758. Chops off the last character of $us and returns it (as a
  759. I<Unicode::String> object).
  760.  
  761. =back
  762.  
  763. =head1 FUNCTIONS
  764.  
  765. The following utility functions are provided.  They will be exported
  766. on request.
  767.  
  768. =over 4
  769.  
  770. =item byteswap2($str, ...)
  771.  
  772. This function will swap 2 and 2 bytes in the strings passed as
  773. arguments.  This can be used to fix up UTF-16 or UCS-2 strings from
  774. litle-endian systems.  If this function is called in void context,
  775. then it will modify its arguments in-place.  Otherwise, then swapped
  776. strings are returned.
  777.  
  778. =item byteswap4($str, ...)
  779.  
  780. The byteswap4 function works similar to byteswap2, but will reverse
  781. the order of 4 and 4 bytes.  Can be used to fix litle-endian UCS-4
  782. strings.
  783.  
  784. =back
  785.  
  786. =head1 SEE ALSO
  787.  
  788. L<Unicode::CharName>,
  789. L<Unicode::Map8>,
  790. http://www.unicode.org/
  791.  
  792. =head1 COPYRIGHT
  793.  
  794. Copyright 1997-2000 Gisle Aas.
  795.  
  796. This library is free software; you can redistribute it and/or
  797. modify it under the same terms as Perl itself.
  798.  
  799. =cut
  800.  
  801.  
  802. #
  803. # Some old code that is not used any more (because the methods are
  804. # now implemented as XS) and which I did not want to throw away yet.
  805. #
  806.  
  807. sub ucs4_inperl
  808. {
  809.     my $self = shift;
  810.     unless (ref $self) {
  811.     my $u = new Unicode::String;
  812.     $u->ucs4($self);
  813.     return $u;
  814.     }
  815.     my $old = pack("N*", $self->ord);
  816.     if (@_) {
  817.     $$self = "";
  818.     for (unpack("N*", shift)) {
  819.         $self->append(uchr($_));
  820.     }
  821.     }
  822.     $old;
  823. }
  824.  
  825.  
  826. sub utf8_inperl
  827. {
  828.     my $self = shift;
  829.     unless (ref $self) {
  830.     # act as ctor
  831.     my $u = new Unicode::String;
  832.     $u->utf8($self);
  833.     return $u;
  834.     }
  835.  
  836.     my $old;
  837.     if (defined($$self) && defined wantarray) {
  838.     # encode UTF-8
  839.     my $uc;
  840.     for $uc (unpack("n*", $$self)) {
  841.         if ($uc < 0x80) {
  842.         # 1 byte representation
  843.         $old .= chr($uc);
  844.         } elsif ($uc < 0x800) {
  845.         # 2 byte representation
  846.         $old .= chr(0xC0 | ($uc >> 6)) .
  847.                         chr(0x80 | ($uc & 0x3F));
  848.         } else {
  849.         # 3 byte representation
  850.         $old .= chr(0xE0 | ($uc >> 12)) .
  851.                 chr(0x80 | (($uc >> 6) & 0x3F)) .
  852.             chr(0x80 | ($uc & 0x3F));
  853.         }
  854.     }
  855.     }
  856.  
  857.     if (@_) {
  858.     if (defined $_[0]) {
  859.         $$self = "";
  860.         my $bytes = shift;
  861.         $bytes =~ s/^[\200-\277]+//;  # can't start with 10xxxxxx
  862.         while (length $bytes) {
  863.         if ($bytes =~ s/^([\000-\177]+)//) {
  864.             $$self .= pack("n*", unpack("C*", $1));
  865.         } elsif ($bytes =~ s/^([\300-\337])([\200-\277])//) {
  866.             my($b1,$b2) = (ord($1), ord($2));
  867.             $$self .= pack("n", (($b1 & 0x1F) << 6) | ($b2 & 0x3F));
  868.         } elsif ($bytes =~ s/^([\340-\357])([\200-\277])([\200-\277])//) {
  869.             my($b1,$b2,$b3) = (ord($1), ord($2), ord($3));
  870.             $$self .= pack("n", (($b1 & 0x0F) << 12) |
  871.                                         (($b2 & 0x3F) <<  6) |
  872.                          ($b3 & 0x3F));
  873.         } else {
  874.             croak "Bad UTF-8 data";
  875.         }
  876.         }
  877.     } else {
  878.         $$self = undef;
  879.     }
  880.     }
  881.  
  882.     $old;
  883. }
  884.  
  885.  
  886.  
  887.  
  888. sub latin1_inperl
  889. {
  890.     my $self = shift;
  891.     unless (ref $self) {
  892.     # act as ctor
  893.     my $u = new Unicode::String;
  894.     $u->latin1($self);
  895.     return $u;
  896.     }
  897.  
  898.     my $old;
  899.     # XXX: should really check that none of the chars > 256
  900.     $old = pack("C*", unpack("n*", $$self)) if defined $$self;
  901.  
  902.     if (@_) {
  903.     # set the value
  904.     if (defined $_[0]) {
  905.         $$self = pack("n*", unpack("C*", $_[0]));
  906.     } else {
  907.         $$self = undef;
  908.     }
  909.     }
  910.     $old;
  911. }
  912.