Mungle/Compare/Struct.pm

##    --------------------------------------------------------------------------------
##    $Id: Struct.pm,v 1.7 2004/07/07 03:13:43 joko Exp $
##    --------------------------------------------------------------------------------
##    $Log: Struct.pm,v $
##    Revision 1.7  2004/07/07 03:13:43  joko
##    minor fix for "sub isEmpty"
##
##    Revision 1.6  2004/05/12 13:53:19  jonen
##    + bugfix related to declaration of arrays,
##        solved error: 'Bizarre copy of ARRAY in aassign at...'
##
##    Revision 1.5  2003/03/27 15:17:05  joko
##    namespace fixes for Data::Mungle::*
##
##    Revision 1.4  2002/12/19 01:06:27  joko
##    + fixed isEmpty with ARRAYs
##
##    Revision 1.3  2002/12/13 21:47:04  joko
##    + fixes to 'sub isEmpty'
##
##    Revision 1.2  2002/12/05 07:56:34  joko
##    + updated/enhanced isEmpty (hacky?)
##
##    Revision 1.1  2002/11/29 04:49:30  joko
##    + initial check-in
##
##    --------------------------------------------------------------------------------


package Data::Mungle::Compare::Struct;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( 
  &getRelations 
  &getDifference 
  &isEmpty
);

use Data::Dumper;

sub getRelations {
  my $a_ref = shift;
  my $b_ref = shift;
  my @a = @{$a_ref};
  my @b = @{$b_ref};

  # BUGFIX 2004-05-12: following declaration of arrays occures an strange perl error:
  # 'Bizarre copy of ARRAY in aassign at ..<PATH_TO>/<THIS_FILE> line <NEXT LINE>' 
  # (at PERL 5.8.4, Debian/unstable/experimental)
  #
  #my @isect = my @diff = my @union = ();
  #
  # so use normal declaration instead!!
  my @isect = ();
  my @diff = ();
  my @union = ();

  my $e;
  my %count;
  
  foreach $e (@a, @b) { $count{$e}++ }

  foreach $e (keys %count) {
      push(@union, $e);
      push @{ $count{$e} == 2 ? \@isect : \@diff }, $e;
  }

  # bugfix: a diff is no diff if we don't even have an isect
  @diff = undef if !@isect;
  
  my $result = {
    union => \@union,
    isect => \@isect,
    diff => \@diff,
  };
  
  return $result;

}

sub getDifference {
  my $res = getRelations(shift, shift);
  return $res->{diff};
}

