--- bin/ldap2model.pl 2008/04/30 21:27:54 98 +++ bin/ldap2model.pl 2008/05/15 18:33:58 117 @@ -2,44 +2,224 @@ use warnings; use strict; -# schema2model.pl - convert LDAP schema file into jifty model -# -# 04/30/08 20:55:21 CEST Dobrica Pavlinusic +=head1 NAME +schema2model.pl - convert LDAP schema file into jifty model + +=head1 DESCRIPTION + +Create model from ldif data + + ./bin/ldap2model.pl --model hrEduOrg --path data/all.ldif + +or directly from LDAP server + + ./bin/ldap2model.pl --model inetOrgPerson + ./bin/ldap2model.pl --model organization + +which must match C in C + +With C<--debug> switch all output will go to C +instead to files. + +If your schema for model doesn't include some objectClasses +and you want to mixin them manually, use something like: + + ./bin/ldap2model.pl --model hrEduOrg --mixin dcObject --mixin posixAccount + +=cut + +use lib 'lib'; + +use Jifty; +use A3C::LDAP; use Net::LDAP::Schema; +use File::Slurp; use Data::Dump qw/dump/; +use Getopt::Long; + +my ( $path, $objectClass, $debug ); +my @mixin; + +GetOptions( + 'model|objectClass=s', => \$objectClass, + 'mixin=s', => \@mixin, + 'path=s', => \$path, + 'debug+', => \$debug, +); + +die "usage: $0 --model netOrgPerson [--path path/to/schema.ldif]\n" unless $objectClass; + +my $schema; +if ( $path ) { + $schema = Net::LDAP::Schema->new; + $schema->parse ( $path ) or die $schema->error; + warn "# loaded schema from $path\n"; +} else { + my $l = A3C::LDAP->new; + $schema = $l->ldap->schema; +} + +die "$objectClass objectClass not found in $path\n" unless $schema->objectclass( $objectClass ); + +my $model = qq/package A3C::Model::$objectClass; +use strict; +use warnings; -my ( $path, $objectClass ) = @ARGV; +use Jifty::DBI::Schema; -die "usage: $0 path/to/schema.ldif inetOrgPerson\n" unless $path && $objectClass; +use A3C::Record schema { -my $schema = Net::LDAP::Schema->new; -$schema->parse ( $path ) or die $schema->error; +/; -sub entry { - my ( $e, $add ) = @_; - my $out = qq/\tcolumn $_->{name} =>\n\t\tlabel is _('$_->{desc}')/; - $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'}; - $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'}; - $out .= qq/,\n\t\t$add/ if $add; - $out .= qq/;\n\n/; - return $out; +my $methods; +my $create; +my $columns; + +sub model_columns { + my $objectClass = shift; + my $model; + warn "Creating columns for model $objectClass\n"; + + my $aliases = qq/\n=head1 $objectClass helper methods\n=cut\n\n/; + + sub entry { + my ( $e, $add ) = @_; + my $name = $_->{name} || die "no name?"; + if ( $columns->{$name} ) { + warn "WARNING: column $name found again, skipping...\n"; + return ''; + } + $aliases .= qq/sub $_ { \$_[0]->$name }\n/ foreach @{$_->{aliases}}; + my $out = qq/\tcolumn $name =>\n\t\tlabel is _('$_->{desc}')/; +# $out .= qq/,\n\t\t# single-value/ if $_->{'single-value'}; +# $out .= qq/,\n\t\tfilters are qw(A3C::Filter::Array)/ unless $_->{'single-value'}; + $out .= qq/,\n\t\tmax_length is $_->{max_length}/ if $_->{'max_length'}; + $out .= qq/,\n\t\t$add/ if $add; + $out .= qq/;\n\n/; + $columns->{$name}++; + return $out; + } + + $model .= qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/ if $schema->superclass($objectClass); + + my $must; + map { + warn "# $objectClass must: ",dump( $_ ),$/ if $debug; + $must .= entry( $_, 'is mandatory' ); + $create->{$_->{name}} = $_->{'single-value'} ? $_->{name} : [ $_->{name}, $_->{desc} ]; + } $schema->must( $objectClass ); + $model .= qq/\t# $objectClass must:\n\n$must\n/ if $must; + + my $may; + map { + warn "# $objectClass may: ",dump( $_ ),$/ if $debug; + $may .= entry( $_ ); + } $schema->may( $objectClass ); + $model .= qq/\t# $objectClass may:\n\n$may\n/ if $may; + + $methods .= $aliases unless $aliases; + + return $model; } -my $model = qq/\t# $objectClass super: / . join(' ', $schema->superclass($objectClass)). qq/\n\n/; +$model .= model_columns( $objectClass ); +$model .= model_columns( $_ ) foreach @mixin; + +$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}; + +$model .= qq/ + +}; -$model .= qq/\t# $objectClass must:\n\n/; +$methods -map { - warn "# $objectClass must: ",dump( $_ ); - $model .= entry( $_, 'is mandatory' ); -} $schema->must( $objectClass ); +=head2 ACL -$model .= qq/\t# $objectClass may:\n\n/; +We use L for access control -map { - warn "# $objectClass may: ",dump( $_ ); - $model .= entry( $_ ); -} $schema->may( $objectClass ); +=cut -print $model; +use A3C::DefaultACL; + +1; +/; + +if ( $debug ) { + print "##### ----- start of created model $objectClass\n\n$model\n\n#### ---- END of created model $objectClass\n"; +} else { + my $model_path = "lib/A3C/Model/$objectClass.pm"; + write_file( $model_path, $model ); + print "Created $model_path\n"; +} + +my $test = <<'__END_OF_TEST__'; +#!/usr/bin/env perl +use warnings; +use strict; + +=head1 DESCRIPTION + +A basic test harness for the _objectClass_ model. + +=cut + +use Jifty::Test tests => 11; + +# Make sure we can load the model +use_ok('A3C::Model::_objectClass_'); + +# Grab a system user +my $system_user = A3C::CurrentUser->superuser; +ok($system_user, "Found a system user"); + +# Try testing a create +my $o = A3C::Model::_objectClass_->new(current_user => $system_user); +my ($id) = $o->create( +_create_1_); +ok($id, "_objectClass_ create returned success"); +ok($o->id, "New _objectClass_ has valid id set"); +is($o->id, $id, "Create returned the right id"); + +# And another +$o->create( +_create_2_); +ok($o->id, "_objectClass_ create returned another value"); +isnt($o->id, $id, "And it is different from the previous one"); + +# Searches in general +my $collection = A3C::Model::_objectClass_Collection->new(current_user => $system_user); +$collection->unlimit; +is($collection->count, 2, "Finds two records"); + +# Searches in specific +$collection->limit(column => 'id', value => $o->id); +is($collection->count, 1, "Finds one record with specific id"); + +# Delete one of them +$o->delete; +$collection->redo_search; +is($collection->count, 0, "Deleted row is gone"); + +# And the other one is still there +$collection->unlimit; +is($collection->count, 1, "Still one left"); +__END_OF_TEST__ + +$test =~ s/_objectClass_/$objectClass/gs; + +foreach my $round ( 1 .. 2 ) { + my $data; + $data .= qq/\t\t'$_' => / . dump( $create->{$_} ) . qq/,\n/ foreach keys %$create; + warn "$round data = $data\n" if $debug; + $test =~ s/_create_${round}_/$data/gs; +} + +if ( $debug ) { + print "##### ----- template test\n$test\n"; +} else { + my $test_path = "t/00-model-$objectClass.t"; + write_file( $test_path, $test ); + print "Created $test_path\n"; + chmod 0755, $test_path; +}