/[cvs]/nfo/perl/libs/Data/Mungle/Transform/Encode.pm
ViewVC logotype

Diff of /nfo/perl/libs/Data/Mungle/Transform/Encode.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by joko, Thu Dec 5 13:57:22 2002 UTC revision 1.6 by joko, Tue May 13 07:42:59 2003 UTC
# Line 1  Line 1 
1  ##############################################  ## -------------------------------------------------------------------------
2  #  ##  $Id$
3  #  $Id$  ## -------------------------------------------------------------------------
4  #  ##  $Log$
5  #  $Log$  ##  Revision 1.6  2003/05/13 07:42:59  joko
6  #  Revision 1.2  2002/12/05 13:57:22  joko  ##  + sub decode_hex_nybbles: e.g. required to decode binary data from cellular phones
7  #  + now able to export 'scalar2utf8'  ##
8  #  + comments  ##  Revision 1.5  2003/04/09 07:22:34  joko
9  #  ##  childObj2string now inside Encode.pm, renamed to 'twingle_reference'
10  #  Revision 1.1  2002/11/29 04:49:20  joko  ##
11  #  + initial check-in  ##  Revision 1.4  2003/03/27 15:17:07  joko
12  #  ##  namespace fixes for Data::Mungle::*
13  #  Revision 1.1  2002/10/10 03:26:00  cvsjoko  ##
14  #  + new  ##  Revision 1.3  2003/02/20 20:48:36  joko
15  #  ##  renamed methods
16  ##############################################  ##
17    ##  Revision 1.2  2002/12/05 13:57:22  joko
18    ##  + now able to export 'scalar2utf8'
19    ##  + comments
20    ##
21    ##  Revision 1.1  2002/11/29 04:49:20  joko
22    ##  + initial check-in
23    ##
24    ##  Revision 1.1  2002/10/10 03:26:00  cvsjoko
25    ##  + new
26    ## -------------------------------------------------------------------------
27    
28    
29  package Data::Transform::Encode;  package Data::Mungle::Transform::Encode;
30    
31  use strict;  use strict;
32  use warnings;  use warnings;
33    
34  require Exporter;  require Exporter;
35  our @ISA = qw( Exporter );  our @ISA = qw( Exporter );
36  our @EXPORT_OK = qw( &var2utf8 &var_utf2iso &scalar2utf8 );  our @EXPORT_OK = qw(
37      &latin_to_utf8
38      &latin_to_utf8_scalar
39      &utf8_to_latin
40      &utf8_to_latin_scalar
41      &twingle_reference
42      &decode_hex_nybbles
43    );
44    
45    
46  use Unicode::String qw(utf8 latin1);  use Unicode::String qw(utf8 latin1);
47    
48  # TODO: refactor using Greg London's "Iterate" from CPAN  # TODO: refactor using Greg London's "Iterate" from CPAN
49  sub var2utf8 {  sub latin_to_utf8 {
50    my $vref = shift;    my $vref = shift;
51    if (ref $vref eq 'HASH') {    if (ref $vref eq 'HASH') {
52      foreach (keys %{$vref}) {      foreach (keys %{$vref}) {
53        if ((ref $vref->{$_}) =~ m/ARRAY|HASH/) {        if ((ref $vref->{$_}) =~ m/ARRAY|HASH/) {
54          var2utf8($vref->{$_});          latin_to_utf8($vref->{$_});
55        } else {        } else {
56          $vref->{$_} = scalar2utf8($vref->{$_});          $vref->{$_} = latin_to_utf8_scalar($vref->{$_});
57        }        }
58      }      }
59    } elsif (ref $vref eq 'ARRAY') {    } elsif (ref $vref eq 'ARRAY') {
60      foreach (@{$vref}) {      foreach (@{$vref}) {
61        if (ref $_ ne 'SCALAR') {        if (ref $_ ne 'SCALAR') {
62          var2utf8($_);          latin_to_utf8($_);
63        } else {        } else {
64          $_ = scalar2utf8($_);          $_ = latin_to_utf8_scalar($_);
65        }        }
66      }      }
67    }    }
68        
69  }  }
70    
71  sub scalar2utf8 {  sub latin_to_utf8_scalar {
72    my $scalar = shift;    my $scalar = shift;
73    if ($scalar) {    if ($scalar) {
74      my $u = latin1($scalar);      my $u = latin1($scalar);
# Line 59  sub scalar2utf8 { Line 77  sub scalar2utf8 {
77  }  }
78    
79  # TODO: refactor using Greg London's "Iterate" from CPAN  # TODO: refactor using Greg London's "Iterate" from CPAN
80  sub var_utf2iso {  sub utf8_to_latin {
81    my $vref = shift;    my $vref = shift;
82    if (ref $vref eq 'HASH') {    if (ref $vref eq 'HASH') {
83      foreach (keys %{$vref}) {      foreach (keys %{$vref}) {
84        if ((ref $vref->{$_}) =~ m/ARRAY|HASH/) {        if ((ref $vref->{$_}) =~ m/ARRAY|HASH/) {
85          var_utf2iso($vref->{$_});          utf8_to_latin($vref->{$_});
86        } else {        } else {
87          $vref->{$_} = scalar2iso($vref->{$_});          $vref->{$_} = utf8_to_latin_scalar($vref->{$_});
88        }        }
89      }      }
90    } elsif (ref $vref eq 'ARRAY') {    } elsif (ref $vref eq 'ARRAY') {
91      foreach (@{$vref}) {      foreach (@{$vref}) {
92        if (ref $_ ne 'SCALAR') {        if (ref $_ ne 'SCALAR') {
93          var_utf2iso($_);          utf8_to_latin($_);
94        } else {        } else {
95          $_ = scalar2iso($_);          $_ = utf8_to_latin_scalar($_);
96        }        }
97      }      }
98    }    }
99        
100  }  }
101    
102  sub scalar2iso {  sub utf8_to_latin_scalar {
103    my $scalar = shift;    my $scalar = shift;
104    if ($scalar) {    if ($scalar) {
105      my $u = utf8($scalar);      my $u = utf8($scalar);
# Line 89  sub scalar2iso { Line 107  sub scalar2iso {
107    }    }
108  }  }
109    
110    
111    # encodes object-references to serialized string representations
112    # made up of:
113    #   - 'o_<classname>_<ref type>_<guid>'???
114    #   - 'o_{guid}_{classname}'!!!
115    
116    # TODO: enhance further!
117    # make it possible to twingle OID-, GUID- and/or other references
118    
119    sub twingle_reference {
120      my $obj = shift;
121      my $option = shift;
122      my $string = 'n/a';
123      
124      #if ($option == 1) {
125        if ((my $classname = ref $obj) && (my $guid = $obj->{guid})) {
126          $string = join('_', 'o', $guid, $classname);
127        }  
128      #}
129      
130      return $string;
131    }
132    
133    sub decode_hex_nybbles {
134      my $data = shift;
135      my @buf;
136      for (my $i = 0; $i <= length($data); $i = $i + 2) {
137        my $nybble = substr($data, $i, 2);
138        push @buf, chr(hex($nybble));
139      }
140      return join('', @buf);
141    }
142    
143    
144  1;  1;
145    __END__
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.6
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed