persistence/lib/Text/Tradition/Directory.pm

   1 package Text::Tradition::Directory;
   2
   3 use strict;
   4 use warnings;
   5 use Moose;
   6 use DBI;
   7 use Encode qw/ encode decode_utf8 /;
   8 use KiokuDB::GC::Naive;
   9 use KiokuDB::TypeMap;
  10 use KiokuDB::TypeMap::Entry::Naive;
  11 use Safe::Isa;
  12 use Text::Tradition::Error;
  13
  14 ## users
  15 use KiokuX::User::Util qw(crypt_password);
  16 use Text::Tradition::Store;
  17 use Text::Tradition::User;
  18 use Text::Tradition::TypeMap::Entry;
  19
  20 extends 'KiokuX::Model';
  21
  22 use vars qw/ $VERSION /;
  23 $VERSION = "1.1";
  24
  25 =head1 NAME
  26
  27 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving
  28 traditions and their owners
  29
  30 =head1 SYNOPSIS
  31
  32   use Text::Tradition::Directory;
  33   my $d = Text::Tradition::Directory->new(
  34     'dsn' => 'dbi:SQLite:mytraditions.db',
  35     'extra_args' => { 'create' => 1 },
  36   );
  37
  38   my $tradition = Text::Tradition->new( @args );
  39   my $stemma = $tradition->add_stemma( dotfile => $dotfile ); # if Analysis module installed
  40   $d->save_tradition( $tradition );
  41
  42   foreach my $id ( $d->traditions ) {
  43         print $d->tradition( $id )->name;
  44   }
  45
  46   ## Users:
  47   my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
  48   my $newuser = $userstore->add_user({ username => 'fred',
  49                                        password => 'somepassword' });
  50
  51   my $fetchuser = $userstore->find_user({ username => 'fred' });
  52   if($fetchuser->check_password('somepassword')) {
  53      ## login user or .. whatever
  54   }
  55
  56   my $user = $userstore->deactivate_user({ username => 'fred' });
  57   if(!$user->active) {
  58     ## shouldnt be able to login etc
  59   }
  60
  61 =head1 DESCRIPTION
  62
  63 Text::Tradition::Directory is an interface for storing and retrieving text
  64 traditions and all their data, including an associated stemma hypothesis
  65 and a user who has ownership rights to the tradition data. It is an
  66 instantiation of a KiokuDB::Model, storing traditions and associated
  67 stemmas by UUID.
  68
  69 The Text::Tradition::Directory package also includes the
  70 L<Text::Tradition::User> class for user objects, and the
  71 L<Text::Tradition::Ownership> role which extends the Text::Tradition class
  72 to handle user ownership.
  73
  74 =head1 ATTRIBUTES
  75
  76 =head2 MIN_PASS_LEN
  77
  78 Constant for the minimum password length when validating passwords,
  79 defaults to "8".
  80
  81 =cut
  82
  83 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
  84
  85 =head1 METHODS
  86
  87 =head2 new
  88
  89 Returns a Directory object.
  90
  91 =head2 traditionlist
  92
  93 Returns a hashref mapping of ID => name for all traditions in the directory.
  94
  95 =head2 tradition( $id )
  96
  97 Returns the Text::Tradition object of the given ID.
  98
  99 =head2 save( $tradition )
 100
 101 Writes the given tradition to the database, returning its ID.
 102
 103 =head2 delete( $tradition )
 104
 105 Deletes the given tradition object from the database.
 106 WARNING!! Garbage collection does not yet work. Use this sparingly.
 107
 108 =begin testing
 109
 110 use TryCatch;
 111 use File::Temp;
 112 use Safe::Isa;
 113 use Text::Tradition;
 114 use_ok 'Text::Tradition::Directory';
 115
 116 my $fh = File::Temp->new();
 117 my $file = $fh->filename;
 118 $fh->close;
 119 my $dsn = "dbi:SQLite:dbname=$file";
 120 my $uuid;
 121 my $user = 'user@example.org';
 122 my $t = Text::Tradition->new(
 123         'name'  => 'inline',
 124         'input' => 'Tabular',
 125         'file'  => 't/data/simple.txt',
 126         );
 127 my $stemma_enabled = $t->can( 'add_stemma' );
 128
 129 {
 130         my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
 131                 'extra_args' => { 'create' => 1 } );
 132         ok( $d->$_isa('Text::Tradition::Directory'), "Got directory object" );
 133
 134         my $scope = $d->new_scope;
 135         $uuid = $d->save( $t );
 136         ok( $uuid, "Saved test tradition" );
 137
 138         # Add a test user
 139         my $user = $d->add_user({ username => $user, password => 'UserPass' });
 140         $user->add_tradition( $t );
 141         $d->store( $user );
 142         is( $t->user, $user, "Assigned tradition to test user" );
 143
 144         SKIP: {
 145                 skip "Analysis package not installed", 5 unless $stemma_enabled;
 146                 my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
 147                 ok( $d->save( $t ), "Updated tradition with stemma" );
 148                 is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
 149                 is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
 150                 try {
 151                         $d->save( $s );
 152                 } catch( Text::Tradition::Error $e ) {
 153                         is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
 154                         like( $e->message, qr/Cannot directly save non-Tradition object/,
 155                                 "Exception has correct message" );
 156                 }
 157         }
 158 }
 159 my $nt = Text::Tradition->new(
 160         'name' => 'CX',
 161         'input' => 'CollateX',
 162         'file' => 't/data/Collatex-16.xml',
 163         );
 164 ok( $nt->$_isa('Text::Tradition'), "Made new tradition" );
 165
 166 {
 167         my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
 168         my $scope = $f->new_scope;
 169         is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
 170         my $nuuid = $f->save( $nt );
 171         ok( $nuuid, "Stored second tradition" );
 172         my @tlist = $f->traditionlist;
 173         is( scalar @tlist, 2, "Directory index has both traditions" );
 174         my $tf = $f->tradition( $uuid );
 175         my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
 176         is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
 177         is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
 178         my $sid;
 179         SKIP: {
 180                 skip "Analysis package not installed", 4 unless $stemma_enabled;
 181                 $sid = $f->object_to_id( $tf->stemma(0) );
 182                 try {
 183                         $f->tradition( $sid );
 184                 } catch( Text::Tradition::Error $e ) {
 185                         is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
 186                         like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
 187                 }
 188                 try {
 189                         $f->delete( $sid );
 190                 } catch( Text::Tradition::Error $e ) {
 191                         is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
 192                         like( $e->message, qr/Cannot directly delete non-Tradition object/,
 193                                 "Exception has correct message" );
 194                 }
 195         }
 196
 197         $f->delete( $uuid );
 198         ok( !$f->exists( $uuid ), "Object is deleted from DB" );
 199         ok( !$f->exists( $sid ), "Object stemma also deleted from DB" ) if $stemma_enabled;
 200         is( scalar $f->traditionlist, 1, "Object is deleted from index" );
 201 }
 202
 203 {
 204         my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
 205         my $scope = $g->new_scope;
 206         is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
 207         my $ntobj = $g->tradition( 'CX' );
 208         my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
 209         my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
 210         is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
 211 }
 212
 213 =end testing
 214
 215 =cut
 216 use Text::Tradition::TypeMap::Entry;
 217
 218 has +typemap => (
 219   is      => 'rw',
 220   isa     => 'KiokuDB::TypeMap',
 221   default => sub {
 222     KiokuDB::TypeMap->new(
 223       isa_entries => {
 224         # now that we fall back to YAML deflation, all attributes of
 225         # Text::Tradition will be serialized to YAML as individual objects
 226         # Except if we declare a specific entry type here
 227         "Text::Tradition" =>
 228           KiokuDB::TypeMap::Entry::MOP->new(),
 229         # We need users to be naive entries so that they hold
 230         # references to the original tradition objects, not clones
 231         "Text::Tradition::User" =>
 232           KiokuDB::TypeMap::Entry::MOP->new(),
 233         "Text::Tradition::Collation" =>
 234           KiokuDB::TypeMap::Entry::MOP->new(),
 235         "Text::Tradition::Witness" =>
 236           KiokuDB::TypeMap::Entry::MOP->new(),
 237         "Graph" => Text::Tradition::TypeMap::Entry->new(),
 238         "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
 239       }
 240     );
 241   },
 242 );
 243
 244 has '_mysql_utf8_hack' => (
 245         is => 'ro',
 246         isa => 'Bool',
 247         default => undef,
 248 );
 249
 250 # Push some columns into the extra_args
 251 around BUILDARGS => sub {
 252         my $orig = shift;
 253         my $class = shift;
 254         my $args;
 255         if( @_ == 1 ) {
 256                 $args = $_[0];
 257         } else {
 258                 $args = { @_ };
 259         }
 260         my @column_args;
 261         if( $args->{'dsn'} =~ /^dbi:(\w+):/ ) { # We're using Backend::DBI
 262                 my $dbtype = $1;
 263                 @column_args = ( 'columns',
 264                         [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
 265                           'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
 266                 if( $dbtype eq 'mysql' &&
 267                         exists $args->{extra_args}->{dbi_attrs} &&
 268                         $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} ) {
 269                         # There is a bad interaction with MySQL in utf-8 mode.
 270                         # Work around it here.
 271                         # TODO fix the underlying storage problem
 272                         $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} = undef;
 273                         $args->{_mysql_utf8_hack} = 1;
 274                 }
 275         }
 276         my $ea = $args->{'extra_args'};
 277         if( ref( $ea ) eq 'ARRAY' ) {
 278                 push( @$ea, @column_args );
 279         } elsif( ref( $ea ) eq 'HASH' ) {
 280                 $ea = { %$ea, @column_args };
 281         } else {
 282                 $ea = { @column_args };
 283         }
 284         $args->{'extra_args'} = $ea;
 285
 286         return $class->$orig( $args );
 287 };
 288
 289 override _build_directory => sub {
 290   my($self) = @_;
 291   Text::Tradition::Store->connect(@{ $self->_connect_args },
 292     resolver_constructor => sub {
 293       my($class) = @_;
 294       $class->new({ typemap => $self->directory->merged_typemap,
 295                     fallback_entry => Text::Tradition::TypeMap::Entry->new() });
 296   });
 297 };
 298
 299 ## These checks don't cover store($id, $obj)
 300 # before [ qw/ store update insert delete / ] => sub {
 301 before [ qw/ delete / ] => sub {
 302         my $self = shift;
 303         my @nontrad;
 304         foreach my $obj ( @_ ) {
 305                 if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
 306             && !$obj->$_isa('Text::Tradition::User') ) {
 307                         # Is it an id => Tradition hash?
 308                         if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
 309                                 my( $k ) = keys %$obj;
 310                                 next if $obj->{$k}->$_isa('Text::Tradition');
 311                         }
 312                         push( @nontrad, $obj );
 313                 }
 314         }
 315         if( @nontrad ) {
 316                 throw( "Cannot directly save non-Tradition object of type "
 317                         . ref( $nontrad[0] ) );
 318         }
 319 };
 320
 321 # TODO Garbage collection doesn't work. Suck it up and live with the
 322 # inflated DB.
 323 after delete => sub {
 324         my $self = shift;
 325         my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
 326         $self->directory->backend->delete( $gc->garbage->members );
 327 };
 328
 329 sub save {
 330         my $self = shift;
 331         return $self->store( @_ );
 332 }
 333
 334 sub tradition {
 335         my( $self, $id ) = @_;
 336         my $obj = $self->lookup( $id );
 337         unless( $obj ) {
 338                 # Try looking up by name.
 339                 foreach my $item ( $self->traditionlist ) {
 340                         if( $item->{'name'} eq $id ) {
 341                                 $obj = $self->lookup( $item->{'id'} );
 342                                 last;
 343                         }
 344                 }
 345         }
 346         if( $obj && !$obj->$_isa('Text::Tradition') ) {
 347                 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
 348         }
 349         return $obj;
 350 }
 351
 352 sub traditionlist {
 353         my $self = shift;
 354     my ($user) = @_;
 355
 356     return $self->user_traditionlist($user) if($user);
 357         return $self->_get_object_idlist( 'Text::Tradition' );
 358 }
 359
 360 sub _get_object_idlist {
 361         my( $self, $objclass ) = @_;
 362         my @tlist;
 363         # If we are using DBI, we can do it the easy way; if not, the hard way.
 364         # Easy way still involves making a separate DBI connection. Ew.
 365         if( $self->dsn =~ /^dbi:(\w+):/ ) {
 366                 my $dbtype = $1;
 367                 my @connection = @{$self->directory->backend->connect_info};
 368                 # Get rid of KiokuDB-specific arg
 369                 pop @connection if scalar @connection > 4;
 370                 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
 371                 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
 372                 my $dbh = DBI->connect( @connection );
 373                 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "'
 374                         . $objclass . '"' );
 375                 $q->execute();
 376                 while( my @row = $q->fetchrow_array ) {
 377                         # Horrible horrible hack. Re-convert the name to UTF-8.
 378                         if( $self->_mysql_utf8_hack ) {
 379                                 # Convert the chars into a raw bytestring.
 380                                 my $octets = encode( 'ISO-8859-1', $row[1] );
 381                                 $row[1] = decode_utf8( $octets );
 382                         }
 383                         push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
 384                 }
 385         } else {
 386                 $self->scan( sub { my $o = shift;
 387                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 388                                                                                    'name' => $o->name,
 389                                                                                    'public' => $o->public } )
 390                                                                 if( ref $o eq $objclass ) } );
 391         }
 392         return @tlist;
 393 }
 394
 395 sub throw {
 396         Text::Tradition::Error->throw(
 397                 'ident' => 'database error',
 398                 'message' => $_[0],
 399                 );
 400 }
 401
 402
 403 # has 'directory' => (
 404 #     is => 'rw',
 405 #     isa => 'KiokuX::Model',
 406 #     handles => []
 407 #     );
 408
 409 ## TODO: Some of these methods should probably optionally take $user objects
 410 ## instead of hashrefs.
 411
 412 ## It also occurs to me that all these methods don't need to be named
 413 ## XX_user, but leaving that way for now incase we merge this code
 414 ## into ::Directory for one-store.
 415
 416 =head1 USER DIRECTORY METHODS
 417
 418 =head2 add_user( $userinfo )
 419
 420 Takes a hashref of C<username>, C<password>.
 421
 422 Create a new user object, store in the KiokuDB backend, and return it.
 423
 424 =cut
 425
 426 sub add_user {
 427     my ($self, $userinfo) = @_;
 428
 429     my $username = $userinfo->{username};
 430     my $password = $userinfo->{password};
 431     my $role = $userinfo->{role} || 'user';
 432
 433         throw( "No username given" ) unless $username;
 434         throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
 435                 . " characters long" )
 436                 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
 437
 438     my $user = Text::Tradition::User->new(
 439         id => $username,
 440         password => ($password ? crypt_password($password) : ''),
 441         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 442         role => $role,
 443     );
 444
 445     $self->store($user->kiokudb_object_id, $user);
 446
 447     return $user;
 448 }
 449
 450 =head2 create_user( $userinfo )
 451
 452 Takes a hashref that can either be suitable for add_user (see above) or be
 453 a hash of OpenID user information from Credential::OpenID.
 454
 455 =cut
 456
 457 sub create_user {
 458     my ($self, $userinfo) = @_;
 459
 460     ## No username means probably an OpenID based user
 461     if(!exists $userinfo->{username}) {
 462         _extract_openid_data($userinfo);
 463     }
 464
 465     return $self->add_user($userinfo);
 466 }
 467
 468 ## Not quite sure where this method should be.. Auth /
 469 ## Credential::OpenID just pass us back the chunk of extension data
 470 sub _extract_openid_data {
 471     my ($userinfo) = @_;
 472
 473     ## Spec says SHOULD use url as identifier
 474     $userinfo->{username} = $userinfo->{url};
 475
 476     ## Use email addy as display if available
 477     if(exists $userinfo->{extensions} &&
 478          exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
 479          defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
 480         ## Somewhat ugly attribute extension reponse, contains
 481         ## google-email string which we can use as the id
 482
 483         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 484     }
 485
 486     return;
 487 }
 488
 489 =head2 find_user( $userinfo )
 490
 491 Takes a hashref of C<username> or C<email>, and possibly openIDish results from
 492 L<Net::OpenID::Consumer>.
 493
 494 Fetches the user object for the given username and returns it.
 495
 496 =cut
 497
 498 sub find_user {
 499     my ($self, $userinfo) = @_;
 500
 501     ## A URL field means probably an OpenID based user
 502     if( exists $userinfo->{url} ) {
 503         _extract_openid_data($userinfo);
 504     }
 505
 506         my $user;
 507         if( exists $userinfo->{username} ) {
 508         my $username = $userinfo->{username};
 509                 ## No logins if user is deactivated (use lookup to fetch to re-activate)
 510                 $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 511                 ## If there is an inactive user, skip it
 512                 return if( $user && !$user->active );
 513         } elsif( exists $userinfo->{email} ) {
 514                 ## Scan the users looking for a matching email
 515                 my @matches;
 516                 $self->scan( sub { push( @matches, @_ )
 517                         if $_[0]->isa('Text::Tradition::User')
 518                         && $_[0]->email eq $userinfo->{email} } );
 519                 $user = shift @matches;
 520         }
 521 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 522     return $user;
 523 }
 524
 525 =head2 modify_user( $userinfo )
 526
 527 Takes a hashref of C<username> and C<password> (same as add_user).
 528
 529 Retrieves the user, and updates it with the new information. Username
 530 changing is not currently supported.
 531
 532 Returns the updated user object, or undef if not found.
 533
 534 =cut
 535
 536 sub modify_user {
 537     my ($self, $userinfo) = @_;
 538     my $username = $userinfo->{username};
 539     my $password = $userinfo->{password};
 540     my $role = $userinfo->{role};
 541
 542     throw( "Missing username" ) unless $username;
 543
 544     my $user = $self->find_user({ username => $username });
 545     throw( "Could not find user $username" ) unless $user;
 546
 547     if($password) {
 548         throw( "Bad password" ) unless $self->validate_password($password);
 549         $user->password(crypt_password($password));
 550     }
 551     if($role) {
 552         $user->role($role);
 553     }
 554
 555     $self->update($user);
 556
 557     return $user;
 558 }
 559
 560 =head2 deactivate_user( $userinfo )
 561
 562 Takes a hashref of C<username>.
 563
 564 Sets the users C<active> flag to false (0), and sets all traditions
 565 assigned to them to non-public, updates the storage and returns the
 566 deactivated user.
 567
 568 Returns undef if user not found.
 569
 570 =cut
 571
 572 sub deactivate_user {
 573     my ($self, $userinfo) = @_;
 574     my $username = $userinfo->{username};
 575
 576     throw( "Need to specify a username for deactivation" ) unless $username;
 577
 578     my $user = $self->find_user({ username => $username });
 579     throw( "User $username not found" ) unless $user;
 580
 581     $user->active(0);
 582     foreach my $tradition (@{ $user->traditions }) {
 583         ## Not implemented yet
 584         # $tradition->public(0);
 585     }
 586
 587     ## Should we be using Text::Tradition::Directory also?
 588     $self->update(@{ $user->traditions });
 589
 590     $self->update($user);
 591
 592     return $user;
 593 }
 594
 595 =head2 reactivate_user( $userinfo )
 596
 597 Takes a hashref of C<username>.
 598
 599 Returns the user object if already activated. Activates (sets the
 600 active flag to true (1)), updates the storage and returns the user.
 601
 602 Returns undef if the user is not found.
 603
 604 =cut
 605
 606 sub reactivate_user {
 607     my ($self, $userinfo) = @_;
 608     my $username = $userinfo->{username};
 609
 610     throw( "Need to specify a username for reactivation" ) unless $username;
 611
 612     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 613     throw( "User $username not found" ) unless $user;
 614
 615     return $user if $user->active;
 616
 617     $user->active(1);
 618     $self->update($user);
 619
 620     return $user;
 621 }
 622
 623 =head2 delete_user( $userinfo )
 624
 625 CAUTION: Deletes actual data!
 626
 627 Takes a hashref of C<username>.
 628
 629 Returns undef if the user doesn't exist.
 630
 631 Removes the user from the store and returns 1.
 632
 633 =cut
 634
 635 sub delete_user {
 636     my ($self, $userinfo) = @_;
 637     my $username = $userinfo->{username};
 638
 639     throw( "Need to specify a username for deletion" ) unless $username;
 640
 641     my $user = $self->find_user({ username => $username });
 642     throw( "User $username not found" ) unless $user;
 643
 644     ## Should we be using Text::Tradition::Directory for this bit?
 645     $self->delete( @{ $user->traditions });
 646
 647     ## Poof, gone.
 648     $self->delete($user);
 649
 650     return 1;
 651 }
 652
 653 =head2 validate_password( $password )
 654
 655 Takes a password string. Returns true if it is longer than
 656 L</MIN_PASS_LEN>, false otherwise.
 657
 658 Used internally by L</add_user>.
 659
 660 =cut
 661
 662 sub validate_password {
 663     my ($self, $password) = @_;
 664
 665     return if !$password;
 666     return if length($password) < $self->MIN_PASS_LEN;
 667
 668     return 1;
 669 }
 670
 671 =head2 user_traditionlist( $user )
 672
 673 Returns a tradition list (see specification above) but containing only
 674 those traditions visible to the specified user.  If $user is the string
 675 'public', returns only publicly-viewable traditions.
 676
 677 =cut
 678
 679 sub user_traditionlist {
 680     my ($self, $user) = @_;
 681
 682     my @tlist;
 683     if(ref $user && $user->is_admin) {
 684         ## Admin sees all
 685         return $self->traditionlist();
 686     } elsif(ref $user) {
 687         ## We have a user object already, so just fetch its traditions and use tose
 688         foreach my $t (@{ $user->traditions }) {
 689             push( @tlist, { 'id' => $self->object_to_id( $t ),
 690                             'name' => $t->name } );
 691         }
 692         return @tlist;
 693     } elsif($user ne 'public') {
 694         die "Passed neither a user object nor 'public' to user_traditionlist";
 695     }
 696
 697     ## Search for all traditions which allow public viewing
 698         my @list = grep { $_->{public} } $self->traditionlist();
 699         return @list;
 700 }
 701
 702 1;
 703
 704 =head1 LICENSE
 705
 706 This package is free software and is provided "as is" without express
 707 or implied warranty.  You can redistribute it and/or modify it under
 708 the same terms as Perl itself.
 709
 710 =head1 AUTHORS
 711
 712 Tara L Andrews E<lt>aurum@cpan.orgE<gt> (initial release)
 713
 714 Shadowcat Systems L<http://www.scsys.co.uk/> (user functionality; making it all work)
 715