sub isEmpty {

  my $var = shift;
  my $ref = ref($var);
  my $reftype = '';
  $reftype = attributes::reftype($var) if $ref;

  #print "isEmpty is parsing variable ( ref $ref reftype $reftype )", "\n";
  
#print Dumper($ref);
  
  my $found;

  if ($ref eq 'Set::Object') {
    $found = 1;
#print "members:", "\n";
#print Dumper($var->members());
#print "\n";
    my $tc = { ok => 0, count => 0, empty => 0 };
    foreach ($var->members()) {
#print "member!!", "\n";
      #print "empty: ", isEmpty($_), "\n";
      #$tc->{ok} = 1;
      $tc->{count}++;
      $tc->{empty}++ if isEmpty($_);
      #return $result if $result;
    }

#print Dumper($tc);
    
    return 1 if ($tc->{count} == $tc->{empty});
    return 0;
    
  }

  if ($reftype eq 'ARRAY') {
    my @arr = @$var;
    my $isReallyEmpty = ($#arr == -1 ? 1 : 0);
    return 1 if $isReallyEmpty;
    $found = 1;
    foreach (@arr) {
      #return 0 if defined $_;
      #return 1 if isEmpty($_);
      return 0 if !isEmpty($_);
    }

  } elsif ($reftype eq 'HASH') {
    my $empty = 1;
    $found = 1;
    foreach (keys %$var) {
# TODO: review and fix this!
=pod
      # recursion
      if (ref $var->{$_} eq 'Set::Object') {
        print "==========set", "\n";
        if (isEmpty($var->{$_})) {
          return 0;
          #next;
        }
      }
=cut
      next if ref $var->{$_} eq 'Set::Object';
      #return 0 if defined $var->{$_};
      #return 1 if isEmpty($var->{$_});
      my $elem_empty = isEmpty($var->{$_});
      
#print "elem: $elem_empty\n";
      $empty &&= $elem_empty;
    }
    return $empty;
    #return 0;
  
  # check for empty string
  } elsif (defined $var) {
    $found = 1;
    return 0 if $var ne '';
  }
  
  if (!$found) {
    #print "isEmpty could not parse variable ( ref $ref reftype $reftype )", "\n";
  }

  #print "EMPTY!!!", "\n";

  return 1;
  
}

1;
1	joko	1.1	## --------------------------------------------------------------------------------
2	jonen	1.8	## $Id: Struct.pm,v 1.7 2004/07/07 03:13:43 joko Exp $
3	joko	1.1	## --------------------------------------------------------------------------------
4	joko	1.2	## $Log: Struct.pm,v $
5	jonen	1.8	## Revision 1.7 2004/07/07 03:13:43 joko
6			## minor fix for "sub isEmpty"
7			##
8	joko	1.7	## Revision 1.6 2004/05/12 13:53:19 jonen
9			## + bugfix related to declaration of arrays,
10			## solved error: 'Bizarre copy of ARRAY in aassign at...'
11			##
12	jonen	1.6	## Revision 1.5 2003/03/27 15:17:05 joko
13			## namespace fixes for Data::Mungle::*
14			##
15	joko	1.5	## Revision 1.4 2002/12/19 01:06:27 joko
16			## + fixed isEmpty with ARRAYs
17			##
18	joko	1.4	## Revision 1.3 2002/12/13 21:47:04 joko
19			## + fixes to 'sub isEmpty'
20			##
21	joko	1.3	## Revision 1.2 2002/12/05 07:56:34 joko
22			## + updated/enhanced isEmpty (hacky?)
23			##
24	joko	1.2	## Revision 1.1 2002/11/29 04:49:30 joko
25			## + initial check-in
26			##
27	joko	1.1	## --------------------------------------------------------------------------------
28
29
30	joko	1.5	package Data::Mungle::Compare::Struct;
31	joko	1.1
32			use strict;
33			use warnings;
34
35			require Exporter;
36			our @ISA = qw( Exporter );
37			our @EXPORT_OK = qw(
38			&getRelations
39			&getDifference
40			&isEmpty
41			);
42
43			use Data::Dumper;
44
45			sub getRelations {
46			my $a_ref = shift;
47			my $b_ref = shift;
48			my @a = @{$a_ref};
49			my @b = @{$b_ref};
50
51	jonen	1.6	# BUGFIX 2004-05-12: following declaration of arrays occures an strange perl error:
52			# 'Bizarre copy of ARRAY in aassign at ..<PATH_TO>/<THIS_FILE> line <NEXT LINE>'
53			# (at PERL 5.8.4, Debian/unstable/experimental)
54			#
55			#my @isect = my @diff = my @union = ();
56			#
57			# so use normal declaration instead!!
58			my @isect = ();
59			my @diff = ();
60			my @union = ();
61
62	joko	1.1	my $e;
63			my %count;
64
65			foreach $e (@a, @b) { $count{$e}++ }
66
67			foreach $e (keys %count) {
68			push(@union, $e);
69			push @{ $count{$e} == 2 ? \@isect : \@diff }, $e;
70			}
71
72			# bugfix: a diff is no diff if we don't even have an isect
73			@diff = undef if !@isect;
74
75			my $result = {
76			union => \@union,
77			isect => \@isect,
78			diff => \@diff,
79			};
80
81			return $result;
82
83			}
84
85			sub getDifference {
86			my $res = getRelations(shift, shift);
87			return $res->{diff};
88			}
89
90			sub isEmpty {
91	joko	1.2
92	joko	1.1	my $var = shift;
93	joko	1.2	my $ref = ref($var);
94			my $reftype = '';
95			$reftype = attributes::reftype($var) if $ref;
96
97			#print "isEmpty is parsing variable ( ref $ref reftype $reftype )", "\n";
98
99	jonen	1.8	#print Dumper($ref);
100	joko	1.3
101	joko	1.2	my $found;
102
103			if ($ref eq 'Set::Object') {
104			$found = 1;
105	joko	1.3	#print "members:", "\n";
106			#print Dumper($var->members());
107			#print "\n";
108	joko	1.2	my $tc = { ok => 0, count => 0, empty => 0 };
109			foreach ($var->members()) {
110	joko	1.3	#print "member!!", "\n";
111	joko	1.2	#print "empty: ", isEmpty($_), "\n";
112			#$tc->{ok} = 1;
113			$tc->{count}++;
114			$tc->{empty}++ if isEmpty($_);
115			#return $result if $result;
116			}
117	joko	1.3
118			#print Dumper($tc);
119	joko	1.2
120			return 1 if ($tc->{count} == $tc->{empty});
121			return 0;
122
123			}
124	joko	1.1
125	joko	1.3	if ($reftype eq 'ARRAY') {
126			my @arr = @$var;
127			my $isReallyEmpty = ($#arr == -1 ? 1 : 0);
128			return 1 if $isReallyEmpty;
129			$found = 1;
130	joko	1.4	foreach (@arr) {
131			#return 0 if defined $_;
132			#return 1 if isEmpty($_);
133			return 0 if !isEmpty($_);
134	joko	1.3	}
135
136			} elsif ($reftype eq 'HASH') {
137			my $empty = 1;
138	joko	1.2	$found = 1;
139	joko	1.1	foreach (keys %$var) {
140	joko	1.3	# TODO: review and fix this!
141	joko	1.2	=pod
142			# recursion
143			if (ref $var->{$_} eq 'Set::Object') {
144			print "==========set", "\n";
145			if (isEmpty($var->{$_})) {
146			return 0;
147			#next;
148			}
149			}
150			=cut
151			next if ref $var->{$_} eq 'Set::Object';
152			#return 0 if defined $var->{$_};
153	joko	1.3	#return 1 if isEmpty($var->{$_});
154			my $elem_empty = isEmpty($var->{$_});
155
156			#print "elem: $elem_empty\n";
157			$empty &&= $elem_empty;
158	joko	1.1	}
159	joko	1.3	return $empty;
160			#return 0;
161	joko	1.2
162	joko	1.7	# check for empty string
163			} elsif (defined $var) {
164	joko	1.2	$found = 1;
165	joko	1.7	return 0 if $var ne '';
166	joko	1.2	}
167
168			if (!$found) {
169	jonen	1.8	#print "isEmpty could not parse variable ( ref $ref reftype $reftype )", "\n";
170	joko	1.1	}
171	joko	1.4
172			#print "EMPTY!!!", "\n";
173	joko	1.1
174			return 1;
175	joko	1.2
176	joko	1.1	}
177
178			1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26