/[A3C]/bin/ldap2model.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /bin/ldap2model.pl

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

revision 99 by dpavlin, Wed Apr 30 23:44:43 2008 UTC revision 114 by dpavlin, Thu May 15 17:35:45 2008 UTC
# Line 2  Line 2 
2  use warnings;  use warnings;
3  use strict;  use strict;
4    
5  # schema2model.pl - convert LDAP schema file into jifty model  =head1 NAME
 #  
 # 04/30/08 20:55:21 CEST Dobrica Pavlinusic <dpavlin@rot13.org>  
 #  
 # ./bin/ldap2model.pl data/all.ldif hrEduOrg  
6    
7    schema2model.pl - convert LDAP schema file into jifty model
8    
9    =head1 DESCRIPTION
10    
11    Create model from ldif data
12    
13      ./bin/ldap2model.pl --model hrEduOrg --path data/all.ldif
14    
15    or directly from LDAP server
16    
17      ./bin/ldap2model.pl --model inetOrgPerson
18      ./bin/ldap2model.pl --model organization
19    
20    which must match C<LDAP.objectClass> in C<etc/conf.yml>
21    
22    With C<--debug> switch all output will go to C<STDOUT>
23    instead to files.
24    
25    If your schema for model doesn't include some objectClasses
26    and you want to mixin them manually, use something like:
27    
28      ./bin/ldap2model.pl --model hrEduOrg --mixin dcObject --mixin posixAccount
29    
30    =cut
31    
32    use lib 'lib';
33    
34    use Jifty;
35    use A3C::LDAP;
36  use Net::LDAP::Schema;  use Net::LDAP::Schema;
37  use File::Slurp;  use File::Slurp;
38  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
39    use Getopt::Long;
40    
41  my ( $path, $objectClass ) = @ARGV;  my ( $path, $objectClass, $debug );
42    my @mixin;
 die "usage: $0 path/to/schema.ldif inetOrgPerson\n" unless $path && $objectClass;  
43    
44  my $schema = Net::LDAP::Schema->new;  GetOptions(
45  $schema->parse ( $path ) or die $schema->error;          'model|objectClass=s', => \$objectClass,
46            'mixin=s', => \@mixin,
47            'path=s', => \$path,
48            'debug+', => \$debug,
49    );
50    
51    die "usage: $0 --model netOrgPerson [--path path/to/schema.ldif]\n" unless $objectClass;
52    
53    my $schema;
54    if ( $path ) {
55            $schema = Net::LDAP::Schema->new;
56            $schema->parse ( $path ) or die $schema->error;
57            warn "# loaded schema from $path\n";
58    } else {
59            my $l = A3C::LDAP->new;
60            $schema = $l->ldap->schema;
61    }
62    
63  die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass );  die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass );
64    
# Line 32  use A3C::Record schema { Line 73  use A3C::Record schema {
73  /;  /;
74    
75  my $methods;  my $methods;
76    my $create;
77    my $columns;
78    
79  sub entry {  sub model_columns {
80          my ( $e, $add ) = @_;          my $objectClass = shift;
81          my $name = $_->{name} || die "no name?";          my $model;
82          $methods .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};          warn "Creating columns for model $objectClass\n";
83          my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/;  
84          $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};          $methods .= qq/\n=head2 $objectClass\n=cut\n\n/;
85          $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};  
86          $out .= qq/,\n\t\t$add/ if $add;          sub entry {
87          $out .= qq/;\n\n/;                  my ( $e, $add ) = @_;
88          return $out;                  my $name = $_->{name} || die "no name?";
89  }                  if ( $columns->{$name} ) {
90                            warn "WARNING: column $name found again, skipping...\n";
91  $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);                          return '';
92                    }
93  $model .= qq/\t# $objectClass must:\n\n/;                  $methods .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}};
94                    my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/;
95    #               $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'};
96    #               $out .= qq/,\n\t\tfilters are qw(A3C::Filter::Array)/ unless $_->{'single-value'};
97                    $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'};
98                    $out .= qq/,\n\t\t$add/ if $add;
99                    $out .= qq/;\n\n/;
100                    $columns->{$name}++;
101                    return $out;
102            }
103    
104            $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass);
105    
106            my $must;
107            map {
108                    warn "# $objectClass must: ",dump( $_ ),$/ if $debug;
109                    $must .= entry( $_, 'is mandatory' );
110                    $create->{$_->{name}} = $_->{'single-value'} ? $_->{name} : [ $_->{name}, $_->{desc} ];
111            } $schema->must( $objectClass );
112            $model .= qq/\t# $objectClass must:\n\n$must\n/ if $must;
113    
114            my $may;
115            map {
116                    warn "# $objectClass may: ",dump( $_ ),$/ if $debug;
117                    $may .= entry( $_ );
118            } $schema->may( $objectClass );
119            $model .= qq/\t# $objectClass may:\n\n$may\n/ if $may;
120    
121  map {          return $model;
122          warn "# $objectClass must: ",dump( $_ );  }
         $model .= entry( $_, 'is mandatory' );  
 } $schema->must( $objectClass );  
123    
124  $model .= qq/\t# $objectClass may:\n\n/;  $model .= model_columns( $objectClass );
125    $model .= model_columns( $_ ) foreach @mixin;
126    
127  map {  $methods .= qq/\n=head2 name\n\nAuto-generated human readable id for generic access to name\n\n=cut\n\nsub name { \$_[0]->id }\n/ unless $columns->{name};
         warn "# $objectClass may: ",dump( $_ );  
         $model .= entry( $_ );  
 } $schema->may( $objectClass );  
128    
129  $model .= qq/  $model .= qq/
130    
# Line 67  $model .= qq/ Line 132  $model .= qq/
132    
133  $methods  $methods
134    
135    =head ACL
136    
137    We use L<A3C::DefaultACL> for access control
138    
139    =cut
140    
141  use A3C::DefaultACL;  use A3C::DefaultACL;
142    
143  1;  1;
144  /;  /;
145    
146  my $model_path = "lib/A3C/Model/$objectClass.pm";  if ( $debug ) {
147  write_file( $model_path, $model );          print "##### ----- start of created model $objectClass\n\n$model\n\n#### ---- END of created model $objectClass\n";
148  warn "Created $model_path\n";  } else {
149            my $model_path = "lib/A3C/Model/$objectClass.pm";
150            write_file( $model_path, $model );
151            print "Created $model_path\n";
152    }
153    
154    my $test = <<'__END_OF_TEST__';
155    #!/usr/bin/env perl
156    use warnings;
157    use strict;
158    
159    =head1 DESCRIPTION
160    
161    A basic test harness for the _objectClass_ model.
162    
163    =cut
164    
165    use Jifty::Test tests => 11;
166    
167    # Make sure we can load the model
168    use_ok('A3C::Model::_objectClass_');
169    
170    # Grab a system user
171    my $system_user = A3C::CurrentUser->superuser;
172    ok($system_user, "Found a system user");
173    
174    # Try testing a create
175    my $o = A3C::Model::_objectClass_->new(current_user => $system_user);
176    my ($id) = $o->create(
177    _create_1_);
178    ok($id, "_objectClass_ create returned success");
179    ok($o->id, "New _objectClass_ has valid id set");
180    is($o->id, $id, "Create returned the right id");
181    
182    # And another
183    $o->create(
184    _create_2_);
185    ok($o->id, "_objectClass_ create returned another value");
186    isnt($o->id, $id, "And it is different from the previous one");
187    
188    # Searches in general
189    my $collection =  A3C::Model::_objectClass_Collection->new(current_user => $system_user);
190    $collection->unlimit;
191    is($collection->count, 2, "Finds two records");
192    
193    # Searches in specific
194    $collection->limit(column => 'id', value => $o->id);
195    is($collection->count, 1, "Finds one record with specific id");
196    
197    # Delete one of them
198    $o->delete;
199    $collection->redo_search;
200    is($collection->count, 0, "Deleted row is gone");
201    
202    # And the other one is still there
203    $collection->unlimit;
204    is($collection->count, 1, "Still one left");
205    __END_OF_TEST__
206    
207    $test =~ s/_objectClass_/$objectClass/gs;
208    
209    foreach my $round ( 1 .. 2 ) {
210            my $data;
211            $data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create;
212            warn "$round data = $data\n" if $debug;
213            $test =~ s/_create_${round}_/$data/gs;
214    }
215    
216    if ( $debug ) {
217            print "##### ----- template test\n$test\n";
218    } else {
219            my $test_path = "t/00-model-$objectClass.t";
220            write_file( $test_path, $test );
221            print "Created $test_path\n";
222            chmod 0755, $test_path;
223    }
Legend:
Removed from v.99  
changed lines
  Added in v.114
  ViewVC Help
Powered by ViewVC 1.1.26