diff --git a/docs/migration.txt b/docs/migration.txt index 605e805b2..e95394a99 100644 --- a/docs/migration.txt +++ b/docs/migration.txt @@ -213,5 +213,19 @@ is not specified. You can now dynamically add tabs to WebGUI::TabForms. +5.14 Persistent API Removed + +The never understood and not really used Persistent API has been removed. If +you want to store something in a tree, it probably belongs in the asset tree +anyway. + + +5.15 Node/Attachment System Replaced + +The file system storage mechanism of lib/WebGUI/Node.pm and +lib/WebGUI/Attachment.pm have been replaced in favor of lib/WebGUI/Storage.pm. +If you had anything using the old system we highly recommend migrating it into +the new system as it is much more flexible. Alternatively you can copy the old +system back into place (it should still work, but no guarantees). diff --git a/docs/upgrades/upgrade_6.2.9-6.3.0.pl b/docs/upgrades/upgrade_6.2.9-6.3.0.pl index 27633b883..bb8f89a67 100644 --- a/docs/upgrades/upgrade_6.2.9-6.3.0.pl +++ b/docs/upgrades/upgrade_6.2.9-6.3.0.pl @@ -467,7 +467,13 @@ print "\tDeleting files which are no longer used.\n" unless ($quiet); #unlink("../../lib/WebGUI/Wobject/DataForm.pm"); #unlink("../../lib/WebGUI/Wobject/USS.pm"); #unlink("../../lib/WebGUI/Wobject/FileManager.pm"); - +#unlink("../../lib/WebGUI/Operation/Collateral.pm"); +#unlink("../../lib/WebGUI/Collateral.pm"); +#unlink("../../lib/WebGUI/CollateralFolder.pm"); +#unlink("../../lib/WebGUI/Persistent.pm"); +#rmtree("../../lib/WebGUI/Persistent"); +#rmtree("../../lib/Tree"); +#rmtree("../../lib/DBIx/Tree"); diff --git a/lib/DBIx/Tree/NestedSet.pm b/lib/DBIx/Tree/NestedSet.pm deleted file mode 100644 index 609ef0f57..000000000 --- a/lib/DBIx/Tree/NestedSet.pm +++ /dev/null @@ -1,1236 +0,0 @@ -package DBIx::Tree::NestedSet; - -use strict; -use warnings; -use Carp; -$DBIx::Tree::NestedSet::VERSION='0.15'; - -#POD Below!! - -################################################################################ -sub new{ - my $class=shift; - $class=ref($class)||$class; - my %params=@_; - my $self={ - dbh => $params{dbh}, - left_column_name => $params{left_column_name} || 'lft', - right_column_name => $params{right_column_name} || 'rght', - no_id_creation => $params{no_id_creation} || '', - table_name => $params{table_name} || 'nested_set', - id_name => $params{id_name} || 'id', - no_alter_table => $params{no_alter_table} || undef, - db_type => $params{db_type} || 'MySQL', - no_locking => $params{no_locking} || undef - }; - bless $self, $class; - croak("Not a DBI connection") - unless($params{dbh}->isa('DBI::db')); - - foreach('left_column_name','right_column_name','table_name','id_name'){ - croak('"'.$self->{$_}."\" doesn't look like a valid SQL table or column name to me") - unless ($self->{$_} =~ m/^[_A-Za-z\d]+$/); - } - - my $db_type=$self->{db_type}; - - my $driver = "DBIx::Tree::NestedSet::$db_type"; - eval "require $driver;" or - croak("That DBD source doesn't have a driver implemented yet"); - - my $db_obj=$driver->new( - dbh => $self->{dbh}, - left_column_name => $self->{left_column_name}, - right_column_name => $self->{right_column_name}, - table_name => $self->{table_name}, - no_alter_table => $self->{no_alter_table}, - id_name => $self->{id_name}, - no_locking => $self->{no_locking} - ); - $self->{_db_obj}=$db_obj; - #$self->{start_id}=$params{start_id}|| scalar $self->{dbh}->selectrow_array('select min('.$self->{left_column_name}.') from '.$self->{table_name} ); - $params{dbh}->{RaiseError} = 1 if(not defined $params{No_RaiseError}); - $params{dbh}->trace($params{trace}) if($params{trace}); - return $self; -} -######################################## - - -################################################################################ -sub get_table_name{ - return $_[0]->{table_name}; -} -######################################## - - -################################################################################ -sub get_left_column_name{ - return $_[0]->{left_column_name}; -} -######################################## - - -################################################################################ -sub get_right_column_name{ - return $_[0]->{right_column_name}; -} -######################################## - - -################################################################################ -sub get_id_name{ - return $_[0]->{id_name}; -} -######################################## - - -################################################################################ -sub get_dbh{ - return $_[0]->{dbh}; -} -######################################## - - -################################################################################ -sub get_db_type{ - return $_[0]->{db_type}; -} -######################################## - - -################################################################################ -sub get_no_alter_table{ - return $_[0]->{no_alter_table}; -} -######################################## - - -################################################################################ -sub get_no_locking{ - return $_[0]->{no_locking}; -} -######################################## - - -################################################################################ -sub get_root{ - my $self=shift; - my $left=$self->{left_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - my ($min_left)=$self->{dbh}->selectrow_array("select min($left) from $table"); - return scalar $self->{dbh}->selectrow_array("select $id_name from ".$self->{table_name}." where $left=?",undef,($min_left)); -} -######################################## - - -################################################################################ -sub _lock_tables{ - my $self=shift; - $self->{_db_obj}->_lock_tables; -} -######################################## - - -################################################################################ -sub _unlock_tables{ - my $self=shift; - $self->{_db_obj}->_unlock_tables; -} -######################################## - - -################################################################################ -sub add_child_to_right{ - my($self,%params)=@_; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - #If they have changed the id_name but still pass in the id to act upon via the "id" parameter, - #fix it here. This is for backwards compatibility - $params{$id_name}=$params{id} - } - $self->_lock_tables(); - if(!$params{$id_name} && scalar $dbh->selectrow_array("select count(*) from $table")){ - #They haven't given us an id for this child. Assume they want to add a child DIRECTLY - #under the parent, as they can't have more than one root. - $params{$id_name}=$self->get_root(); - } - my $prepared_rightmost_SQL_statement= - $dbh->prepare_cached("SELECT $right FROM $table WHERE $id_name=?", - {dbi_dummy=>__FILE__.__LINE__} - ); - - my ($rightmost)=$dbh->selectrow_array($prepared_rightmost_SQL_statement,undef,($params{$id_name})); - my $prepared_rightmost_SQL_tree_fix_statement= - $dbh->prepare_cached( - "UPDATE $table SET $left = CASE WHEN $left > ? THEN $left + 2 ELSE $left END, -$right = CASE WHEN $right >= ? THEN $right + 2 ELSE $right END WHERE $right >= ?", - {dbi_dummy=>__FILE__.__LINE__} - ); - $prepared_rightmost_SQL_tree_fix_statement->execute($rightmost,$rightmost,$rightmost); - $prepared_rightmost_SQL_tree_fix_statement->finish(); - my ($params,$values)=$self->_get_params_and_values(\%params,$left,$right,$id_name); - my ($columns,$placeholders)=_prepare_columns_and_placeholders_for_adding_child_to_right($params,$left,$right); - $self->_alter_table_if_needed($params); - if ($self->{no_id_creation}) { - #We are manually passing in IDs. This is kinda a kludge to make the WebGUI folks happy. - $self->_alter_sql_for_provided_primary_key_edits(\$columns,\$placeholders,$values,\%params); - } - my $insert=$dbh->prepare_cached("INSERT INTO $table ($columns) VALUES($placeholders)",{dbi_dummy=>__FILE__.__LINE__}); - $insert->execute($rightmost||1,$rightmost||1,@$values); - $insert->finish(); - my $new_id; - if ($self->{no_id_creation}) { - $new_id=$params{provided_primary_key}; - } else { - ($new_id)=$dbh->selectrow_array("select max($id_name) from $table"); - } - $self->_unlock_tables(); - return $new_id; -} -######################################## - - -################################################################################ -sub add_child_to_left{ - my($self,%params)=@_; - my $dbh=$self->{dbh}; - - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - #If they have changed the id_name but still pass in the id to act upon via the "id" parameter, - #fix it here. This is for backwards compatibility - $params{$id_name}=$params{id} - } - $self->_lock_tables(); - if(!$params{$id_name} && scalar $dbh->selectrow_array("select count(*) from $table")){ - #They haven't given us an id for this child. Assume they want to add a child DIRECTLY - #under the parent, as they can't have more than one root. - $params{$id_name}=$self->get_root(); - } - - my $prepared_leftmost_SQL_statement=$dbh->prepare_cached("SELECT $left FROM $table WHERE $id_name=?",{dbi_dummy=>__FILE__.__LINE__}); - - my ($leftmost)=$dbh->selectrow_array($prepared_leftmost_SQL_statement,undef,($params{$id_name})); - $prepared_leftmost_SQL_statement->finish(); - my $prepared_leftmost_SQL_tree_fix_statement= - $dbh->prepare_cached( - qq|UPDATE $table - SET $right = - CASE WHEN $right > ? - THEN $right + 2 - ELSE $right END, - $left = - CASE WHEN $left > ? - THEN $left + 2 - ELSE $left - END - |, - {dbi_dummy=>__FILE__.__LINE__} - ); - - $prepared_leftmost_SQL_tree_fix_statement->execute($leftmost,$leftmost); - $prepared_leftmost_SQL_tree_fix_statement->finish(); - my ($params,$values)=$self->_get_params_and_values(\%params,$left,$right,$id_name); - my ($columns,$placeholders)=_prepare_columns_and_placeholders_for_adding_child_to_left($params,$left,$right); - $self->_alter_table_if_needed($params); - if ($self->{no_id_creation}) { - #We are manually passing in IDs. This is kinda a kludge to make the WebGUI folks happy. - $self->_alter_sql_for_provided_primary_key_edits(\$columns,\$placeholders,$values,\%params); - } - my $insert=$dbh->prepare_cached("INSERT INTO $table ($columns) VALUES($placeholders)",{dbi_dummy=>__FILE__.__LINE__}); - $insert->execute($leftmost||1,$leftmost||1,@$values); - $insert->finish(); - my $new_id; - if ($self->{no_id_creation}) { - $new_id=$params{provided_primary_key}; - } else { - ($new_id)=$dbh->selectrow_array("select max($id_name) from $table"); - } - $self->_unlock_tables(); - return $new_id; -} -######################################## - - -################################################################################ -sub _alter_sql_for_provided_primary_key_edits{ - my($self,$columns,$placeholders,$values,$params)=@_; - my $id_name=$self->{id_name}; - $$columns.=",$id_name"; - $$placeholders.=',?'; - push @$values, $params->{provided_primary_key}; -} -######################################## - - -################################################################################ -sub _alter_table_if_needed{ - #$params is an arrayref with all the proper columns in order. - my ($self,$params)=@_; - - #We don't want to invoke the "automagical" table altering behavior - return if(defined $self->{no_alter_table}); - - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $dbh=$self->{dbh}; - my $id_name=$self->{id_name}; - - #my %columns_we_are_requesting=map{$_=>1} @$params; - my @columns_we_need_to_create; - #With MySQL I could use "Explain $table" but I'd like this to be a bit more cross-RDBMS - my $get_columns=$dbh->prepare_cached("select *,count(*) as _ignore_me_sdfas from $table group by $id_name", - {dbi_dummy=>__FILE__.__LINE__}); - $get_columns->execute(); - my %columns_that_we_have=(); - foreach(@{$get_columns->{NAME}}){ - $columns_that_we_have{$_}=1 if($_ ne '_ignore_me_sdfas'); - } - $get_columns->finish(); - foreach(@$params){ - push @columns_we_need_to_create, $_ if(not defined $columns_that_we_have{$_}); - } - my $db_obj=$self->{_db_obj}; - foreach(@columns_we_need_to_create){ - croak('"'.$_."\" doesn't look like a valid SQL table or column name to me") - unless ($_ =~ m/^[_A-Za-z\d]+$/); - $db_obj->_alter_table($_); - $dbh->do("create index $_ on $table($_)"); - } -} -######################################## - - -################################################################################ -sub _get_params_and_values{ - my ($self,$params,$left,$right,$id_name,$no_left_or_right)=@_; - my %ignore=( - $left=>1, - $right=>1, - $id_name=>1, - provided_primary_key=>1 - ); - my @params=($no_left_or_right) ? () :($left,$right); #Keep in order. . . - my @values; - foreach my $column (keys %$params){ - if (not defined $ignore{$column}){ - push @params, $column; - push @values, $params->{$column}||'' - } - } - return (\@params,\@values); -} -######################################## - - -################################################################################ -sub edit_node{ - my ($self,%params)=@_; - my $dbh=$self->{dbh}; - - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - #If they have changed the id_name but still pass in the id to act upon via the "id" parameter, - #fix it here. This is for backwards compatibility - $params{$id_name}=$params{id}; - } - $self->_lock_tables(); - my ($params,$values)=$self->_get_params_and_values(\%params,$left,$right,$id_name,1); - my ($columns)=_prepare_columns_and_placeholders_for_edit($params); - $self->_alter_table_if_needed($params); - my $update=$dbh->prepare_cached( - "update $table set $columns where $id_name=?", - {dbi_dummy=>__FILE__.__LINE__} - ); - my $id_value=$params{$id_name}; - $update->execute(@$values,$id_value); - $update->finish(); - $self->_unlock_tables(); -} -######################################## - - -################################################################################ -sub _prepare_columns_and_placeholders_for_edit{ - my ($params)=@_; - my $columns=join('=? ,',(@$params)).'=?'; - return ($columns); -} -######################################## - - -################################################################################ -sub _prepare_columns_and_placeholders_for_adding_child_to_right{ - my ($params,$left,$right)=@_; - my $columns=join(',',(@$params)); - my $placeholders=join(',',('?','? + 1')). - ((scalar @$params -2 > 0) ? ',':''). #If there isn't more than 2 params, don't put in a comma - substr(('?,' x (scalar @$params -2 )),0,-1); - return ($columns,$placeholders); -} -######################################## - - -################################################################################ -sub _prepare_columns_and_placeholders_for_adding_child_to_left{ - my ($params,$left,$right)=@_; - my $columns=join(',',(@$params)); - my $placeholders=join(',',('? + 1','? + 2')). - ((scalar @$params -2 > 0) ? ',':''). #If there isn't more than 2 params, don't put in a comma - substr(('?,' x (scalar @$params -2 )),0,-1); - return ($columns,$placeholders); -} -######################################## - - -################################################################################ -sub get_id_by_key{ - my($self,%params)=@_; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $key_name=$params{key_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - #If they have changed the id_name but still pass in the id to act upon via the "id" parameter, - #fix it here. This is for backwards compatibility - $params{$id_name}=$params{id}; - } - my $ids=$self->{dbh}->selectcol_arrayref("select $id_name from $table where $key_name = ?",undef,($params{key_value})); - return (@$ids > 1) ? $ids : $ids->[0] ; -} -######################################## - - -################################################################################ -sub get_self_and_parents_flat{ - my($self,%params)=@_; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - #If they have changed the id_name but still pass in the id to act upon via the "id" parameter, - #fix it here. This is for backwards compatibility - $params{$id_name}=$params{id}; - } - my $prepared_get_self_and_parents_flat_SQL_statement= - $dbh->prepare_cached( - "select n2.* from $table as n1, $table as n2 where (n1.$left between n2.$left and n2.$right) and (n1.$id_name=?) order by n2.$left", - {dbi_dummy=>__FILE__.__LINE__} - ); - - my $tree_structure=$dbh->selectall_arrayref($prepared_get_self_and_parents_flat_SQL_statement, - {Columns=>{}}, - ($params{$id_name} || 1) - ); - my $level=1; - foreach(@$tree_structure){ - $_->{level}=$level; - $level++; - } - return $tree_structure; -} -######################################## - - -################################################################################ -sub get_parents_flat{ - my $self=shift; - my $tree=$self->get_self_and_parents_flat(@_); - my $poo=pop @$tree if(@$tree); - return $tree; -} -######################################## - - -################################################################################ -sub delete_self_and_children{ - my ($self,%params)=@_; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - # If they have changed the name of the id field - # but still pass in IDs with the old "id" moniker, fix it here. - - $params{$id_name}=$params{id}; - } - if(!$params{$id_name}){ - carp("You didn't give us an ID that we could start the delete from"); - return []; - } else { - $self->_lock_tables(); - my $ids; - if($params{not_self}){ - #We don't want to delete the starting node. - #Start with the next level and go through them. - - my $outer_tree=$self->get_children_flat(id=>$params{$id_name},depth=>1); - foreach my $outer_node(@$outer_tree){ - my $temp_tree=$self->get_self_and_children_flat(id=>$outer_node->{$id_name}); - $self->_delete_node(id=>$outer_node->{$id_name}); - foreach my $inner_node (@$temp_tree){ - push @$ids,$inner_node->{$id_name}; - } - } - - } else { - #Delete it all. Hasta la bye-bye! - my $tree=$self->get_self_and_children_flat(id=>$params{$id_name}); - $self->_delete_node(%params); - foreach my $node (@$tree){ - push @$ids,$node->{$id_name}; - } - } - $self->_unlock_tables(); - return $ids; - } -} -######################################## - - -################################################################################ -sub delete_children{ - my $self=shift; - $self->delete_self_and_children(@_,not_self=>1); -} -######################################## - - -################################################################################ -sub _delete_node{ - my($self,%params)=@_; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - my $dbh=$self->{dbh}; - my $node_info=$self->get_hashref_of_info_by_id($params{$id_name}); - - my $prepared_delete_node_delete_statement= - $dbh->prepare_cached( - "delete from $table where $left between ? and ?", - {dbi_dummy=>__FILE__.__LINE__} - ); - - $prepared_delete_node_delete_statement->execute($node_info->{$left},$node_info->{$right}); - $prepared_delete_node_delete_statement->finish(); - - my $prepared_delete_node_fix_nodes= - $dbh->prepare_cached( - "UPDATE $table - SET $left = CASE - WHEN $left > ? THEN $left - (? - ? + 1) - ELSE $left - END, - $right = CASE - WHEN $right > ? THEN $right - (? - ? + 1) - ELSE $right - END - WHERE $right > ?", - {dbi_dummy=>__FILE__.__LINE__} - ); - - $prepared_delete_node_fix_nodes->execute( - $node_info->{$left}, - $node_info->{$right}, - $node_info->{$left}, - $node_info->{$right}, - $node_info->{$right}, - $node_info->{$left}, - $node_info->{$left}, - ); - $prepared_delete_node_fix_nodes->finish(); -} -######################################## - - -################################################################################ -sub get_self_and_children_flat{ - my($self,%params)=@_; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - if((defined $params{id}) and ($id_name ne 'id')){ - # If they have changed the id name but still pass in the ID value in the id parameter, fix it. - $params{$id_name}=$params{id} - } - my $id_SQL; - if (defined $params{$id_name}) { - my ($left_value,$right_value,$depth_value)=$dbh->selectrow_array("select $left,$right,depth from $table where $id_name=?",undef,($params{$id_name})); - $id_SQL="where $left between " . $dbh->quote($left_value)." and ".$dbh->quote($right_value); - if (defined $params{depth}) { - $id_SQL .= " having level <=".($params{depth} + $depth_value+2); - } - } - my $sql ="select depth+2 as level,$table.* from $table $id_SQL order by $left"; - my $tree_structure=$dbh->selectall_arrayref($sql,{Columns=>{}}); - return $tree_structure; -} -######################################## - - -################################################################################ -sub get_children_flat{ - my $self=shift; - my $tree=$self->get_self_and_children_flat(@_); - my $poo=shift @$tree if(@$tree); - return $tree; -} -######################################## - - -################################################################################ -sub swap_nodes{ - my($self,%params)=@_; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - - my $first_id=$params{first_id}; - my $second_id=$params{second_id}; - croak("You didn't give me valid IDs to swap!\n") if(! $first_id || ! $second_id); - croak("You can't switch a node with itself!\n") if($first_id eq $second_id); - - $self->_lock_tables(); - my $first_id_info=$self->get_hashref_of_info_by_id($first_id); - my $second_id_info=$self->get_hashref_of_info_by_id($second_id); - - my ($left_node,$right_node); - if($first_id_info->{$left} < $second_id_info->{$left}){ - $left_node=$first_id_info; - $right_node=$second_id_info; - } else { - $left_node=$second_id_info; - $right_node=$first_id_info; - } - $dbh->do(qq|update $table set - $left = - CASE WHEN $left between $left_node->{$left} and $left_node->{$right} - THEN $right_node->{$right} + $left - $left_node->{$right} - WHEN $left between $right_node->{$left} and $right_node->{$right} - THEN $left_node->{$left} + $left - $right_node->{$left} - ELSE $left_node->{$left} + $right_node->{$right} + $left - $left_node->{$right} - $right_node->{$left} END, - $right = - CASE WHEN $right between $left_node->{$left} and $left_node->{$right} - THEN $right_node->{$right} + $right - $left_node->{$right} - WHEN $right between $right_node->{$left} and $right_node->{$right} - THEN $left_node->{$left} + $right - $right_node->{$left} - ELSE $left_node->{$left} + $right_node->{$right} + $right - $left_node->{$right} - $right_node->{$left} END - WHERE ($left between $left_node->{$left} and $right_node->{$right}) - AND $left_node->{$left} < $left_node->{$right} - AND $left_node->{$right} < $right_node->{$left} - AND $right_node->{$left} < $right_node->{$right}|); - - $self->_unlock_tables(); -} -######################################## - - -################################################################################ -sub get_hashref_of_info_by_id{ - my ($self,$value)=@_; - my $dbh=$self->{dbh}; - my $id_name=$self->{id_name}; - #This excessively explicit quoting is to work around the buggy Mandrake 10.0 version of DBD::mysql - return $dbh->selectrow_hashref("select * from ".$self->{table_name}." where $id_name = ".$dbh->quote($value)); -} -######################################## - - -################################################################################ -sub get_hashref_of_info_by_id_with_level{ - my $self=shift; - my $wanted_id=shift; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id_name=$self->{id_name}; - return $self->{dbh}->selectrow_hashref("select count(n2.$id_name) as level,n1.* from $table as n1, $table as n2 where (n1.$left between n2.$left and n2.$right) and n1.$id_name=? group by n1.$id_name",undef,($wanted_id)); -} -######################################## - - -################################################################################ -sub create_report{ - my ($self,%params)=@_; - my $id_name=$self->{id_name}; - my $ancestors=$self->get_self_and_children_flat(id => $params{$id_name}||$self->get_root); - my $report; - foreach (@$ancestors) { - $report.= (($_->{level} > 1) ? ((" " x ($params{indent_level} || 2)) x ($_->{level} - 1)) :''); - $report.= $_->{name}." (".$_->{$id_name}.")(".$_->{level}.")\n"; - } - return $report; -} -######################################## - - -################################################################################ -sub create_default_table{ - my $self=shift; - $self->{_db_obj}->_create_default_table(); -} -######################################## - - -################################################################################ -sub get_default_create_table_statement{ - my $self=shift; - $self->{_db_obj}->_get_default_create_table_statement(); -} -######################################## - - -1; - -__END__ - -=pod - -=head1 NAME - -DBIx::Tree::NestedSet - -=head1 SYNOPSIS - -Implements a "Nested Set" parent/child tree. Example: - - #!/usr/bin/perl - #This is in "scripts/tree_example.pl" of DBIx::Tree::NestedSet distribution - use strict; - use warnings; - use DBIx::Tree::NestedSet; - use DBI; - - #Create the connection. We'll use SQLite for now. - #my $dbh=DBI->connect('DBI:mysql:test','user','pass') or die ($DBI::errstr); - my $dbh=DBI->connect('DBI:SQLite:test') or die ($DBI::errstr); - - my $db_type='SQLite'; - #my $db_type='MySQL'; - my $tree=DBIx::Tree::NestedSet->new( - dbh=>$dbh, - db_type=>$db_type - ); - - #Let's see how the table will be created for this driver - print "Default Create Table Statement for $db_type:\n"; - print $tree->get_default_create_table_statement()."\n"; - - #Let's create it. - $tree->create_default_table(); - - #Create the root node. - my $root_id=$tree->add_child_to_right(name=>'Food'); - - #Second level - my $vegetable_id=$tree->add_child_to_right(id=>$root_id,name=>'Vegetable'); - my $animal_id=$tree->add_child_to_right(id=>$root_id,name=>'Animal'); - my $mineral_id=$tree->add_child_to_right(id=>$root_id,name=>'Mineral'); - - #Third Level, under "Vegetable" - foreach ('Froot','Beans','Legumes','Tubers') { - $tree->add_child_to_right(id=>$vegetable_id,name=>$_); - } - - #Third Level, under "Animal" - foreach ('Beef','Chicken','Seafood') { - $tree->add_child_to_right(id=>$animal_id,name=>$_); - } - - #Hey! We forgot pork! Since it's the other white meat, - #it should be first among the "Animal" crowd. - $tree->add_child_to_left(id=>$animal_id,name=>'Pork'); - - #Oops. Misspelling. - $tree->edit_node( - id=>$tree->get_id_by_key(key_name=>'name',key_value=>'Froot'), - name=>'Fruit' - ); - - #Get the child nodes of the 2nd level "Animal" node - my $children=$tree->get_self_and_children_flat(id=>$animal_id); - - #Grab the first node, which is "Animal" and the - #parent of this subtree. - my $parent=shift @$children; - - print 'Parent Node: '.$parent->{name}."\n"; - - #Loop through the children and do something. - foreach my $child(@$children) { - print ' Child ID: '.$child->{id}.' '.$child->{name}."\n"; - } - - #Mineral? Get rid of it. - $tree->delete_self_and_children(id=>$mineral_id); - - #Print the rudimentary report built into the module. - print "\nThe Complete Tree:\n"; - print $tree->create_report(); - -=head1 DESCRIPTION - -This module implements a "Nested Set" parent/child tree, and is focused (at least in my mind) towards offering methods that make developing web applications easier. It should be generally useful, though. - -See the "SEE ALSO" section for resources that explain the advantages and features of a nested set tree. This module gives you arbitrary levels of nodes, the ability to put in metadata associated with a node via simple method arguments and storage via DBI. - -There are currently drivers implemented for MySQL and SQLite. It should be trivial to write one for your RDBMS, see DBIx::Tree::NestedSet::MySQL for an example driver. - -A nested set tree is "expensive" on updates because you have to edit quite a bit of the tree on inserts, deletes, or the movement of nodes. Conversely, it is "cheaper" on just queries of the tree because nearly every action (getting children, getting parents, getting siblings, etc) can be done B. - -If you're developing apps that require many reads and few updates to a tree (like pretty much every web app I've ever built) a nested set should offer significant performance advantages over the recursive queries required by the typical adjacency list model. - -Whew. Say that fast three times. - -Use the create_default_table() method to create your Nested Set table in your RDBMS. - -=head1 METHODS - -=head2 new - -new() accepts a number of parameters. You MUST pass new() a valid DBI handle. - -=over 4 - -=item dbh - -The DBI handle returned by DBI::connect(). - -=item id_name - -The name of the unique ID associated with this node. Defaults to "id". If you change the name of the id, you should refer to it in every other method with the name you assigned here. - -=item left_column_name - -The name of the column that describes the left hand side of a node. Defaults to "lft". - -=item right_column_name - -The name of the column that describes the right hand side of a node. Defaults to "rght". - -=item table_name - -The name of the table that describes the nested set. Defaults to "nested_set". - -=item No_RaiseError - -By default this module will turn on the "RaiseError" attribute in $dbh. Setting the "No_RaiseError" value to true (because you do not want RaiseError enabled or because it is turned it on elsewhere) will disable this behavior. You should probably leave this alone. - -=item no_locking - -Setting this option to a true value will disable locking for methods that alter the tree stored via DBI. Currently, we lock the entire table, as most "editing" methods have the potential to edit every value on even minor changes. - -=item no_alter_table - -Don't do the automagical table altering stuff used to create columns on-the-fly. See "add_child_to_right" for a description of how this module stores meta-data. Turning off the automagical table altering will probably increase performance, but you won't be able to add in meta-data whenever you want on adding or updating nodes. - -Turning off automagical table altering will cause the module to error out if you try and add in new meta-data that doesn't have a column defined for it in the DBI table. You are warned. - -It probably makes sense to turn off automagical table altering after you've put the application into production and you're done development, but that depends on how you build your app. - -=item trace - -Will turn on DBI::trace() at the level you specify here and output some additional debugging info to STDERR. - -=item db_type - -The type of RDBMS you're using, currently drivers are only implemented for MySQL and SQLite. Defaults to MySQL if not defined. Drivers abstract non-portable (or non-implemented) SQL. See L and L for examples. - -=item no_id_creation - -Set this to a true value if you want to manually provide primary keys for new nodes. You must ensure that the primary keys aren't duplicates on your own: this is your responsibility if you turn this option on. The default is false, meaning that the RDBMS will handle the creation of IDs via built in "auto increment" or "sequence" features. If you do want to provide your own primary keys, remember to alter the table. Normally you should ignore this feature and let the RDBMS handle creating ids for you. - -See also: add_child_to_left(), add_child_to_right(). - -=back - -Examples: - - #Create a nested set tree object, including the default nested_set table - my $tree=DBIx::Tree::NestedSet->new(dbh=>$dbh); - $tree->create_default_table(); - - #Create a nested set tree using SQLite and a few tweaked defaults - my $tree=DBIx::Tree::NestedSet->new(dbh=>$dbh,db_type=>'SQLite',id_name=>'pageID'); - $tree->create_default_table(); - -=head2 create_default_table - -Create a Nested Set table in the data source defined in $dbh that will work for the db_type you specify in new(). Any options (id_name, left_column_name, etc.) you pass to new() will be respected as well. This default table is defined in the driver file for your RDBMS. - -=head2 get_default_create_table_statement - -Return the SQL used to create the table above as a scalar, but don't create it. - -=head2 get_root - -Gets the id of the "root" node of the tree. - -=head2 add_child_to_right - -This will add a child to the "right" of all its siblings, kind of like "push()ing" onto the bottom of an array. It will be the last child under its parent. - -Takes the following parameters as a hash: - -=over 4 - -=item id - -The ID of the parent node we want to add the child to. If you don't give an ID or the id isn't valid, it will add the child under the root node. If you changed the name of "id" in new(), use that name here. - -=back - -Any other parameter passed in as a hash will get stored in the table. If the column doesn't exist, the module will alter the table to add it, and then store that data for you. Example: - -Say you have a table that looks like: - - +----------+--------------+------+-----+---------+----------------+ - | Field | Type | Null | Key | Default | Extra | - +----------+--------------+------+-----+---------+----------------+ - | id | mediumint(9) | | PRI | NULL | auto_increment | - | lft | mediumint(9) | | MUL | 0 | | - | rght | mediumint(9) | | MUL | 0 | | - | name | varchar(255) | | MUL | | | - +----------+--------------+------+-----+---------+----------------+ - -and you execute: - - $tree->add_child_to_right(id=>$tree->get_root(),name=>'Baked Goods',raisins=>'no'); - -Then the module will create a node named "Baked Goods" under the root as the "rightmost" child. The "raisins" column will be created and "no" will be put in it for this node. The table would then look like: - - +----------+--------------+------+-----+---------+----------------+ - | Field | Type | Null | Key | Default | Extra | - +----------+--------------+------+-----+---------+----------------+ - | id | mediumint(9) | | PRI | NULL | auto_increment | - | lft | mediumint(9) | | MUL | 0 | | - | rght | mediumint(9) | | MUL | 0 | | - | name | varchar(255) | | MUL | | | - | raisins | varchar(255) | | MUL | | | - +----------+--------------+------+-----+---------+----------------+ - -Feel free to tweak the columns after the module creates them (or create them in advance, it doesn't really matter). You may want to add indeces if you're going to be doing other selects on the nested_set table. - -This table altering behavior allows you to store metadata about a node simply, with a tradeoff that your metadata could be "flat" and potentially poorly normalized. - -This method returns the id of the newly added child. - -Note: If you are providing your own non-duplicate primary keys (via the "no_id_creation" option passed to "new()"), pass another parameter named "provided_primary_key" with the value of the primary key you want for this new node. The "provided_primary_key" will be used for this node. - -Example of providing your own primary key for a new node: - - $tree->add_child_to_right(id=>$parent_id,name=>'Biscuits',provided_primary_key=>$new_unique_key); - -If you're letting the RDBMS handle generating ids for you (as you should), you can ignore this whole note. - -=head2 add_child_to_left - -Same as add_child_to_right, except this puts the child to the left of its siblings. It will be the first child under the parent node. - -=head2 edit_node - -Edits a node and will exhibit the same "table altering" behavior of add_child_to_right or add_child_to_left. Pass in parameters as a hash, and "id" controls which node you're editing. - -Example: - - #All other values are retained, we're just changing the name of the node - #with the id in "$edit_id" - $tree->edit_node(id=>$edit_id,name=>'Pizza'); - -=head2 get_id_by_key - -Looks up a node(s) by a key name and key value. Takes two parameters: - -=over 4 - -=item key_name - -The name of the column in the database you're doing a lookup on. - -=item key_value - -The value you want to look up. - -=back - -If there is more than one node found, we return an array reference. Otherwise we return a scalar. If nothing is found, you'll get a non-true value. - -Example: - - my $node=$tree->get_id_by_key(key_name=>'name',key_value=>'Foo Name'); - if (! $node){ - #no matching node found. - elsif(ref $node eq 'ARRAY'){ - #We have more than one id returned. - } else { - #We have a single id/node. - } - -=head2 get_self_and_parents_flat - -This will get a node and its parents down to the root node. Takes the id of the starting node as a hash. - -Returns an arrayref of hashrefs (AoH). The hashrefs will have as keys the column names of the table, including those automatically added by the add_*() and edit_node() methods. - -This method does NOT return a "nested hash" or "nested array" of nodes, hence the "flat" in the method name. - -Additionally there will be a "level" hashkey that's the level of the node, with level 1 being the root. - -Example: - - my $self_and_parents=$tree->get_self_and_parents(id=>$starting_id); - foreach(@$self_and_parents){ - print 'ID: '.$_->{id}.' is at level '.$_->{level}."\n"; - } - -Besides arrays of hashrefs being easy to use, this object is PERFECT for passing to HTML::Template::param(). Returns non-true in the event a node doesn't have parents. - -=head2 get_parents_flat - -Same as get_self_and_parents_flat but excludes the starting node. - -=head2 delete_self_and_children - -Similar to get_self_and_children, but deletes nodes from the starting id inclusively. Returns an arrayref of the IDs that were deleted or a non-true value if none. - -Example: - - my $ids=$tree->delete_self_and_children(id=>$delete_from); - -Will delete from the ID in $delete_from and $ids will contain an arrayref of the deleted IDs. - -=head2 delete_children - -Similar to delete_self_and_children, but leaves the starting id untouched. This method just deletes the children (recursively) of the starting node. - -=head2 get_self_and_children_flat - -Nearly identical to get_self_and_parents flat, except it retrieves the children of the starting node (and the starting node itself) recursively. - -Takes a depth parameter additionally, which will specify how far down in the tree from the starting node to go. - -Example: - - my $self_and_children=$tree->get_self_and_children_flat(id=>$start_id,depth=>2); - -Will retrieve an AoH starting from $start_id going down a maximum of 2 levels. - -=head2 get_children_flat - -Same as get_self_and_children_flat but excludes the starting node. - -=head2 swap_nodes - -Takes two parameters: first_id and second_id. It will "swap" the nodes represented by these ids, essentially replacing one node with the other. Children will tag along. swap_nodes() can be used to reorder nodes in a tree OR swap nodes to different levels within a tree. This method allows you to reorder nodes in the tree. - -Example: - - $tree->swap_nodes(first_id=>$first_id,second_id=>$second_id); - -$first_id and $second_id will be "swapped" in the tree. - -=head2 get_hashref_of_info_by_id - -Will return a hashref of the information associated with a node specified by the "id" parameter. Umm. . . Except "level". - -This is probably dumb, but in this case you don't need to pass in the ID as a hash, because this method only every takes one argument. Returns "undef" if a node without that ID isn't found. - -Example: - - my $node_info=$tree->get_hashref_of_info_by_id($node_id); - print $node_info->{id}; - -=head2 get_hashref_of_info_by_id_with_level - -Just like get_hashref_of_info_by_id, except returns the "level" of the node within the tree as well, where the "root" node is level 1. Computing the level is more expensive, so you should use get_hashref_of_info_by_id normally. - -=head2 create_report - -Returns a very simple report (in a scalar) of the tree. Takes a few parameters: - -=over 4 - -=item id - -The id to start the report from. If none is given, it'll start from the root node. - -=item indent_level - -The number of spaces to indent each level with. Defaults to 2 spaces per level. - -=back - -Example: - - my $report=$tree->create_report(indent_level=>4); - print $report; - -Will create a report starting from the "root" with 4 spaces of indentation per level. - -=head1 TABLE DEFINITION - -The base "nested_set" table definition for MySQL is below. Please see each driver class (L or L currently) for create statements specific to your RDBMS. Columns will be added when you pass extra parameters to methods noted above (even for SQLite), unless "no_alter_table" is set to true in the constructor. - -You can add columns you're going to use proactively, and/or "tweak" the columns after you've let this module create them. Just make sure that you use valid SQL column names for the attributes you pass to the edit_node() and add_*() methods. - - ######################################## - #MySQL specific. - CREATE TABLE nested_set ( - id mediumint(9) NOT NULL primary key, - lft mediumint(9) NOT NULL, - rght mediumint(9) NOT NULL - ); - CREATE INDEX lft nested_set(lft); - CREATE INDEX rght nested_set(rght); - ######################################## - -This module has been tested on MySQL 3.x and 4.x and SQLite 2.x. - -=head1 WHY? - -I've implemented a couple different nested tree models in the past, from a flat "one column per level" monstrosity to a typical "adjacency list" parent/child model. - -The "one column per level" model was a BEAR to work with, especially when it came to adding more levels, editing/deleting children and creating parent lists. - -An "adjacency list" is the typical "id/parent_id" model, as illustrated below: - - food food_id parent_id - ================== ======= ========= - Food 001 NULL - Beans and Nuts 002 001 - Beans 003 002 - Nuts 004 002 - Black Beans 005 003 - Pecans 006 004 - -(That table was ripped off directly from DBIx::Tree) - -The recursive queries involved with "adjacency list" models always bugged me and I couldn't get acceptable performance metrics without caching bits of the tree. - -The "nested set" model appears, theoretically, to be perfect for most of the web applications I develop: it's very fast to create lists of children and parents, at the cost of much more complicated and processor-intense updating. - -I've also taken pains to create methods that are useful for web application development but not specific to it. - -If you have an application that sees many reads of a nested tree but not as many writes or updates, the "nested set" model this module implements should offer significant performance benefits over an adjacency list. - -=head1 SEE ALSO - -DBIx::Tree, which implements an "adjacency list" model of nested trees. - -DBIx::NestedSet::Manage which is included with this distribution and implements a CGI::Application and HTML::Based system for managing trees via DBIx::NestedSet and implements most DBIx::NestedSet methods. - - http://www.intelligententerprise.com/001020/celko.jhtml - http://www.dbmsmag.com/9603d06.html - http://www.dbmsmag.com/9604d06.html - http://www.dbmsmag.com/9605d06.html - http://www.dbmsmag.com/9606d06.html - -For those last three links, the "Nested Set" discussion starts about halfway through the articles. - -=head1 BUGS - -Yes. I'm sure there are some, but this module is in production in several non-trivial apps and it's working smoothly. Please contact me if you find any, though. - -Things to be aware of: - -=over 4 - -=item Custom Names - -Keep the names of columns, the table, and any automagically added meta-data keys to fit m/^[_A-Za-z\d]+$/, which is A-Z, a-z, digits, and the underscore. And don't use SQL reserved words. - -=item Mandrake 10.0 users - -You should update to the latest version of DBI and DBD::mysql, there was apparently a bug with placeholder counting that made this module barf on that distribution. I've worked around this bug, but I can't guarantee anything. Upgrade DBI and DBD::mysql just to be sure. - -=back - -=head1 TODO - -I may implement some or all of these. PATCHES ARE WELCOME! - -=over 4 - -=item * - -Methods to translate an adjacency list into a nested set tree. - -=item * - -The ability to associate other user-defined SQL statements with methods. "Pre-" and "post-" triggered SQL. - -=item * - -Create methods to get children that DO implement "nested array" trees. - -=item * - -Maybe create a "traversal" system other than the very simple: - - my $nodes=$tree->get_self_and_children(id=$tree->get_root); - foreach my $node(@$nodes){ - #do something with the hashref that represents this node. - } - -=back - -=head1 THANKS - -The following folks have provided patches, bug alerts, ideas, guidance and suggestions related directly to this module. THANKS! Sorry if I left anyone out. - -=over 4 - -=item Giuseppe Maxia - -gmax on www.perlmonks.org. He pushed me to make it more RDBMS-independent and offered other suggestions to improve the module and documentation. - -=item Martin Kamerbeek - -www.procolix.com, a core WebGUI developer. One of the original guineau pigs. Bug fixes and feature enhancements. - -=item Hansen - -On www.perlmonks.org, algorithm improvement for node dropping. - -=item Tilly - -On www.perlmonks.org for the original idea. - -=back - -=head1 AUTHOR - -Dan Collis Puro, Geekuprising.com. Email: dan at geekuprising dot com. - -This model was inspired by the perlmonks.org thread below: - -http://www.perlmonks.org/index.pl?node_id=354049 - -See "Tilly's" response in particular. I'm "Hero Zzyzzx". - -=head1 LICENSE - -This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - -=cut diff --git a/lib/DBIx/Tree/NestedSet/Manage.pm b/lib/DBIx/Tree/NestedSet/Manage.pm deleted file mode 100644 index c1b5c2000..000000000 --- a/lib/DBIx/Tree/NestedSet/Manage.pm +++ /dev/null @@ -1,356 +0,0 @@ -package DBIx::Tree::NestedSet::Manage; - -use strict; -use Carp; -use base 'CGI::Application'; -$DBIx::Tree::NestedSet::Manage::VERSION='0.12'; - -#POD Below!! - -################################################################################ -sub setup { - my $self=shift; - $self->start_mode('show_nodes'); - $self->mode_param('rm'); - $self->run_modes( - show_nodes=>'show_nodes', - add_child_form=>'add_child_form', - move_up=>'move_up', - move_down=>'move_down', - delete_node=>'delete_node', - edit_node=>'edit_node', - denied=>'denied', - 'AUTOLOAD'=>'show_nodes' - ); -} -######################################## - - -################################################################################ -sub cgiapp_init{ - my $self=shift; - my $q=$self->query(); - $self->param( - template=>$self->load_tmpl( - $self->param('template_name'), - die_on_bad_params=>0 - ) - ); -} -######################################## - - -################################################################################ -sub stuff_in_extra_info{ - my ($self,$array)=@_; - my $q=$self->query(); - my $script_name=$q->script_name(); - my $upper_sibling; - my $lower_sibling; - my $i=1; - foreach (@$array) { - $_->{LOWER_SIBLING}=$array->[$i]->{id} if($array->[$i]); - $_->{UPPER_SIBLING}=$upper_sibling; - $_->{SCRIPT_NAME}=$script_name; - $upper_sibling=$_->{id}; - $i++; - } -} -######################################## - - -################################################################################ -sub show_nodes{ - my $self=shift; - my $q=$self->query(); - my $tree=$self->param('tree'); - my $template=$self->param('template'); - my $id = $q->param('id') || $self->param('start_root') || $tree->get_root(); - - my $current_nodes=$tree->get_children_flat( - id => $id, - depth => 1 - ); - #my $foo=shift @$current_nodes; - my $parents=$tree->get_self_and_parents_flat(id=>$id); - - $self->stuff_in_extra_info($parents); - $self->stuff_in_extra_info($current_nodes); - my $node_info=$tree->get_hashref_of_info_by_id($id); - $template->param( - SHOW_NODES=>1, - CURRENT_NODES=>$current_nodes, - PARENTS=>$parents, - CURRENT_ID=>$id, - NAME=>$node_info->{name} - ); - return $template->output(); -} -######################################## - - -################################################################################ -sub redirect_to_category{ - my ($self,$id)=@_; - my $q=$self->query(); - $self->header_type('redirect'); - $self->header_add(-location=>$q->script_name().'?rm=show_nodes;id='.$q->escape($id)); -} -######################################## - - -################################################################################ -sub add_child_form{ - my $self=shift; - my $q=$self->query(); - my $tree=$self->param('tree'); - my $template=$self->param('template'); - my $id = $q->param('id') || $self->param('start_root') || $tree->get_root(); - - my $errors={}; - if($q->param('submit')){ - if(! $q->param('name')){ - $errors->{NO_NAME}=1; - } else { - $tree->add_child_to_right(id=>$id,name=>$q->param('name')); - return $self->redirect_to_category($id); - } - } - my $node_info=$tree->get_hashref_of_info_by_id($id); - my $form .= - $q->start_form(). - $q->hidden(-name=>'rm',-value=>'add_child_form',-override=>1). - $q->hidden(-name=>'id'). - $q->textfield(-name=>'name'). - $q->submit(-name=>'submit'). - $q->end_form(); - $template->param( - ADD_CHILD_FORM=>1, - FORM=>$form, - ERRORS=>$errors, - PARENT=>$node_info->{name}, - ERROR_NO_NAME=>$errors->{NO_NAME} - ); - return $template->output(); -} -######################################## - - -################################################################################ -sub move_up{ - my $self=shift; - my $q=$self->query; - my $tree=$self->param('tree'); - my $up_id=$q->param('up_id'); - my $id=$q->param('id'); - if($id && $up_id){ - my $parents=$tree->get_self_and_parents_flat(id=>$id); - $tree->swap_nodes(first_id=>$id,second_id=>$up_id); - return $self->redirect_to_category($parents->[-2]->{id} || $tree->get_root); - } -} -######################################## - - -################################################################################ -sub move_down{ - my $self=shift; - my $q=$self->query; - my $tree=$self->param('tree'); - my $down_id=$q->param('down_id'); - my $id=$q->param('id'); - if($id && $down_id){ - my $parents=$tree->get_self_and_parents_flat(id=>$id); - $tree->swap_nodes(first_id=>$id,second_id=>$down_id); - return $self->redirect_to_category($parents->[-2]->{id} || $tree->get_root); - } -} -######################################## - - -################################################################################ -sub confirm_node_can_be_deleted{ -# You should customize this method to check for you own -# criteria as to what nodes may be deleted. -# my $self=shift; -# my $dbh=$self->param('dbh'); -# my $q=$self->query(); -# my $tree=$self->param('tree'); -# my $nodes=$tree->get_self_and_children_flat(id=>$q->param('id')); -# my @ids=map{$dbh->quote($_->{id})} @$nodes; -# my $id_sql=join(',',@ids); -# my ($count)=$dbh->selectrow_array(qq|select count(*) from doc_categories where primary_cat in($id_sql)|); -# #If there's a positive count, we can't delete. -# return ($count) ? 0 : 1 ; - return 1; -} -######################################## - - -################################################################################ -sub delete_node{ - my $self=shift; - my $q=$self->query(); - my $tree=$self->param('tree'); - my $id=$q->param('id'); - my $confirm_node_can_be_deleted=$self->confirm_node_can_be_deleted(); - if($q->param('confirm') && $id && $confirm_node_can_be_deleted){ - my $parents=$tree->get_self_and_parents_flat(id=>$id); - $tree->delete_self_and_children(id=>$id); - return $self->redirect_to_category($parents->[-2]->{id} || $tree->get_root); - } else { - my $template=$self->param('template'); - my $node_info=$tree->get_hashref_of_info_by_id($id); - $template->param( - CONFIRM_NODE_DELETION=>1, - NODE_CAN_BE_DELETED=>$confirm_node_can_be_deleted, - SCRIPT_NAME=>$q->script_name(), - NODE_NAME=>$node_info->{name}, - ID=>$id, - ); - return $template->output(); - } -} -######################################## - - -################################################################################ -sub denied{ - return 'Access is denied.'; -} -######################################## - - -################################################################################ -sub edit_node{ - my $self=shift; - my $q=$self->query(); - my $id=$q->param('id'); - my $tree=$self->param('tree'); - my $node_info=$tree->get_hashref_of_info_by_id($id); - - if($q->param('name') && $id){ - # We passed tests. - $tree->edit_node(id=>$id,name=>$q->param('name')); - my $parents=$tree->get_self_and_parents_flat(id=>$id); - return $self->redirect_to_category($parents->[-2]->{id} || $tree->get_root); - } else { - my $form={}; - $form->{START_FORM}=$q->start_form(). - $q->hidden(-name=>'rm',-value=>'edit_node',-override=>1). - $q->hidden(-name=>'id'); - $form->{NAME_TEXTFIELD}= $q->textfield(-name=>'name',-value=>$node_info->{name}); - $form->{SUBMIT}=$q->submit(-name=>'submit',-value=>'Edit Node'); - $form->{END_FORM}=$q->end_form(); - - $form->{EDIT_NODE}=1; - $form->{SCRIPT_NAME}=$q->script_name; - $form->{NODE_NAME}=$node_info->{name}; - $form->{ID}=$id; - - my $template=$self->param('template'); - $template->param( - %$form - ); - return $template->output(); - } -} -######################################## - -1; - -__END__ - -=pod - -=head1 NAME - -DBIx::Tree::NestedSet::Manage - -=head1 SYNOPSIS - -A CGI::Application and HTML::Template based helper class that provides an interface to DBIx::Tree::NestedSet methods. - -=head1 DESCRIPTION - -The idea of this module is that you subclass it and add your own cgiapp_prerun(), denied(), and cgiapp_postrun() methods. You should probably tweak the add_child_form() and delete_node() methods too to include the metadata you want in your tree. - -confirm_node_can_be_deleted() should be overridden too, it's used to "confirm" whether or not a node can be deleted without messing up your database. Returning a true value means the node is OK to delete. - -See the "templates", "cgi-bin", and "graphics" directories of this distribution for an example HTML::Template, graphics (thank you to WebGUI) and an instance script. - -Example Module: - - package My::NestedSetTree; - use base 'DBIx::Tree::NestedSet::Manage'; - use strict; - - sub cgiapp_prerun{ - #Controls access to this module. - my $self=shift; - if ($self->access_not_allowed()) { - $self->prerun_mode('denied'); - } else { - return; - } - } - - - sub denied{ - #Content returned if a user isn't allowed to access this module - return 'Access is denied.'; - } - - - sub cgiapp_postrun { - #HTML content to "wrap around" this module. - my $self = shift; - my $output_ref = shift; - - my $new_output = "My Tree"; - $new_output .= $$output_ref; - $new_output .= ""; - - # Replace old output with new output - $$output_ref = $new_output; - } - - sub confirm_node_can_be_deleted{ - #You should customize this method to check for your own - #criteria as to what nodes may be deleted. - my $self=shift; - my $dbh=$self->param('dbh'); - my $q=$self->query(); - my $tree=$self->param('tree'); - my $nodes=$tree->get_self_and_children_flat(id=>$q->param('id')); - my @ids=map{$dbh->quote($_->{id})} @$nodes; - my $id_sql=join(',',@ids); - #Check to see if we have any documents assigned to this category. - my ($count)=$dbh->selectrow_array(qq|select count(*) from doc_categories where primary_cat in($id_sql)|); - #If there's a positive count, we can't delete. - return ($count) ? 0 : 1 ; - } - - - 1; - -=head1 SEE ALSO - -CGI::Application, HTML::Template and DBIx::Tree::NestedSet. - -=head1 AUTHOR - -Dan Collis Puro, Geekuprising.com. Email: dan at geekuprising dot com. - -This model was inspired by the perlmonks.org thread below: - -http://www.perlmonks.org/index.pl?node_id=354049 - -See "Tilly's" response in particular. I'm "Hero Zzyzzx". - -=head1 LICENSE - -This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. - -=cut - diff --git a/lib/DBIx/Tree/NestedSet/MySQL.pm b/lib/DBIx/Tree/NestedSet/MySQL.pm deleted file mode 100644 index 4352447c1..000000000 --- a/lib/DBIx/Tree/NestedSet/MySQL.pm +++ /dev/null @@ -1,111 +0,0 @@ -package DBIx::Tree::NestedSet::MySQL; - -use strict; -use Carp; -$DBIx::Tree::NestedSet::MySQL::VERSION='0.15'; - -################################################################################ -sub new{ - my $class=shift; - $class=ref($class)||$class; - my %params=@_; - my $self={ - dbh => $params{dbh}, - left_column_name => $params{left_column_name} || 'lft', - right_column_name => $params{right_column_name} || 'rght', - table_name => $params{table_name} || 'nested_set', - id_name => $params{id_name} || 'id', - no_alter_table => $params{no_alter_table} || undef, - no_locking => $params{no_locking} || undef - }; - bless $self, $class; -} -######################################## - - -################################################################################ -sub _lock_tables{ - my $self=shift; - if(! defined $self->{no_locking}){ - $self->{dbh}->do(qq|lock tables $self->{table_name} as n1 write, $self->{table_name} as n2 write, $self->{table_name} write|) - } -} -######################################## - - -################################################################################ -sub _unlock_tables{ - my $self=shift; - if(! defined $self->{no_locking}){ - $self->{dbh}->do(qq|unlock tables|) - } -} -######################################## - - -################################################################################ -sub _alter_table{ - my($self,$name)=@_; - my $table=$self->{table_name}; - $self->{dbh}->do("alter table $table add column $name varchar(255) not null default ''"); -} -######################################## - - -################################################################################ -sub _create_default_table{ - my $self=shift; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id=$self->{id_name}; - - $dbh->do(_create_table_statement($table,$id,$left,$right)); -} -######################################## - - -################################################################################ -sub _get_default_create_table_statement{ - my $self=shift; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id=$self->{id_name}; - return _create_table_statement($table,$id,$left,$right); -} -######################################## - - -################################################################################ -sub _create_table_statement{ - my ($table,$id,$left,$right)=@_; - return qq| -CREATE TABLE $table ( - $id mediumint(9) NOT NULL auto_increment, - $left mediumint(9) NOT NULL default '0', - $right mediumint(9) NOT NULL default '0', - PRIMARY KEY ($id), - KEY $left ($left), - KEY $right ($right) - )|; -} -######################################## - -1; - -__END__ - -=pod - -=head1 NAME - -DBIx::Tree::NestedSet::MySQL - -=head1 SYNOPSIS - -A driver class for L that implements a MySQL interface. There are no publicly available methods in this class. - -=cut - diff --git a/lib/DBIx/Tree/NestedSet/SQLite.pm b/lib/DBIx/Tree/NestedSet/SQLite.pm deleted file mode 100644 index 1920cea59..000000000 --- a/lib/DBIx/Tree/NestedSet/SQLite.pm +++ /dev/null @@ -1,135 +0,0 @@ -package DBIx::Tree::NestedSet::SQLite; - -use strict; -use Carp; -$DBIx::Tree::NestedSet::SQLite::VERSION='0.15'; - -################################################################################ -sub new{ - my $class=shift; - $class=ref($class)||$class; - my %params=@_; - my $self={ - dbh => $params{dbh}, - left_column_name => $params{left_column_name} || 'lft', - right_column_name => $params{right_column_name} || 'rght', - table_name => $params{table_name} || 'nested_set', - id_name => $params{id_name} || 'id', - no_alter_table => $params{no_alter_table} || undef, - no_locking => $params{no_locking} || undef - }; - bless $self, $class; -} -######################################## - - -################################################################################ -sub _lock_tables{ - - #Transactions are automatically created by SQLite, according to the docs. - -# my $self=shift; -# if(! defined $self->{no_locking}){ -# $self->{dbh}->do(qq|lock tables $self->{table_name} as n1 write, $self->{table_name} as n2 write, $self->{table_name} write|) -# } -} -######################################## - - -################################################################################ -sub _unlock_tables{ - - #Transactions are automatically created by SQLite, according to the docs. - -# my $self=shift; -# if(! defined $self->{no_locking}){ -# $self->{dbh}->do(qq|unlock tables|) -# } -} -######################################## - - -################################################################################ -sub _alter_table{ - my($self,$name)=@_; - my $table=$self->{table_name}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $dbh=$self->{dbh}; - - my ($base_create)=$dbh->selectrow_array('select sql from sqlite_master where tbl_name = ? and type="table"',undef,($table)); - $base_create =~ s/^\s?create\s+table\s+$table\s?(.+)/$1/gim; - $dbh->do('create temporary table '.$table.'_temp'.$base_create); - $dbh->do("insert into ${table}_temp select * from $table"); - my $recreate=$base_create; - $recreate =~ s/(.+)\)$/$1/gim; - $recreate .= ", $name text not null)"; - my $indeces=$dbh->selectcol_arrayref('select sql from sqlite_master where tbl_name=? and type="index"',undef,($table)); - $dbh->do("drop table $table"); - $dbh->do("create table $table ".$recreate); - foreach (@$indeces) { - $dbh->do($_); - } - $dbh->do("insert into $table select *,'' from ${table}_temp"); - $dbh->do("drop table ".$table."_temp"); -} -######################################## - - -################################################################################ -sub _create_default_table{ - my $self=shift; - my $dbh=$self->{dbh}; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id=$self->{id_name}; - my ($create_table,$index1,$index2)=_create_table_statements($table,$id,$left,$right); - $dbh->do($create_table); - $dbh->do($index1); - $dbh->do($index2); -} -######################################## - - -################################################################################ -sub _create_table_statements{ - my ($table,$id,$left,$right)=@_; - return(qq|CREATE TABLE $table ($id integer primary key, - $left mediumint(9) NOT NULL, - $right mediumint(9) NOT NULL)|, -qq|CREATE INDEX $left on $table($left)|, -qq|CREATE INDEX $right on $table($right)|); -} -######################################## - - -################################################################################ -sub _get_default_create_table_statement{ - my $self=shift; - my $left=$self->{left_column_name}; - my $right=$self->{right_column_name}; - my $table=$self->{table_name}; - my $id=$self->{id_name}; - return(join(";\n",_create_table_statements($table,$id,$left,$right))).";\n"; -} -######################################## - -1; - -=pod - -=head1 NAME - -DBIx::Tree::NestedSet::SQLite - -=head1 SYNOPSIS - -A driver class for L that implements an SQLite interface. There are no publicly available methods in this class. - -=head1 WARNING - -You should use this class and L to create your default table: The way the create table is done in this class is pretty tightly tied to how the "automatic alteration" is done. - -=cut - diff --git a/lib/Tree/DAG_Node.pm b/lib/Tree/DAG_Node.pm deleted file mode 100644 index e403ede32..000000000 --- a/lib/Tree/DAG_Node.pm +++ /dev/null @@ -1,2940 +0,0 @@ - -# -*-Perl-*- Time-stamp: "2001-02-23 11:34:46 MST" - -require 5; -package Tree::DAG_Node; -use Carp (); -use strict; -use vars qw(@ISA $Debug $VERSION); - -$Debug = 0; -$VERSION = "1.04"; - -=head1 NAME - -Tree::DAG_Node - (super)class for representing nodes in a tree - -=head1 SYNOPSIS - -Using as a base class: - - package Game::Tree::Node; # or whatever you're doing - use Tree::DAG_Node; - @ISA = qw(Tree::DAG_Node); - ...your own methods overriding/extending - the methods in Tree::DAG_Node... - -Using as a class of its own: - - use Tree::DAG_Node; - my $root = Tree::DAG_Node->new(); - $root->name("I'm the tops"); - my $new_daughter = $root->new_daughter; - $new_daughter->name("More"); - ... - -=head1 DESCRIPTION - -This class encapsulates/makes/manipulates objects that represent nodes -in a tree structure. The tree structure is not an object itself, but -is emergent from the linkages you create between nodes. This class -provides the methods for making linkages that can be used to build up -a tree, while preventing you from ever making any kinds of linkages -which are not allowed in a tree (such as having a node be its own -mother or ancestor, or having a node have two mothers). - -This is what I mean by a "tree structure", a bit redundantly stated: - -* A tree is a special case of an acyclic directed graph. - -* A tree is a network of nodes where there's exactly one root -node (i.e., 'the top'), and the only primary relationship between nodes -is the mother-daugher relationship. - -* No node can be its own mother, or its mother's mother, etc. - -* Each node in the tree has exactly one "parent" (node in the "up" -direction) -- except the root, which is parentless. - -* Each node can have any number (0 to any finite number) of daughter -nodes. A given node's daughter nodes constitute an I list. -(However, you are free to consider this ordering irrelevant. -Some applications do need daughters to be ordered, so I chose to -consider this the general case.) - -* A node can appear in only one tree, and only once in that tree. -Notably (notable because it doesn't follow from the two above points), -a node cannot appear twice in its mother's daughter list. - -* In other words, there's an idea of up (toward the root) versus -down (away from the root), and left (i.e., toward the start (index 0) -of a given node's daughter list) versus right (toward the end of a -given node's daughter list). - -Trees as described above have various applications, among them: -representing syntactic constituency, in formal linguistics; -representing contingencies in a game tree; representing abstract -syntax in the parsing of any computer language -- whether in -expression trees for programming languages, or constituency in the -parse of a markup language document. (Some of these might not use the -fact that daughters are ordered.) - -(Note: B-Trees are a very special case of the above kinds of trees, -and are best treated with their own class. Check CPAN for modules -encapsulating B-Trees; or if you actually want a database, and for -some reason ended up looking here, go look at L.) - -Many base classes are not usable except as such -- but Tree::DAG_Node -can be used as a normal class. You can go ahead and say: - - use Tree::DAG_Node; - my $root = Tree::DAG_Node->new(); - $root->name("I'm the tops"); - $new_daughter = Tree::DAG_Node->new(); - $new_daughter->name("More"); - $root->add_daughter($new_daughter); - -and so on, constructing and linking objects from Tree::DAG_Node and -making useful tree structures out of them. - -=head1 A NOTE TO THE READER - -This class is big and provides lots of methods. If your problem is -simple (say, just representing a simple parse tree), this class might -seem like using an atomic sledgehammer to swat a fly. But the -complexity of this module's bells and whistles shouldn't detract from -the efficiency of using this class for a simple purpose. In fact, I'd -be very surprised if any one user ever had use for more that even a -third of the methods in this class. And remember: an atomic -sledgehammer B kill that fly. - -=head1 OBJECT CONTENTS - -Implementationally, each node in a tree is an object, in the sense of -being an arbitrarily complex data structure that belongs to a class -(presumably Tree::DAG_Node, or ones derived from it) that provides -methods. - -The attributes of a node-object are: - -=over - -=item mother -- this node's mother. undef if this is a root. - -=item daughters -- the (possibly empty) list of daughters of this node. - -=item name -- the name for this node. - -Need not be unique, or even printable. This is printed in some of the -various dumper methods, but it's up to you if you don't put anything -meaningful or printable here. - -=item attributes -- whatever the user wants to use it for. - -Presumably a hashref to whatever other attributes the user wants to -store without risk of colliding with the object's real attributes. -(Example usage: attributes to an SGML tag -- you definitely wouldn't -want the existence of a "mother=foo" pair in such a tag to collide with -a node object's 'mother' attribute.) - -Aside from (by default) initializing it to {}, and having the access -method called "attributes" (described a ways below), I don't do -anything with the "attributes" in this module. I basically intended -this so that users who don't want/need to bother deriving a class -from Tree::DAG_Node, could still attach whatever data they wanted in a -node. - -=back - -"mother" and "daughters" are attributes that relate to linkage -- they -are never written to directly, but are changed as appropriate by the -"linkage methods", discussed below. - -The other two (and whatever others you may add in derived classes) are -simply accessed thru the same-named methods, discussed further below. - -=head2 ABOUT THE DOCUMENTED INTERFACE - -Stick to the documented interface (and comments in the source -- -especially ones saying "undocumented!" and/or "disfavored!" -- do not -count as documentation!), and don't rely on any behavior that's not in -the documented interface. - -Specifically, unless the documentation for a particular method says -"this method returns thus-and-such a value", then you should not rely on -it returning anything meaningful. - -A I acquintance with at least the broader details of the source -code for this class is assumed for anyone using this class as a base -class -- especially if you're overriding existing methods, and -B if you're overriding linkage methods. - -=head1 MAIN CONSTRUCTOR, AND INITIALIZER - -=over - -=item the constructor CLASS->new() or CLASS->new({...options...}) - -This creates a new node object, calls $object->_init({...options...}) -to provide it sane defaults (like: undef name, undef mother, no -daughters, 'attributes' setting of a new empty hashref), and returns -the object created. (If you just said "CLASS->new()" or "CLASS->new", -then it pretends you called "CLASS->new({})".) - -Currently no options for putting in {...options...} are part -of the documented interface, but the options is here in case -you want to add such behavior in a derived class. - -Read on if you plan on using Tree::DAG_New as a base class. -(Otherwise feel free to skip to the description of _init.) - -There are, in my mind, two ways to do object construction: - -Way 1: create an object, knowing that it'll have certain uninteresting -sane default values, and then call methods to change those values to -what you want. Example: - - $node = Tree::DAG_Node->new; - $node->name('Supahnode!'); - $root->add_daughter($node); - $node->add_daughters(@some_others) - -Way 2: be able to specify some/most/all the object's attributes in -the call to the constructor. Something like: - - $node = Tree::DAG_Node->new({ - name => 'Supahnode!', - mother => $root, - daughters => \@some_others - }); - -After some deliberation, I've decided that the second way is a Bad -Thing. First off, it is B markedly more concise than the first -way. Second off, it often requires subtly different syntax (e.g., -\@some_others vs @some_others). It just complicates things for the -programmer and the user, without making either appreciably happier. - -(This is not to say that options in general for a constructor are bad --- C, discussed far below, necessarily takes options. -But note that those are not options for the default values of -attributes.) - -Anyway, if you use Tree::DAG_Node as a superclass, and you add -attributes that need to be initialized, what you need to do is provide -an _init method that calls $this->SUPER::_init($options) to use its -superclass's _init method, and then initializes the new attributes: - - sub _init { - my($this, $options) = @_[0,1]; - $this->SUPER::_init($options); # call my superclass's _init to - # init all the attributes I'm inheriting - - # Now init /my/ new attributes: - $this->{'amigos'} = []; # for example - } - -...or, as I prefer when I'm being a neat freak: - - sub _init { - my($this, $options) = @_[0,1]; - $this->SUPER::_init($options); - - $this->_init_amigos($options); - } - - sub _init_amigos { - my $this = $_[0]; - # Or my($this,$options) = @_[0,1]; if I'm using $options - $this->{'amigos'} = []; - } - - -In other words, I like to have each attribute initialized thru a -method named _init_[attribute], which should expect the object as -$_[0] and the the options hashref (or {} if none was given) as $_[1]. -If you insist on having your _init recognize options for setting -attributes, you might as well have them dealt with by the appropriate -_init_[attribute] method, like this: - - sub _init { - my($this, $options) = @_[0,1]; - $this->SUPER::_init($options); - - $this->_init_amigos($options); - } - - sub _init_amigos { - my($this,$options) = @_[0,1]; # I need options this time - $this->{'amigos'} = []; - $this->amigos(@{$options->{'amigos'}}) if $options->{'amigos'}; - } - -All this bookkeeping looks silly with just one new attribute in a -class derived straight from Tree::DAG_Node, but if there's lots of new -attributes running around, and if you're deriving from a class derived -from a class derived from Tree::DAG_Node, then tidy -stratification/modularization like this can keep you sane. - -=item the constructor $obj->new() or $obj->new({...options...}) - -Just another way to get at the C method. This B -$obj, but merely constructs a new object of the same class as it. -Saves you the bother of going $class = ref $obj; $obj2 = $class->new; - -=cut - -sub new { # constructor - # Presumably you won't EVER need to override this -- _init is what - # you'd override in order to set an object's default attribute values. - my $class = shift; - $class = ref($class) if ref($class); # tchristic style. why not? - - my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # o for options hashref - my $it = bless( {}, $class ); - print "Constructing $it in class $class\n" if $Debug; - $it->_init( $o ); - return $it; -} - -########################################################################### - -=item the method $node->_init({...options...}) - -Initialize the object's attribute values. See the discussion above. -Presumably this should be called only by the guts of the C -constructor -- never by the end user. - -Currently there are no documented options for putting in -{...options...}, but (in case you want to disregard the above rant) -the option exists for you to use {...options...} for something useful -in a derived class. - -Please see the source for more information. - -=item see also (below) the constructors "new_daughter" and "new_daughter_left" - -=back - -=cut - -sub _init { # method - my $this = shift; - my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; - - # Sane initialization. - $this->_init_mother($o); - $this->_init_daughters($o); - $this->_init_name($o); - $this->_init_attributes($o); - - return; -} - -sub _init_mother { # to be called by an _init - my($this, $o) = @_[0,1]; - - $this->{'mother'} = undef; - - # Undocumented and disfavored. Consider this just an example. - ( $o->{'mother'} )->add_daughter($this) - if defined($o->{'mother'}) && ref($o->{'mother'}); - # DO NOT use this option (as implemented) with new_daughter or - # new_daughter_left!!!!! - # BAD THINGS MAY HAPPEN!!! -} - -sub _init_daughters { # to be called by an _init - my($this, $o) = @_[0,1]; - - $this->{'daughters'} = []; - - # Undocumented and disfavored. Consider this just an example. - $this->set_daughters( @{$o->{'daughters'}} ) - if ref($o->{'daughters'}) && (@{$o->{'daughters'}}); - # DO NOT use this option (as implemented) with new_daughter or - # new_daughter_left!!!!! - # BAD THINGS MAY HAPPEN!!! -} - -sub _init_name { # to be called by an _init - my($this, $o) = @_[0,1]; - - $this->{'name'} = undef; - - # Undocumented and disfavored. Consider this just an example. - $this->name( $o->{'name'} ) if exists $o->{'name'}; -} - -sub _init_attributes { # to be called by an _init - my($this, $o) = @_[0,1]; - - $this->{'attributes'} = {}; - - # Undocumented and disfavored. Consider this just an example. - $this->attributes( $o->{'attributes'} ) if exists $o->{'attributes'}; -} - -########################################################################### -########################################################################### - -=head1 LINKAGE-RELATED METHODS - -=over - -=item $node->daughters - -This returns the (possibly empty) list of daughters for $node. - -=cut - -sub daughters { # read-only attrib-method: returns a list. - my $this = shift; - - if(@_) { # undoc'd and disfavored to use as a write-method - Carp::croak "Don't set daughters with doughters anymore\n"; - Carp::carp "my parameter must be a listref" unless ref($_[0]); - $this->{'daughters'} = $_[0]; - $this->_update_daughter_links; - } - #return $this->{'daughters'}; - return @{$this->{'daughters'} || []}; -} - -########################################################################### - -=item $node->mother - -This returns what node is $node's mother. This is undef if $node has -no mother -- i.e., if it is a root. - -=cut - -sub mother { # read-only attrib-method: returns an object (the mother node) - my $this = shift; - Carp::croak "I'm a read-only method!" if @_; - return $this->{'mother'}; -} - -########################################################################### -########################################################################### - -=item $mother->add_daughters( LIST ) - -This method adds the node objects in LIST to the (right) end of -$mother's C list. Making a node N1 the daughter of another -node N2 also means that N1's C attribute is "automatically" set -to N2; it also means that N1 stops being anything else's daughter as -it becomes N2's daughter. - -If you try to make a node its own mother, a fatal error results. If -you try to take one of a a node N1's ancestors and make it also a -daughter of N1, a fatal error results. A fatal error results if -anything in LIST isn't a node object. - -If you try to make N1 a daughter of N2, but it's B a daughter -of N2, then this is a no-operation -- it won't move such nodes to the -end of the list or anything; it just skips doing anything with them. - -=item $node->add_daughter( LIST ) - -An exact synonym for $node->add_daughters(LIST) - -=cut - -sub add_daughters { # write-only method - my($mother, @daughters) = @_; - return unless @daughters; # no-op - return - $mother->_add_daughters_wrapper( - sub { push @{$_[0]}, $_[1]; }, - @daughters - ); -} - -sub add_daughter { # alias - my($it,@them) = @_; $it->add_daughters(@them); -} - -=item $mother->add_daughters_left( LIST ) - -This method is just like C, except that it adds the -node objects in LIST to the (left) beginning of $mother's daughter -list, instead of the (right) end of it. - -=item $node->add_daughter_left( LIST ) - -An exact synonym for $node->add_daughters_left( LIST ) - -=cut - -sub add_daughters_left { # write-only method - my($mother, @daughters) = @_; - return unless @daughters; - return - $mother->_add_daughters_wrapper( - sub { unshift @{$_[0]}, $_[1]; }, - @daughters - ); -} - -sub add_daughter_left { # alias - my($it,@them) = @_; $it->add_daughters_left(@them); -} - -=item Note: - -The above link-making methods perform basically an C or -C on the mother node's daughter list. To get the full range of -list-handling functionality, copy the daughter list, and change it, -and then call C on the result: - - @them = $mother->daughters; - @removed = splice(@them, 0,2, @new_nodes); - $mother->set_daughters(@them); - -Or consider a structure like: - - $mother->set_daughters( - grep($_->name =~ /NP/ , - $mother->daughters - ) - ); - -=cut - - -### -## Used by the adding methods -# (except maybe new_daughter, and new_daughter_left) - -sub _add_daughters_wrapper { - my($mother, $callback, @daughters) = @_; - return unless @daughters; - - my %ancestors; - @ancestors{ $mother->ancestors } = undef; - # This could be made more efficient by not bothering to compile - # the ancestor list for $mother if all the nodes to add are - # daughterless. - # But then you have to CHECK if they're daughterless. - # If $mother is [big number] generations down, then it's worth checking. - - foreach my $daughter (@daughters) { # which may be () - Carp::croak "daughter must be a node object!" unless UNIVERSAL::can($daughter, 'is_node'); - - printf "Mother : %s (%s)\n", $mother, ref $mother if $Debug; - printf "Daughter: %s (%s)\n", $daughter, ref $daughter if $Debug; - printf "Adding %s to %s\n", - ($daughter->name() || $daughter), - ($mother->name() || $mother) if $Debug > 1; - - Carp::croak "mother can't be its own daughter!" if $mother eq $daughter; - - $daughter->cyclicity_fault( - "$daughter (" . ($daughter->name || 'no_name') . - ") is an ancestor of $mother (" . ($mother->name || 'no_name') . - "), so can't became its daughter." - ) if exists $ancestors{$daughter}; - - my $old_mother = $daughter->{'mother'}; - - next if defined($old_mother) && ref($old_mother) && $old_mother eq $mother; - # noop if $daughter is already $mother's daughter - - $old_mother->remove_daughters($daughter) - if defined($old_mother) && ref($old_mother); - - &{$callback}($mother->{'daughters'}, $daughter); - } - $mother->_update_daughter_links; # need only do this at the end - - return; -} - -########################################################################### -########################################################################### - -sub _update_daughter_links { - # Eliminate any duplicates in my daughters list, and update - # all my daughters' links to myself. - my $this = shift; - - my $them = $this->{'daughters'}; - - # Eliminate duplicate daughters. - my %seen = (); - @$them = grep { ref($_) && not($seen{$_}++) } @$them; - # not that there should ever be duplicate daughters anyhoo. - - foreach my $one (@$them) { # linkage bookkeeping - Carp::croak "daughter <$one> isn't an object!" unless ref $one; - $one->{'mother'} = $this; - } - return; -} - -########################################################################### - -# Currently unused. - -sub _update_links { # update all descendant links for ancestorship below - # this point - # note: it's "descendant", not "descendent" - # see - my $this = shift; - # $this->no_cyclicity; - $this->walk_down({ - 'callback' => sub { - my $this = $_[0]; - $this->_update_daughter_links; - return 1; - }, - }); -} - -########################################################################### -########################################################################### - -=item the constructor $daughter = $mother->new_daughter, or - -=item the constructor $daughter = $mother->new_daughter({...options...}) - -This B a B node (of the same class as $mother), and -adds it to the (right) end of the daughter list of $mother. This is -essentially the same as going - - $daughter = $mother->new; - $mother->add_daughter($daughter); - -but is rather more efficient because (since $daughter is guaranteed new -and isn't linked to/from anything), it doesn't have to check that -$daughter isn't an ancestor of $mother, isn't already daughter to a -mother it needs to be unlinked from, isn't already in $mother's -daughter list, etc. - -As you'd expect for a constructor, it returns the node-object created. - -=cut - -# Note that if you radically change 'mother'/'daughters' bookkeeping, -# you may have to change this routine, since it's one of the places -# that directly writes to 'daughters' and 'mother'. - -sub new_daughter { - my($mother, @options) = @_; - my $daughter = $mother->new(@options); - - push @{$mother->{'daughters'}}, $daughter; - $daughter->{'mother'} = $mother; - - return $daughter; -} - -=item the constructor $mother->new_daughter_left, or - -=item $mother->new_daughter_left({...options...}) - -This is just like $mother->new_daughter, but adds the new daughter -to the left (start) of $mother's daughter list. - -=cut - -# Note that if you radically change 'mother'/'daughters' bookkeeping, -# you may have to change this routine, since it's one of the places -# that directly writes to 'daughters' and 'mother'. - -sub new_daughter_left { - my($mother, @options) = @_; - my $daughter = $mother->new(@options); - - unshift @{$mother->{'daughters'}}, $daughter; - $daughter->{'mother'} = $mother; - - return $daughter; -} - -########################################################################### - -=item $mother->remove_daughters( LIST ) - -This removes the nodes listed in LIST from $mother's daughter list. -This is a no-operation if LIST is empty. If there are things in LIST -that aren't a current daughter of $mother, they are ignored. - -Not to be confused with $mother->clear_daughters. - -=cut - -sub remove_daughters { # write-only method - my($mother, @daughters) = @_; - Carp::croak "mother must be an object!" unless ref $mother; - return unless @daughters; - - my %to_delete; - @daughters = grep {ref($_) - and defined($_->{'mother'}) - and $mother eq $_->{'mother'} - } @daughters; - return unless @daughters; - @to_delete{ @daughters } = undef; - - # This could be done better and more efficiently, I guess. - foreach my $daughter (@daughters) { - $daughter->{'mother'} = undef; - } - my $them = $mother->{'daughters'}; - @$them = grep { !exists($to_delete{$_}) } @$them; - - # $mother->_update_daughter_links; # unnecessary - return; -} - -=item $node->remove_daughter( LIST ) - -An exact synonym for $node->remove_daughters( LIST ) - -=cut - -sub remove_daughter { # alias - my($it,@them) = @_; $it->remove_daughters(@them); -} - -=item $node->unlink_from_mother - -This removes node from the daughter list of its mother. If it has no -mother, this is a no-operation. - -Returns the mother unlinked from (if any). - -=cut - -sub unlink_from_mother { - my $node = $_[0]; - my $mother = $node->{'mother'}; - $mother->remove_daughters($node) if defined($mother) && ref($mother); - return $mother; -} - -########################################################################### - -=item $mother->clear_daughters - -This unlinks all $mother's daughters. -Returns the the list of what used to be $mother's daughters. - -Not to be confused with $mother->remove_daughters( LIST ). - -=cut - -sub clear_daughters { # write-only method - my($mother) = $_[0]; - my @daughters = @{$mother->{'daughters'}}; - - @{$mother->{'daughters'}} = (); - foreach my $one (@daughters) { - next unless UNIVERSAL::can($one, 'is_node'); # sanity check - $one->{'mother'} = undef; - } - # Another, simpler, way to do it: - # $mother->remove_daughters($mother->daughters); - - return @daughters; # NEW -} -#-------------------------------------------------------------------------- - -=item $mother->set_daughters( LIST ) - -This unlinks all $mother's daughters, and replaces them with the -daughters in LIST. - -Currently implemented as just $mother->clear_daughters followed by -$mother->add_daughters( LIST ). - -=cut - -sub set_daughters { # write-only method - my($mother, @them) = @_; - $mother->clear_daughters; - $mother->add_daughters(@them) if @them; - # yup, it's that simple -} - -#-------------------------------------------------------------------------- - -=item $node->replace_with( LIST ) - -This replaces $node in its mother's daughter list, by unlinking $node -and replacing it with the items in LIST. This returns a list consisting -of $node followed by LIST, i.e., the nodes that replaced it. - -LIST can include $node itself (presumably at most once). LIST can -also be empty-list. However, if any items in LIST are sisters to -$node, they are ignored, and are not in the copy of LIST passed as the -return value. - -As you might expect for any linking operation, the items in LIST -cannot be $node's mother, or any ancestor to it; and items in LIST are, -of course, unlinked from their mothers (if they have any) as they're -linked to $node's mother. - -(In the special (and bizarre) case where $node is root, this simply calls -$this->unlink_from_mother on all the items in LIST, making them roots of -their own trees.) - -Note that the daughter-list of $node is not necessarily affected; nor -are the daughter-lists of the items in LIST. I mention this in case you -think replace_with switches one node for another, with respect to its -mother list B its daughter list, leaving the rest of the tree -unchanged. If that's what you want, replacing $Old with $New, then you -want: - - $New->set_daughters($Old->clear_daughters); - $Old->replace_with($New); - -(I can't say $node's and LIST-items' daughter lists are B -affected my replace_with -- they can be affected in this case: - - $N1 = ($node->daughters)[0]; # first daughter of $node - $N2 = ($N1->daughters)[0]; # first daughter of $N1; - $N3 = Tree::DAG_Node->random_network; # or whatever - $node->replace_with($N1, $N2, $N3); - -As a side affect of attaching $N1 and $N2 to $node's mother, they're -unlinked from their parents ($node, and $N1, replectively). -But N3's daughter list is unaffected. - -In other words, this method does what it has to, as you'd expect it -to. - -=cut - -sub replace_with { # write-only method - my($this, @replacements) = @_; - - if(not( defined($this->{'mother'}) && ref($this->{'mother'}) )) { # if root - foreach my $replacement (@replacements) { - $replacement->{'mother'}->remove_daughters($replacement) - if $replacement->{'mother'}; - } - # make 'em roots - } else { # I have a mother - my $mother = $this->{'mother'}; - - #@replacements = grep(($_ eq $this || $_->{'mother'} ne $mother), - # @replacements); - @replacements = grep { $_ eq $this - || not(defined($_->{'mother'}) && - ref($_->{'mother'}) && - $_->{'mother'} eq $mother - ) - } - @replacements; - # Eliminate sisters (but not self) - # i.e., I want myself or things NOT with the same mother as myself. - - $mother->set_daughters( # old switcheroo - map($_ eq $this ? (@replacements) : $_ , - @{$mother->{'daughters'}} - ) - ); - # and set_daughters does all the checking and possible - # unlinking - } - return($this, @replacements); -} - -=item $node->replace_with_daughters - -This replaces $node in its mother's daughter list, by unlinking $node -and replacing it with its daughters. In other words, $node becomes -motherless and daughterless as its daughters move up and take its place. -This returns a list consisting of $node followed by the nodes that were -its daughters. - -In the special (and bizarre) case where $node is root, this simply -unlinks its daughters from it, making them roots of their own trees. - -Effectively the same as $node->replace_with($node->daughters), but more -efficient, since less checking has to be done. (And I also think -$node->replace_with_daughters is a more common operation in -tree-wrangling than $node->replace_with(LIST), so deserves a named -method of its own, but that's just me.) - -=cut - -# Note that if you radically change 'mother'/'daughters' bookkeeping, -# you may have to change this routine, since it's one of the places -# that directly writes to 'daughters' and 'mother'. - -sub replace_with_daughters { # write-only method - my($this) = $_[0]; # takes no params other than the self - my $mother = $this->{'mother'}; - return($this, $this->clear_daughters) - unless defined($mother) && ref($mother); - - my @daughters = $this->clear_daughters; - my $sib_r = $mother->{'daughters'}; - @$sib_r = map($_ eq $this ? (@daughters) : $_, - @$sib_r # old switcheroo - ); - foreach my $daughter (@daughters) { - $daughter->{'mother'} = $mother; - } - return($this, @daughters); -} - -#-------------------------------------------------------------------------- - -=item $node->add_left_sisters( LIST ) - -This adds the elements in LIST (in that order) as immediate left sisters of -$node. In other words, given that B's mother's daughter-list is (A,B,C,D), -calling B->add_left_sisters(X,Y) makes B's mother's daughter-list -(A,X,Y,B,C,D). - -If LIST is empty, this is a no-op, and returns empty-list. - -This is basically implemented as a call to $node->replace_with(LIST, -$node), and so all replace_with's limitations and caveats apply. - -The return value of $node->add_left_sisters( LIST ) is the elements of -LIST that got added, as returned by replace_with -- minus the copies -of $node you'd get from a straight call to $node->replace_with(LIST, -$node). - -=cut - -sub add_left_sisters { # write-only method - my($this, @new) = @_; - return() unless @new; - - @new = $this->replace_with(@new, $this); - shift @new; pop @new; # kill the copies of $this - return @new; -} - -=item $node->add_left_sister( LIST ) - -An exact synonym for $node->add_left_sisters(LIST) - -=cut - -sub add_left_sister { # alias - my($it,@them) = @_; $it->add_left_sisters(@them); -} - -=item $node->add_right_sisters( LIST ) - -Just like add_left_sisters (which see), except that the the elements -in LIST (in that order) as immediate B sisters of $node; - -In other words, given that B's mother's daughter-list is (A,B,C,D), -calling B->add_right_sisters(X,Y) makes B's mother's daughter-list -(A,B,X,Y,C,D). - -=cut - -sub add_right_sisters { # write-only method - my($this, @new) = @_; - return() unless @new; - @new = $this->replace_with($this, @new); - shift @new; shift @new; # kill the copies of $this - return @new; -} - -=item $node->add_right_sister( LIST ) - -An exact synonym for $node->add_right_sisters(LIST) - -=cut - -sub add_right_sister { # alias - my($it,@them) = @_; $it->add_right_sisters(@them); -} - -########################################################################### - -=back - -=cut - -########################################################################### -########################################################################### - -=head1 OTHER ATTRIBUTE METHODS - -=over - -=item $node->name or $node->name(SCALAR) - -In the first form, returns the value of the node object's "name" -attribute. In the second form, sets it to the value of SCALAR. - -=cut - -sub name { # read/write attribute-method. returns/expects a scalar - my $this = shift; - $this->{'name'} = $_[0] if @_; - return $this->{'name'}; -} - - -########################################################################### - -=item $node->attributes or $node->attributes(SCALAR) - -In the first form, returns the value of the node object's "attributes" -attribute. In the second form, sets it to the value of SCALAR. I -intend this to be used to store a reference to a (presumably -anonymous) hash the user can use to store whatever attributes he -doesn't want to have to store as object attributes. In this case, you -needn't ever set the value of this. (_init has already initialized it -to {}.) Instead you can just do... - - $node->attributes->{'foo'} = 'bar'; - -...to write foo => bar. - -=cut - -sub attributes { # read/write attribute-method - # expects a ref, presumably a hashref - my $this = shift; - if(@_) { - Carp::carp "my parameter must be a reference" unless ref($_[0]); - $this->{'attributes'} = $_[0]; - } - return $this->{'attributes'}; -} - -=item $node->attribute or $node->attribute(SCALAR) - -An exact synonym for $node->attributes or $node->attributes(SCALAR) - -=cut - -sub attribute { # alias - my($it,@them) = @_; $it->attributes(@them); -} - -########################################################################### -# Secret Stuff. - -sub no_cyclicity { # croak iff I'm in a CYCLIC class. - my($it) = $_[0]; - # If, God forbid, I use this to make a cyclic class, then I'd - # expand the functionality of this routine to actually look for - # cyclicity. Or something like that. Maybe. - - $it->cyclicity_fault("You can't do that in a cyclic class!") - if $it->cyclicity_allowed; - return; -} - -sub cyclicity_fault { - my($it, $bitch) = @_[0,1]; - Carp::croak "Cyclicity fault: $bitch"; # never return -} - -sub cyclicity_allowed { - return 0; -} - -########################################################################### -# More secret stuff. Currently unused. - -sub inaugurate_root { # no-op - my($it, $tree) = @_[0,1]; - # flag this node as being the root of the tree $tree. - return; -} - -sub decommission_root { # no-op - # flag this node as no longer being the root of the tree $tree. - return; -} - -########################################################################### -########################################################################### - -=back - -=head1 OTHER METHODS TO DO WITH RELATIONSHIPS - -=over - -=item $node->is_node - -This always returns true. More pertinently, $object->can('is_node') -is true (regardless of what C would do if called) for objects -belonging to this class or for any class derived from it. - -=cut - -sub is_node { return 1; } # always true. -# NEVER override this with anything that returns false in the belief -# that this'd signal "not a node class". The existence of this method -# is what I test for, with the various "can()" uses in this class. - -########################################################################### - -=item $node->ancestors - -Returns the list of this node's ancestors, starting with its mother, -then grandmother, and ending at the root. It does this by simply -following the 'mother' attributes up as far as it can. So if $item IS -the root, this returns an empty list. - -Consider that scalar($node->ancestors) returns the ply of this node -within the tree -- 2 for a granddaughter of the root, etc., and 0 for -root itself. - -=cut - -sub ancestors { - my $this = shift; - my $mama = $this->{'mother'}; # initial condition - return () unless ref($mama); # I must be root! - - # $this->no_cyclicity; # avoid infinite loops - - # Could be defined recursively, as: - # if(ref($mama = $this->{'mother'})){ - # return($mama, $mama->ancestors); - # } else { - # return (); - # } - # But I didn't think of that until I coded the stuff below, which is - # faster. - - my @ancestors = ( $mama ); # start off with my mama - while(defined( $mama = $mama->{'mother'} ) && ref($mama)) { - # Walk up the tree - push(@ancestors, $mama); - # This turns into an infinite loop if someone gets stupid - # and makes this tree cyclic! Don't do it! - } - return @ancestors; -} - -########################################################################### - -=item $node->root - -Returns the root of whatever tree $node is a member of. If $node is -the root, then the result is $node itself. - -=cut - -sub root { - my $it = $_[0]; - my @ancestors = ($it, $it->ancestors); - return $ancestors[-1]; -} - -########################################################################### - -=item $node->is_daughter_of($node2) - -Returns true iff $node is a daughter of $node2. -Currently implemented as just a test of ($it->mother eq $node2). - -=cut - -sub is_daughter_of { - my($it,$mama) = @_[0,1]; - return $it->{'mother'} eq $mama; -} - -########################################################################### - -=item $node->self_and_descendants - -Returns a list consisting of itself (as element 0) and all the -descendants of $node. Returns just itself if $node is a -terminal_node. - -(Note that it's spelled "descendants", not "descendents".) - -=cut - -sub self_and_descendants { - # read-only method: return a list of myself and any/all descendants - my $node = shift; - my @List = (); - # $node->no_cyclicity; - $node->walk_down({ 'callback' => sub { push @List, $_[0]; return 1;}}); - Carp::croak "Spork Error 919: \@List has no contents!?!?" unless @List; - # impossible - return @List; -} - -########################################################################### - -=item $node->descendants - -Returns a list consisting of all the descendants of $node. Returns -empty-list if $node is a terminal_node. - -(Note that it's spelled "descendants", not "descendents".) - -=cut - -sub descendants { - # read-only method: return a list of my descendants - my $node = shift; - my @list = $node->self_and_descendants; - shift @list; # lose myself. - return @list; -} - -########################################################################### - -=item $node->leaves_under - -Returns a list (going left-to-right) of all the leaf nodes under -$node. ("Leaf nodes" are also called "terminal nodes" -- i.e., nodes -that have no daughters.) Returns $node in the degenerate case of -$node being a leaf itself. - -=cut - -sub leaves_under { - # read-only method: return a list of all leaves under myself. - # Returns myself in the degenerate case of being a leaf myself. - my $node = shift; - my @List = (); - # $node->no_cyclicity; - $node->walk_down({ 'callback' => - sub { - my $node = $_[0]; - my @daughters = @{$node->{'daughters'}}; - push(@List, $node) unless @daughters; - return 1; - } - }); - Carp::croak "Spork Error 861: \@List has no contents!?!?" unless @List; - # impossible - return @List; -} - -########################################################################### - -=item $node->depth_under - -Returns an integer representing the number of branches between this -$node and the most distant leaf under it. (In other words, this -returns the ply of subtree starting of $node. Consider -scalar($it->ancestors) if you want the ply of a node within the whole -tree.) - -=cut - -sub depth_under { - my $node = shift; - my $max_depth = 0; - $node->walk_down({ - '_depth' => 0, - 'callback' => sub { - my $depth = $_[1]->{'_depth'}; - $max_depth = $depth if $depth > $max_depth; - return 1; - }, - }); - return $max_depth; -} - -########################################################################### - -=item $node->generation - -Returns a list of all nodes (going left-to-right) that are in $node's -generation -- i.e., that are the some number of nodes down from -the root. $root->generation is just $root. - -Of course, $node is always in its own generation. - -=item $node->generation_under(NODE2) - -Like $node->generation, but returns only the nodes in $node's generation -that are also descendants of NODE2 -- in other words, - - @us = $node->generation_under( $node->mother->mother ); - -is all $node's first cousins (to borrow yet more kinship terminology) -- -assuming $node does indeed have a grandmother. Actually "cousins" isn't -quite an apt word, because C<@us> ends up including $node's siblings and -$node. - -Actually, C is just an alias to C, but I -figure that this: - - @us = $node->generation_under($way_upline); - -is a bit more readable than this: - - @us = $node->generation($way_upline); - -But it's up to you. - -$node->generation_under($node) returns just $node. - -If you call $node->generation_under($node) but NODE2 is not $node or an -ancestor of $node, it behaves as if you called just $node->generation(). - -=cut - -sub generation { - my($node, $limit) = @_[0,1]; - # $node->no_cyclicity; - return $node - if $node eq $limit || not( - defined($node->{'mother'}) && - ref($node->{'mother'}) - ); # bailout - - return map(@{$_->{'daughters'}}, $node->{'mother'}->generation($limit)); - # recurse! - # Yup, my generation is just all the daughters of my mom's generation. -} - -sub generation_under { - my($node, @rest) = @_; - return $node->generation(@rest); -} - -########################################################################### - -=item $node->self_and_sisters - -Returns a list of all nodes (going left-to-right) that have the same -mother as $node -- including $node itself. This is just like -$node->mother->daughters, except that that fails where $node is root, -whereas $root->self_and_siblings, as a special case, returns $root. - -(Contrary to how you may interpret how this method is named, "self" is -not (necessarily) the first element of what's returned.) - -=cut - -sub self_and_sisters { - my $node = $_[0]; - my $mother = $node->{'mother'}; - return $node unless defined($mother) && ref($mother); # special case - return @{$node->{'mother'}->{'daughters'}}; -} - -########################################################################### - -=item $node->sisters - -Returns a list of all nodes (going left-to-right) that have the same -mother as $node -- B $node itself. If $node is root, -this returns empty-list. - -=cut - -sub sisters { - my $node = $_[0]; - my $mother = $node->{'mother'}; - return() unless $mother; # special case - return grep($_ ne $node, - @{$node->{'mother'}->{'daughters'}} - ); -} - -########################################################################### - -=item $node->left_sister - -Returns the node that's the immediate left sister of $node. If $node -is the leftmost (or only) daughter of its mother (or has no mother), -then this returns undef. - -(See also $node->add_left_sisters(LIST).) - -=cut - -sub left_sister { - my $it = $_[0]; - my $mother = $it->{'mother'}; - return undef unless $mother; - my @sisters = @{$mother->{'daughters'}}; - - return undef if @sisters == 1; # I'm an only daughter - - my $left = undef; - foreach my $one (@sisters) { - return $left if $one eq $it; - $left = $one; - } - die "SPORK ERROR 9757: I'm not in my mother's daughter list!?!?"; -} - - -=item $node->left_sisters - -Returns a list of nodes that're sisters to the left of $node. If -$node is the leftmost (or only) daughter of its mother (or has no -mother), then this returns an empty list. - -(See also $node->add_left_sisters(LIST).) - -=cut - -sub left_sisters { - my $it = $_[0]; - my $mother = $it->{'mother'}; - return() unless $mother; - my @sisters = @{$mother->{'daughters'}}; - return() if @sisters == 1; # I'm an only daughter - - my @out = (); - foreach my $one (@sisters) { - return @out if $one eq $it; - push @out, $one; - } - die "SPORK ERROR 9767: I'm not in my mother's daughter list!?!?"; -} - -=item $node->right_sister - -Returns the node that's the immediate right sister of $node. If $node -is the rightmost (or only) daughter of its mother (or has no mother), -then this returns undef. - -(See also $node->add_right_sisters(LIST).) - -=cut - -sub right_sister { - my $it = $_[0]; - my $mother = $it->{'mother'}; - return undef unless $mother; - my @sisters = @{$mother->{'daughters'}}; - return undef if @sisters == 1; # I'm an only daughter - - my $seen = 0; - foreach my $one (@sisters) { - return $one if $seen; - $seen = 1 if $one eq $it; - } - die "SPORK ERROR 9777: I'm not in my mother's daughter list!?!?" - unless $seen; - return undef; -} - -=item $node->right_sisters - -Returns a list of nodes that're sisters to the right of $node. If -$node is the rightmost (or only) daughter of its mother (or has no -mother), then this returns an empty list. - -(See also $node->add_right_sisters(LIST).) - -=cut - -sub right_sisters { - my $it = $_[0]; - my $mother = $it->{'mother'}; - return() unless $mother; - my @sisters = @{$mother->{'daughters'}}; - return() if @sisters == 1; # I'm an only daughter - - my @out; - my $seen = 0; - foreach my $one (@sisters) { - push @out, $one if $seen; - $seen = 1 if $one eq $it; - } - die "SPORK ERROR 9787: I'm not in my mother's daughter list!?!?" - unless $seen; - return @out; -} - -########################################################################### - -=item $node->my_daughter_index - -Returns what index this daughter is, in its mother's C list. -In other words, if $node is ($node->mother->daughters)[3], then -$node->my_daughter_index returns 3. - -As a special case, returns 0 if $node has no mother. - -=cut - -sub my_daughter_index { - # returns what number is my index in my mother's daughter list - # special case: 0 for root. - my $node = $_[0]; - my $ord = -1; - my $mother = $node->{'mother'}; - - return 0 unless $mother; - my @sisters = @{$mother->{'daughters'}}; - - die "SPORK ERROR 6512: My mother has no kids!!!" unless @sisters; - - Find_Self: - for(my $i = 0; $i < @sisters; $i++) { - if($sisters[$i] eq $node) { - $ord = $i; - last Find_Self; - } - } - die "SPORK ERROR 2837: I'm not a daughter of my mother?!?!" if $ord == -1; - return $ord; -} - -########################################################################### - -=item $node->address or $anynode->address(ADDRESS) - -With the first syntax, returns the address of $node within its tree, -based on its position within the tree. An address is formed by noting -the path between the root and $node, and concatenating the -daughter-indices of the nodes this passes thru (starting with 0 for -the root, and ending with $node). - -For example, if to get from node ROOT to node $node, you pass thru -ROOT, A, B, and $node, then the address is determined as: - -* ROOT's my_daughter_index is 0. - -* A's my_daughter_index is, suppose, 2. (A is index 2 in ROOT's -daughter list.) - -* B's my_daughter_index is, suppose, 0. (B is index 0 in A's -daughter list.) - -* $node's my_daughter_index is, suppose, 4. ($node is index 4 in -B's daughter list.) - -The address of the above-described $node is, therefore, "0:2:0:4". - -(As a somewhat special case, the address of the root is always "0"; -and since addresses start from the root, all addresses start with a -"0".) - -The second syntax, where you provide an address, starts from the root -of the tree $anynode belongs to, and returns the node corresponding to -that address. Returns undef if no node corresponds to that address. -Note that this routine may be somewhat liberal in its interpretation -of what can constitute an address; i.e., it accepts "0.2.0.4", besides -"0:2:0:4". - -Also note that the address of a node in a tree is meaningful only in -that tree as currently structured. - -(Consider how ($address1 cmp $address2) may be magically meaningful -to you, if you mant to figure out what nodes are to the right of what -other nodes.) - -=cut - -sub address { - my($it, $address) = @_[0,1]; - if(defined($address) && length($address)) { # given the address, return the node. - # invalid addresses return undef - my $root = $it->root; - my @parts = map {$_ + 0} - $address =~ m/(\d+)/g; # generous! - Carp::croak "Address \"$address\" is an ill-formed address" unless @parts; - Carp::croak "Address \"$address\" must start with '0'" unless shift(@parts) == 0; - - my $current_node = $root; - while(@parts) { # no-op for root - my $ord = shift @parts; - my @daughters = @{$current_node->{'daughters'}}; - - if($#daughters < $ord) { # illegal address - print "* $address has an out-of-range index ($ord)!" if $Debug; - return undef; - } - $current_node = $daughters[$ord]; - unless(ref($current_node)) { - print "* $address points to or thru a non-node!" if $Debug; - return undef; - } - } - return $current_node; - - } else { # given the node, return the address - my @parts = (); - my $current_node = $it; - my $mother; - - while(defined( $mother = $current_node->{'mother'} ) && ref($mother)) { - unshift @parts, $current_node->my_daughter_index; - $current_node = $mother; - } - return join(':', 0, @parts); - } -} - -########################################################################### - -=item $node->common(LIST) - -Returns the lowest node in the tree that is ancestor-or-self to the -nodes $node and LIST. - -If the nodes are far enough apart in the tree, the answer is just the -root. - -If the nodes aren't all in the same tree, the answer is undef. - -As a degenerate case, if LIST is empty, returns $node. - -=cut - -sub common { # Return the lowest node common to all these nodes... - # Called as $it->common($other) or $it->common(@others) - my @ones = @_; # all nodes I was given - my($first, @others) = @_; - - return $first unless @others; # degenerate case - - my %ones; - @ones{ @ones } = undef; - - foreach my $node (@others) { - Carp::croak "TILT: node \"$node\" is not a node" - unless UNIVERSAL::can($node, 'is_node'); - my %first_lineage; - @first_lineage{$first, $first->ancestors} = undef; - my $higher = undef; # the common of $first and $node - my @my_lineage = $node->ancestors; - - Find_Common: - while(@my_lineage) { - if(exists $first_lineage{$my_lineage[0]}) { - $higher = $my_lineage[0]; - last Find_Common; - } - shift @my_lineage; - } - return undef unless $higher; - $first = $higher; - } - return $first; -} - - -########################################################################### - -=item $node->common_ancestor(LIST) - -Returns the lowest node that is ancestor to all the nodes given (in -nodes $node and LIST). In other words, it answers the question: "What -node in the tree, as low as possible, is ancestor to the nodes given -($node and LIST)?" - -If the nodes are far enough apart, the answer is just the root -- -except if any of the nodes are the root itself, in which case the -answer is undef (since the root has no ancestor). - -If the nodes aren't all in the same tree, the answer is undef. - -As a degenerate case, if LIST is empty, returns $node's mother; -that'll be undef if $node is root. - -=cut - -sub common_ancestor { - my @ones = @_; # all nodes I was given - my($first, @others) = @_; - - return $first->{'mother'} unless @others; - # which may be undef if $first is the root! - - my %ones; - @ones{ @ones } = undef; # my arguments - - my $common = $first->common(@others); - if(exists($ones{$common})) { # if the common is one of my nodes... - return $common->{'mother'}; - # and this might be undef, if $common is root! - } else { - return $common; - # which might be null if that's all common came up with - } -} - -########################################################################### -########################################################################### - -=back - -=head1 YET MORE METHODS - -=over - -=item $node->walk_down({ callback => \&foo, callbackback => \&foo, ... }) - -Performs a depth-first traversal of the structure at and under $node. -What it does at each node depends on the value of the options hashref, -which you must provide. There are three options, "callback" and -"callbackback" (at least one of which must be defined, as a sub -reference), and "_depth". This is what C does, in -pseudocode form: - -* Start at the $node given. - -* If there's a C, call it with $node as the first argument, -and the options hashref as the second argument (which contains the -potentially useful C<_depth>, remember). This function must return -true or false -- if false, it will block the next step: - -* If $node has any daughter nodes, increment C<_depth>, and call -$daughter->walk_down(options_hashref) for each daughter (in order, of -course), where options_hashref is the same hashref it was called with. -When this returns, decrements C<_depth>. - -* If there's a C, call just it as with C (but -tossing out the return value). Note that C returning false -blocks traversal below $node, but doesn't block calling callbackback -for $node. (Incidentally, in the unlikely case that $node has stopped -being a node object, C won't get called.) - -* Return. - -$node->walk_down is the way to recursively do things to a tree (if you -start at the root) or part of a tree; if what you're doing is best done -via pre-pre order traversal, use C; if what you're doing is -best done with post-order traversal, use C. -C is even the basis for plenty of the methods in this -class. See the source code for examples both simple and horrific. - -Note that if you don't specify C<_depth>, it effectively defaults to -0. You should set it to scalar($node->ancestors) if you want -C<_depth> to reflect the true depth-in-the-tree for the nodes called, -instead of just the depth below $node. (If $node is the root, there's -difference, of course.) - -And B, it's a bad idea to modify the tree from the callback. -Unpredictable things may happen. I instead suggest having your callback -add to a stack of things that need changing, and then, once C -is all finished, changing those nodes from that stack. - -Note that the existence of C doesn't mean you can't write -you own special-use traversers. - -=cut - -sub walk_down { - my($this, $o) = @_[0,1]; - - # All the can()s are in case an object changes class while I'm - # looking at it. - - Carp::croak "I need options!" unless ref($o); - Carp::croak "I need a callback or a callbackback" unless - ( ref($o->{'callback'}) || ref($o->{'callbackback'}) ); - - # $this->no_cyclicity; - my $callback = ref($o->{'callback'}) ? $o->{'callback'} : undef; - my $callbackback = ref($o->{'callbackback'}) ? $o->{'callbackback'} : undef; - my $callback_status = 1; - - print "Callback: $callback Callbackback: $callbackback\n" if $Debug; - - printf "* Entering %s\n", ($this->name || $this) if $Debug; - $callback_status = &{ $callback }( $this, $o ) if $callback; - - if($callback_status) { - # Keep recursing unless callback returned false... and if there's - # anything to recurse into, of course. - my @daughters = UNIVERSAL::can($this, 'is_node') ? @{$this->{'daughters'}} : (); - if(@daughters) { - $o->{'_depth'} += 1; - #print "Depth " , $o->{'_depth'}, "\n"; - foreach my $one (@daughters) { - $one->walk_down($o) if UNIVERSAL::can($one, 'is_node'); - # and if it can do "is_node", it should provide a walk_down! - } - $o->{'_depth'} -= 1; - } - } else { - printf "* Recursing below %s pruned\n", ($this->name || $this) if $Debug; - } - - # Note that $callback_status doesn't block callbackback from being called - if($callbackback){ - if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node! - print "* Calling callbackback\n" if $Debug; - scalar( &{ $callbackback }( $this, $o ) ); - # scalar to give it the same context as callback - } else { - print "* Can't call callbackback -- $this isn't a node anymore\n" - if $Debug; - } - } - if($Debug) { - if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node! - printf "* Leaving %s\n", ($this->name || $this) - } else { - print "* Leaving [no longer a node]\n"; - } - } - return; -} - -########################################################################### - -=item @lines = $node->dump_names({ ...options... }); - -Dumps, as an indented list, the names of the nodes starting at $node, -and continuing under it. Options are: - -* _depth -- A nonnegative number. Indicating the depth to consider -$node as being at (and so the generation under that is that plus one, -etc.). Defaults to 0. You may choose to use set _depth => -scalar($node->ancestors). - -* tick -- a string to preface each entry with, between the -indenting-spacing and the node's name. Defaults to empty-string. You -may prefer "*" or "-> " or someting. - -* indent -- the string used to indent with. Defaults to " " (two -spaces). Another sane value might be ". " (period, space). Setting it -to empty-string suppresses indenting. - -The dump is not printed, but is returned as a list, where each -item is a line, with a "\n" at the end. - -=cut - -sub dump_names { - my($it, $o) = @_[0,1]; - $o = {} unless ref $o; - my @out = (); - $o->{'_depth'} ||= 0; - $o->{'indent'} ||= ' '; - $o->{'tick'} ||= ''; - - $o->{'callback'} = sub { - my($this, $o) = @_[0,1]; - push(@out, - join('', - $o->{'indent'} x $o->{'_depth'}, - $o->{'tick'}, - &Tree::DAG_Node::_dump_quote($this->name || $this), - "\n" - ) - ); - return 1; - } - ; - $it->walk_down($o); - return @out; -} - -########################################################################### -########################################################################### - -=item the constructor CLASS->random_network({...options...}) - -=item the method $node->random_network({...options...}) - -In the first case, constructs a randomly arranged network under a new -node, and returns the root node of that tree. In the latter case, -constructs the network under $node. - -Currently, this is implemented a bit half-heartedly, and -half-wittedly. I basically needed to make up random-looking networks -to stress-test the various tree-dumper methods, and so wrote this. If -you actually want to rely on this for any application more -serious than that, I suggest examining the source code and seeing if -this does really what you need (say, in reliability of randomness); -and feel totally free to suggest changes to me (especially in the form -of "I rewrote C, here's the code...") - -It takes four options: - -* max_node_count -- maximum number of nodes this tree will be allowed -to have (counting the root). Defaults to 25. - -* min_depth -- minimum depth for the tree. Defaults to 2. Leaves can -be generated only after this depth is reached, so the tree will be at -least this deep -- unless max_node_count is hit first. - -* max_depth -- maximum depth for the tree. Defaults to 3 plus -min_depth. The tree will not be deeper than this. - -* max_children -- maximum number of children any mother in the tree -can have. Defaults to 4. - -=cut - -sub random_network { # constructor or method. - my $class = $_[0]; - my $o = ref($_[1]) ? $_[1] : {}; - my $am_cons = 0; - my $root; - - if(ref($class)){ # I'm a method. - $root = $_[0]; # build under the given node, from same class. - $class = ref $class; - $am_cons = 0; - } else { # I'm a constructor - $root = $class->new; # build under a new node, with class named. - $root->name("Root"); - $am_cons = 1; - } - - my $min_depth = $o->{'min_depth'} || 2; - my $max_depth = $o->{'max_depth'} || ($min_depth + 3); - my $max_children = $o->{'max_children'} || 4; - my $max_node_count = $o->{'max_node_count'} || 25; - - Carp::croak "max_children has to be positive" if int($max_children) < 1; - - my @mothers = ( $root ); - my @children = ( ); - my $node_count = 1; # the root - - Gen: - foreach my $depth (1 .. $max_depth) { - last if $node_count > $max_node_count; - Mother: - foreach my $mother (@mothers) { - last Gen if $node_count > $max_node_count; - my $children_number; - if($depth <= $min_depth) { - until( $children_number = int(rand(1 + $max_children)) ) {} - } else { - $children_number = int(rand($max_children)); - } - Beget: - foreach (1 .. $children_number) { - last Gen if $node_count > $max_node_count; - my $node = $mother->new_daughter; - $node->name("Node$node_count"); - ++$node_count; - push(@children, $node); - } - } - @mothers = @children; - @children = (); - last unless @mothers; - } - - return $root; -} - -=item the constructor CLASS->lol_to_tree($lol); - -Converts something like bracket-notation for "Chomsky trees" (or -rather, the closest you can come with Perl -list-of-lists(-of-lists(-of-lists))) into a tree structure. Returns -the root of the tree converted. - -The conversion rules are that: 1) if the last (possibly the only) item -in a given list is a scalar, then that is used as the "name" attribute -for the node based on this list. 2) All other items in the list -represent daughter nodes of the current node -- recursively so, if -they are list references; otherwise, (non-terminal) scalars are -considered to denote nodes with that name. So ['Foo', 'Bar', 'N'] is -an alternate way to represent [['Foo'], ['Bar'], 'N']. - -An example will illustrate: - - use Tree::DAG_Node; - $lol = - [ - [ - [ [ 'Det:The' ], - [ [ 'dog' ], 'N'], 'NP'], - [ '/with rabies\\', 'PP'], - 'NP' - ], - [ 'died', 'VP'], - 'S' - ]; - $tree = Tree::DAG_Node->lol_to_tree($lol); - $diagram = $tree->draw_ascii_tree; - print map "$_\n", @$diagram; - -...returns this tree: - - | - - | - /------------------\ - | | - - | | - /---------------\ - | | - - | | - /-------\ - | | - - | - - -By the way (and this rather follows from the above rules), when -denoting a LoL tree consisting of just one node, this: - - $tree = Tree::DAG_Node->lol_to_tree( 'Lonely' ); - -is okay, although it'd probably occur to you to denote it only as: - - $tree = Tree::DAG_Node->lol_to_tree( ['Lonely'] ); - -which is of course fine, too. - -=cut - -sub lol_to_tree { - my($class, $lol, $seen_r) = @_[0,1,2]; - $seen_r = {} unless ref($seen_r) eq 'HASH'; - return if ref($lol) && $seen_r->{$lol}++; # catch circularity - - $class = ref($class) || $class; - my $node = $class->new(); - - unless(ref($lol) eq 'ARRAY') { # It's a terminal node. - $node->name($lol) if defined $lol; - return $node; - } - return $node unless @$lol; # It's a terminal node, oddly represented - - # It's a non-terminal node. - - my @options = @$lol; - unless(ref($options[-1]) eq 'ARRAY') { - # This is what separates this method from simple_lol_to_tree - $node->name(pop(@options)); - } - - foreach my $d (@options) { # Scan daughters (whether scalars or listrefs) - $node->add_daughter( $class->lol_to_tree($d, $seen_r) ); # recurse! - } - - return $node; -} - -#-------------------------------------------------------------------------- - -=item $node->tree_to_lol_notation({...options...}) - -Dumps a tree (starting at $node) as the sort of LoL-like bracket -notation you see in the above example code. Returns just one big -block of text. The only option is "multiline" -- if true, it dumps -the text as the sort of indented structure as seen above; if false -(and it defaults to false), dumps it all on one line (with no -indenting, of course). - -For example, starting with the tree from the above example, -this: - - print $tree->tree_to_lol_notation, "\n"; - -prints the following (which I've broken over two lines for sake of -printablitity of documentation): - - [[[['Det:The'], [['dog'], 'N'], 'NP'], [["/with rabies\x5c"], - 'PP'], 'NP'], [['died'], 'VP'], 'S'], - -Doing this: - - print $tree->tree_to_lol_notation({ multiline => 1 }); - -prints the same content, just spread over many lines, and prettily -indented. - -=cut - -#-------------------------------------------------------------------------- - -sub tree_to_lol_notation { - my $root = $_[0]; - my($it, $o) = @_[0,1]; - $o = {} unless ref $o; - my @out = (); - $o->{'_depth'} ||= 0; - $o->{'multiline'} = 0 unless exists($o->{'multiline'}); - - my $line_end; - if($o->{'multiline'}) { - $o->{'indent'} ||= ' '; - $line_end = "\n"; - } else { - $o->{'indent'} ||= ''; - $line_end = ''; - } - - $o->{'callback'} = sub { - my($this, $o) = @_[0,1]; - push(@out, - $o->{'indent'} x $o->{'_depth'}, - "[$line_end", - ); - return 1; - } - ; - $o->{'callbackback'} = sub { - my($this, $o) = @_[0,1]; - my $name = $this->name; - if(!defined($name)) { - $name = 'undef'; - } else { - $name = &Tree::DAG_Node::_dump_quote($name); - } - push(@out, - $o->{'indent'} x ($o->{'_depth'} + 1), - "$name$line_end", - $o->{'indent'} x $o->{'_depth'}, - "], $line_end", - ); - return 1; - } - ; - $it->walk_down($o); - return join('', @out); -} - -#-------------------------------------------------------------------------- - -=item $node->tree_to_lol - -Returns that tree (starting at $node) represented as a LoL, like what -$lol, above, holds. (This is as opposed to C, -which returns the viewable code like what gets evaluated and stored in -$lol, above.) - -Lord only knows what you use this for -- maybe for feeding to -Data::Dumper, in case C doesn't do just what you -want? - -=cut - -sub tree_to_lol { - # I haven't /rigorously/ tested this. - my($it, $o) = @_[0,1]; # $o is currently unused anyway - $o = {} unless ref $o; - - my $out = []; - my @lol_stack = ($out); - $o->{'callback'} = sub { - my($this, $o) = @_[0,1]; - my $new = []; - push @{$lol_stack[-1]}, $new; - push(@lol_stack, $new); - return 1; - } - ; - $o->{'callbackback'} = sub { - my($this, $o) = @_[0,1]; - push @{$lol_stack[-1]}, $this->name; - pop @lol_stack; - return 1; - } - ; - $it->walk_down($o); - die "totally bizarre error 12416" unless ref($out->[0]); - $out = $out->[0]; # the real root - return $out; -} - -########################################################################### - -=item the constructor CLASS->simple_lol_to_tree($simple_lol); - -This is like lol_to_tree, except that rule 1 doesn't apply -- i.e., -all scalars (or really, anything not a listref) in the LoL-structure -end up as named terminal nodes, and only terminal nodes get names -(and, of course, that name comes from that scalar value). This method -is useful for making things like expression trees, or at least -starting them off. Consider that this: - - $tree = Tree::DAG_Node->simple_lol_to_tree( - [ 'foo', ['bar', ['baz'], 'quux'], 'zaz', 'pati' ] - ); - -converts from something like a Lispish or Iconish tree, if you pretend -the brackets are parentheses. - -Note that there is a (possibly surprising) degenerate case of what I'm -calling a "simple-LoL", and it's like this: - - $tree = Tree::DAG_Node->simple_lol_to_tree('Lonely'); - -This is the (only) way you can specify a tree consisting of only a -single node, which here gets the name 'Lonely'. - -=cut - -sub simple_lol_to_tree { - my($class, $lol, $seen_r) = @_[0,1,2]; - $class = ref($class) || $class; - $seen_r = {} unless ref($seen_r) eq 'HASH'; - return if ref($lol) && $seen_r->{$lol}++; # catch circularity - - my $node = $class->new(); - - unless(ref($lol) eq 'ARRAY') { # It's a terminal node. - $node->name($lol) if defined $lol; - return $node; - } - - # It's a non-terminal node. - foreach my $d (@$lol) { # scan daughters (whether scalars or listrefs) - $node->add_daughter( $class->simple_lol_to_tree($d, $seen_r) ); # recurse! - } - - return $node; -} - -#-------------------------------------------------------------------------- - -=item $node->tree_to_simple_lol - -Returns that tree (starting at $node) represented as a simple-LoL -- -i.e., one where non-terminal nodes are represented as listrefs, and -terminal nodes are gotten from the contents of those nodes' "name' -attributes. - -Note that in the case of $node being terminal, what you get back is -the same as $node->name. - -Compare to tree_to_simple_lol_notation. - -=cut - -sub tree_to_simple_lol { - # I haven't /rigorously/ tested this. - my $root = $_[0]; - - return $root->name unless scalar($root->daughters); - # special case we have to nip in the bud - - my($it, $o) = @_[0,1]; # $o is currently unused anyway - $o = {} unless ref $o; - - my $out = []; - my @lol_stack = ($out); - $o->{'callback'} = sub { - my($this, $o) = @_[0,1]; - my $new; - $new = scalar($this->daughters) ? [] : $this->name; - # Terminal nodes are scalars, the rest are listrefs we'll fill in - # as we recurse the tree below here. - push @{$lol_stack[-1]}, $new; - push(@lol_stack, $new); - return 1; - } - ; - $o->{'callbackback'} = sub { pop @lol_stack; return 1; }; - $it->walk_down($o); - die "totally bizarre error 12416" unless ref($out->[0]); - $out = $out->[0]; # the real root - return $out; -} - -#-------------------------------------------------------------------------- - -=item $node->tree_to_simple_lol_notation({...options...}) - -A simple-LoL version of tree_to_lol_notation (which see); takes the -same options. - -=cut - -sub tree_to_simple_lol_notation { - my($it, $o) = @_[0,1]; - $o = {} unless ref $o; - my @out = (); - $o->{'_depth'} ||= 0; - $o->{'multiline'} = 0 unless exists($o->{'multiline'}); - - my $line_end; - if($o->{'multiline'}) { - $o->{'indent'} ||= ' '; - $line_end = "\n"; - } else { - $o->{'indent'} ||= ''; - $line_end = ''; - } - - $o->{'callback'} = sub { - my($this, $o) = @_[0,1]; - if(scalar($this->daughters)) { # Nonterminal - push(@out, - $o->{'indent'} x $o->{'_depth'}, - "[$line_end", - ); - } else { # Terminal - my $name = $this->name; - push @out, - $o->{'indent'} x $o->{'_depth'}, - defined($name) ? &Tree::DAG_Node::_dump_quote($name) : 'undef', - ",$line_end"; - } - return 1; - } - ; - $o->{'callbackback'} = sub { - my($this, $o) = @_[0,1]; - push(@out, - $o->{'indent'} x $o->{'_depth'}, - "], $line_end", - ) if scalar($this->daughters); - return 1; - } - ; - - $it->walk_down($o); - return join('', @out); -} - -########################################################################### -# $list_r = $root_node->draw_ascii_tree({ h_compact => 1}); -# print map("$_\n", @$list_r); - -=item $list_r = $node->draw_ascii_tree({ ... options ... }) - -Draws a nice ASCII-art representation of the tree structure -at-and-under $node, with $node at the top. Returns a reference to the -list of lines (with no "\n"s or anything at the end of them) that make -up the picture. - -Example usage: - - print map("$_\n", @{$tree->draw_ascii_tree}); - -draw_ascii_tree takes parameters you set in the options hashref: - -* "no_name" -- if true, C doesn't print the name of -the node; simply prints a "*". Defaults to 0 (i.e., print the node -name.) - -* "h_spacing" -- number 0 or greater. Sets the number of spaces -inserted horizontally between nodes (and groups of nodes) in a tree. -Defaults to 1. - -* "h_compact" -- number 0 or 1. Sets the extent to which -C tries to save horizontal space. Defaults to 1. If -I think of a better scrunching algorithm, there'll be a "2" setting -for this. - -* "v_compact" -- number 0, 1, or 2. Sets the degree to which -C tries to save vertical space. Defaults to 1. - -This occasionally returns trees that are a bit cock-eyed in parts; if -anyone can suggest a better drawing algorithm, I'd be appreciative. - -=cut - -sub draw_ascii_tree { - # Make a "box" for this node and its possible daughters, recursively. - - # The guts of this routine are horrific AND recursive! - - # Feel free to send me better code. I worked on this until it - # gave me a headache and it worked passably, and then I stopped. - - my $it = $_[0]; - my $o = ref($_[1]) ? $_[1] : {}; - my(@box, @daughter_boxes, $width, @daughters); - @daughters = @{$it->{'daughters'}}; - - # $it->no_cyclicity; - - $o->{'no_name'} = 0 unless exists $o->{'no_name'}; - $o->{'h_spacing'} = 1 unless exists $o->{'h_spacing'}; - $o->{'h_compact'} = 1 unless exists $o->{'h_compact'}; - $o->{'v_compact'} = 1 unless exists $o->{'v_compact'}; - - my $printable_name; - if($o->{'no_name'}) { - $printable_name = '*'; - } else { - $printable_name = $it->name || $it; - $printable_name =~ tr<\cm\cj\t >< >s; - $printable_name = "<$printable_name>"; - } - - if(!scalar(@daughters)) { # I am a leaf! - # Now add the top parts, and return. - @box = ("|", $printable_name); - } else { - @daughter_boxes = map { &draw_ascii_tree($_, $o) } @daughters; - - my $max_height = 0; - foreach my $box (@daughter_boxes) { - my $h = @$box; - $max_height = $h if $h > $max_height; - } - - @box = ('') x $max_height; # establish the list - - foreach my $one (@daughter_boxes) { - my $length = length($one->[0]); - my $height = @$one; - - #now make all the same height. - my $deficit = $max_height - $height; - if($deficit > 0) { - push @$one, ( scalar( ' ' x $length ) ) x $deficit; - $height = scalar(@$one); - } - - - # Now tack 'em onto @box - ########################################################## - # This used to be a sub of its own. Ho-hum. - - my($b1, $b2) = (\@box, $one); - my($h1, $h2) = (scalar(@$b1), scalar(@$b2)); - - my(@diffs, $to_chop); - if($o->{'h_compact'}) { # Try for h-scrunching. - my @diffs; - my $min_diff = length($b1->[0]); # just for starters - foreach my $line (0 .. ($h1 - 1)) { - my $size_l = 0; # length of terminal whitespace - my $size_r = 0; # length of initial whitespace - $size_l = length($1) if $b1->[$line] =~ /( +)$/s; - $size_r = length($1) if $b2->[$line] =~ /^( +)/s; - my $sum = $size_l + $size_r; - - $min_diff = $sum if $sum < $min_diff; - push @diffs, [$sum, $size_l, $size_r]; - } - $to_chop = $min_diff - $o->{'h_spacing'}; - $to_chop = 0 if $to_chop < 0; - } - - if(not( $o->{'h_compact'} and $to_chop )) { - # No H-scrunching needed/possible - foreach my $line (0 .. ($h1 - 1)) { - $b1->[ $line ] .= $b2->[ $line ] . (' ' x $o->{'h_spacing'}); - } - } else { - # H-scrunching is called for. - foreach my $line (0 .. ($h1 - 1)) { - my $r = $b2->[$line]; # will be the new line - my $remaining = $to_chop; - if($remaining) { - my($l_chop, $r_chop) = @{$diffs[$line]}[1,2]; - - if($l_chop) { - if($l_chop > $remaining) { - $l_chop = $remaining; - $remaining = 0; - } elsif($l_chop == $remaining) { - $remaining = 0; - } else { # remaining > l_chop - $remaining -= $l_chop; - } - } - if($r_chop) { - if($r_chop > $remaining) { - $r_chop = $remaining; - $remaining = 0; - } elsif($r_chop == $remaining) { - $remaining = 0; - } else { # remaining > r_chop - $remaining -= $r_chop; # should never happen! - } - } - - substr($b1->[$line], -$l_chop) = '' if $l_chop; - substr($r, 0, $r_chop) = '' if $r_chop; - } # else no-op - $b1->[ $line ] .= $r . (' ' x $o->{'h_spacing'}); - } - # End of H-scrunching ickyness - } - # End of ye big tack-on - - } - # End of the foreach daughter_box loop - - # remove any fencepost h_spacing - if($o->{'h_spacing'}) { - foreach my $line (@box) { - substr($line, -$o->{'h_spacing'}) = '' if length($line); - } - } - - # end of catenation - die "SPORK ERROR 958203: Freak!!!!!" unless @box; - - # Now tweak the pipes - my $new_pipes = $box[0]; - my $pipe_count = $new_pipes =~ tr<|><+>; - if($pipe_count < 2) { - $new_pipes = "|"; - } else { - my($init_space, $end_space); - - # Thanks to Gilles Lamiral for pointing out the need to set to '', - # to avoid -w warnings about undeffiness. - - if( $new_pipes =~ s<^( +)><>s ) { - $init_space = $1; - } else { - $init_space = ''; - } - - if( $new_pipes =~ s<( +)$><>s ) { - $end_space = $1 - } else { - $end_space = ''; - } - - $new_pipes =~ tr< ><->; - substr($new_pipes,0,1) = "/"; - substr($new_pipes,-1,1) = "\\"; - - $new_pipes = $init_space . $new_pipes . $end_space; - # substr($new_pipes, int((length($new_pipes)), 1)) / 2) = "^"; # feh - } - - # Now tack on the formatting for this node. - if($o->{'v_compact'} == 2) { - if(@daughters == 1) { - unshift @box, "|", $printable_name; - } else { - unshift @box, "|", $printable_name, $new_pipes; - } - } elsif ($o->{'v_compact'} == 1 and @daughters == 1) { - unshift @box, "|", $printable_name; - } else { # general case - unshift @box, "|", $printable_name, $new_pipes; - } - } - - # Flush the edges: - my $max_width = 0; - foreach my $line (@box) { - my $w = length($line); - $max_width = $w if $w > $max_width; - } - foreach my $one (@box) { - my $space_to_add = $max_width - length($one); - next unless $space_to_add; - my $add_left = int($space_to_add / 2); - my $add_right = $space_to_add - $add_left; - $one = (' ' x $add_left) . $one . (' ' x $add_right); - } - - return \@box; # must not return a null list! -} - -########################################################################### - -=item $node->copy_tree or $node->copy_tree({...options...}) - -This returns the root of a copy of the tree that $node is a member of. -If you pass no options, copy_tree pretends you've passed {}. - -This method is currently implemented as just a call to -$this->root->copy_at_and_under({...options...}), but magic may be -added in the future. - -Options you specify are passed down to calls to $node->copy. - -=cut - -sub copy_tree { - my($this, $o) = @_[0,1]; - my $root = $this->root; - $o = {} unless ref $o; - - my $new_root = $root->copy_at_and_under($o); - - return $new_root; -} - -=item $node->copy_at_and_under or $node->copy_at_and_under({...options...}) - -This returns a copy of the subtree consisting of $node and everything -under it. - -If you pass no options, copy_at_and_under pretends you've passed {}. - -This works by recursively building up the new tree from the leaves, -duplicating nodes using $orig_node->copy($options_ref) and then -linking them up into a new tree of the same shape. - -Options you specify are passed down to calls to $node->copy. - -=cut - -sub copy_at_and_under { - my($from, $o) = @_[0,1]; - $o = {} unless ref $o; - my @daughters = map($_->copy_at_and_under($o), @{$from->{'daughters'}}); - my $to = $from->copy($o); - $to->set_daughters(@daughters) if @daughters; - return $to; -} - -=item the constructor $node->copy or $node->copy({...options...}) - -Returns a copy of $node, B its daughter or mother attributes -(which are set back to default values). - -If you pass no options, C pretends you've passed {}. - -Magic happens with the 'attributes' attribute: if it's a hashref (and -it usually is), the new node doesn't end up with the same hashref, but -with ref to a hash with the content duplicated from the original's -hashref. If 'attributes' is not a hashref, but instead an object that -belongs to a class that provides a method called "copy", then that -method is called, and the result saved in the clone's 'attribute' -attribute. Both of these kinds of magic are disabled if the options -you pass to C (maybe via C, or C) -includes (C => 1). - -The options hashref you pass to C (derictly or indirectly) gets -changed slightly after you call C -- it gets an entry called -"from_to" added to it. Chances are you would never know nor care, but -this is reserved for possible future use. See the source if you are -wildly curious. - -Note that if you are using $node->copy (whether directly or via -$node->copy_tree or $node->copy_at_or_under), and it's not properly -copying object attributes containing references, you probably -shouldn't fight it or try to fix it -- simply override copy_tree with: - - sub copy_tree { - use Storable qw(dclone); - my $this = $_[0]; - return dclone($this->root); - # d for "deep" - } - -or - - sub copy_tree { - use Data::Dumper; - my $this = $_[0]; - $Data::Dumper::Purity = 1; - return eval(Dumper($this->root)); - } - -Both of these avoid you having to reinvent the wheel. - -How to override copy_at_or_under with something that uses Storable -or Data::Dumper is left as an exercise to the reader. - -Consider that if in a derived class, you add attributes with really -bizarre contents (like a unique-for-all-time-ID), you may need to -override C. Consider: - - sub copy { - my($it, @etc) = @_; - $it->SUPER::copy(@etc); - $it->{'UID'} = &get_new_UID; - } - -...or the like. See the source of Tree::DAG_Node::copy for -inspiration. - -=cut - -sub copy { - my($from,$o) = @_[0,1]; - $o = {} unless ref $o; - - # Straight dupe, and bless into same class: - my $to = bless { %$from }, ref($from); - - # Null out linkages. - $to->_init_mother; - $to->_init_daughters; - - # dupe the 'attributes' attribute: - unless($o->{'no_attribute_copy'}) { - my $attrib_copy = ref($to->{'attributes'}); - if($attrib_copy) { - if($attrib_copy eq 'HASH') { - $to->{'attributes'} = { %{$to->{'attributes'}} }; - # dupe the hashref - } elsif ($attrib_copy = UNIVERSAL::can($to->{'attributes'}, 'copy') ) { - # $attrib_copy now points to the copier method - $to->{'attributes'} = &{$attrib_copy}($from); - } # otherwise I don't know how to copy it; leave as is - } - } - $o->{'from_to'}->{$from} = $to; # SECRET VOODOO - # ...autovivifies an anon hashref for 'from_to' if need be - # This is here in case I later want/need a table corresponding - # old nodes to new. - return $to; -} - - -########################################################################### - -=item $node->delete_tree - -Destroys the entire tree that $node is a member of (starting at the -root), by nulling out each node-object's attributes (including, most -importantly, its linkage attributes -- hopefully this is more than -sufficient to eliminate all circularity in the data structure), and -then moving it into the class DEADNODE. - -Use this when you're finished with the tree in question, and want to -free up its memory. (If you don't do this, it'll get freed up anyway -when your program ends.) - -If you try calling any methods on any of the node objects in the tree -you've destroyed, you'll get an error like: - - Can't locate object method "leaves_under" - via package "DEADNODE". - -So if you see that, that's what you've done wrong. (Actually, the -class DEADNODE does provide one method: a no-op method "delete_tree". -So if you want to delete a tree, but think you may have deleted it -already, it's safe to call $node->delete_tree on it (again).) - -The C method is needed because Perl's garbage collector -would never (as currently implemented) see that it was time to -de-allocate the memory the tree uses -- until either you call -$node->delete_tree, or until the program stops (at "global -destruction" time, when B is unallocated). - -Incidentally, there are better ways to do garbage-collecting on a -tree, ways which don't require the user to explicitly call a method -like C -- they involve dummy classes, as explained at -C - -However, introducing a dummy class concept into Tree::DAG_Node would -be rather a distraction. If you want to do this with your derived -classes, via a DESTROY in a dummy class (or in a tree-metainformation -class, maybe), then feel free to. - -The only case where I can imagine C failing to totally -void the tree, is if you use the hashref in the "attributes" attribute -to store (presumably among other things) references to other nodes' -"attributes" hashrefs -- which 1) is maybe a bit odd, and 2) is your -problem, because it's your hash structure that's circular, not the -tree's. Anyway, consider: - - # null out all my "attributes" hashes - $anywhere->root->walk_down({ - 'callback' => sub { - $hr = $_[0]->attributes; %$hr = (); return 1; - } - }); - # And then: - $anywhere->delete_tree; - -(I suppose C is a "destructor", or as close as you can -meaningfully come for a circularity-rich data structure in Perl.) - -=cut - -sub delete_tree { - my $it = $_[0]; - $it->root->walk_down({ # has to be callbackback, not callback - 'callbackback' => sub { - %{$_[0]} = (); - bless($_[0], 'DEADNODE'); # cause become dead! cause become dead! - return 1; - } - }); - return; - # Why DEADNODE? Because of the nice error message: - # "Can't locate object method "leaves_under" via package "DEADNODE"." - # Moreover, DEADNODE doesn't provide is_node, so fails my can() tests. -} - -sub DEADNODE::delete_tree { return; } - # in case you kill it AGAIN!!!!! AND AGAIN AND AGAIN!!!!!! OO-HAHAHAHA! - -########################################################################### -# stolen from MIDI.pm - -sub _dump_quote { - my @stuff = @_; - return - join(", ", - map - { # the cleaner-upper function - if(!length($_)) { # empty string - "''"; - } elsif( m/^-?\d+(?:\.\d+)?$/s ) { # a number - $_; - } elsif( # text with junk in it - s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> - <'\\x'.(unpack("H2",$1))>eg - ) { - "\"$_\""; - } else { # text with no junk in it - s<'><\\'>g; - "\'$_\'"; - } - } - @stuff - ); -} - -########################################################################### - -=back - -=head2 When and How to Destroy - -It should be clear to you that if you've built a big parse tree or -something, and then you're finished with it, you should call -$some_node->delete_tree on it if you want the memory back. - -But consider this case: you've got this tree: - - A - / | \ - B C D - | | \ - E X Y - -Let's say you decide you don't want D or any of its descendants in the -tree, so you call D->unlink_from_mother. This does NOT automagically -destroy the tree D-X-Y. Instead it merely splits the tree into two: - - A D - / \ / \ - B C X Y - | - E - -To destroy D and its little tree, you have to explicitly call -delete_tree on it. - -Note, however, that if you call C->unlink_from_mother, and if you don't -have a link to C anywhere, then it B magically go away. This is -because nothing links to C -- whereas with the D-X-Y tree, D links to -X and Y, and X and Y each link back to D. Note that calling -C->delete_tree is harmless -- after all, a tree of only one node is -still a tree. - -So, this is a surefire way of getting rid of all $node's children and -freeing up the memory associated with them and their descendants: - - foreach my $it ($node->clear_daughters) { $it->delete_tree } - -Just be sure not to do this: - - foreach my $it ($node->daughters) { $it->delete_tree } - $node->clear_daughters; - -That's bad; the first call to $_->delete_tree will climb to the root -of $node's tree, and nuke the whole tree, not just the bits under $node. -You might as well have just called $node->delete_tree. -(Moreavor, once $node is dead, you can't call clear_daughters on it, -so you'll get an error there.) - -=head1 BUG REPORTS - -If you find a bug in this library, report it to me as soon as possible, -at the address listed in the AUTHOR section, below. Please try to be -as specific as possible about how you got the bug to occur. - -=head1 HELP! - -If you develop a given routine for dealing with trees in some way, and -use it a lot, then if you think it'd be of use to anyone else, do email -me about it; it might be helpful to others to include that routine, or -something based on it, in a later version of this module. - -It's occurred to me that you might like to (and might yourself develop -routines to) draw trees in something other than ASCII art. If you do so --- say, for PostScript output, or for output interpretable by some -external plotting program -- I'd be most interested in the results. - -=head1 RAMBLINGS - -This module uses "strict", but I never wrote it with -w warnings in -mind -- so if you use -w, do not be surprised if you see complaints -from the guts of DAG_Node. As long as there is no way to turn off -w -for a given module (instead of having to do it in every single -subroutine with a "local $^W"), I'm not going to change this. However, -I do, at points, get bursts of ambition, and I try to fix code in -DAG_Node that generates warnings, I -- which is -only occasionally. Feel free to email me any patches for any such -fixes you come up with, tho. - -Currently I don't assume (or enforce) anything about the class -membership of nodes being manipulated, other than by testing whether -each one provides a method C, a la: - - die "Not a node!!!" unless UNIVERSAL::can($node, "is_node"); - -So, as far as I'm concerned, a given tree's nodes are free to belong to -different classes, just so long as they provide/inherit C, the -few methods that this class relies on to navigate the tree, and have the -same internal object structure, or a superset of it. Presumably this -would be the case for any object belonging to a class derived from -C, or belonging to C itself. - -When routines in this class access a node's "mother" attribute, or its -"daughters" attribute, they (generally) do so directly (via -$node->{'mother'}, etc.), for sake of efficiency. But classes derived -from this class should probably do this instead thru a method (via -$node->mother, etc.), for sake of portability, abstraction, and general -goodness. - -However, no routines in this class (aside from, necessarily, C<_init>, -C<_init_name>, and C) access the "name" attribute directly; -routines (like the various tree draw/dump methods) get the "name" value -thru a call to $obj->name(). So if you want the object's name to not be -a real attribute, but instead have it derived dynamically from some feature -of the object (say, based on some of its other attributes, or based on -its address), you can to override the C method, without causing -problems. (Be sure to consider the case of $obj->name as a write -method, as it's used in C and C.) - -=head1 SEE ALSO - -L - -Wirth, Niklaus. 1976. I -Prentice-Hall, Englewood Cliffs, NJ. - -Knuth, Donald Ervin. 1997. I. Addison-Wesley, Reading, MA. - -Wirth's classic, currently and lamentably out of print, has a good -section on trees. I find it clearer than Knuth's (if not quite as -encyclopedic), probably because Wirth's example code is in a -block-structured high-level language (basically Pascal), instead -of in assembler (MIX). - -Until some kind publisher brings out a new printing of Wirth's book, -try poking around used bookstores (or C) for a copy. -I think it was also republished in the 1980s under the title -I, and in a German edition called -I. (That is, I'm sure books by Knuth -were published under those titles, but I'm I that they're just -later printings/editions of I.) - -=head1 COPYRIGHT AND DISCLAIMER - -Copyright 1998,1999,2000,2001 by Sean M. Burke C, all -rights reserved. This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Sean M. Burke C - -=cut - -1; - -__END__ diff --git a/lib/WebGUI/Asset/Wobject.pm b/lib/WebGUI/Asset/Wobject.pm index 8fa2cb493..c40bc2967 100644 --- a/lib/WebGUI/Asset/Wobject.pm +++ b/lib/WebGUI/Asset/Wobject.pm @@ -29,7 +29,6 @@ use WebGUI::Id; use WebGUI::International; use WebGUI::Macro; use WebGUI::Node; -use WebGUI::Page; use WebGUI::Privilege; use WebGUI::Session; use WebGUI::Style; @@ -39,7 +38,7 @@ use WebGUI::Template; use WebGUI::URL; use WebGUI::Utility; use WebGUI::MetaData; -use WebGUI::Wobject::WobjectProxy; +#use WebGUI::Asset::Wobject::WobjectProxy; our @ISA = qw(WebGUI::Asset); diff --git a/lib/WebGUI/Auth.pm b/lib/WebGUI/Auth.pm index 53824207c..4811a81ae 100644 --- a/lib/WebGUI/Auth.pm +++ b/lib/WebGUI/Auth.pm @@ -27,8 +27,6 @@ use WebGUI::HTTP; use WebGUI::Icon; use WebGUI::International; use WebGUI::Macro; -use WebGUI::Node; -use WebGUI::Page; use WebGUI::Session; use WebGUI::SQL; use WebGUI::TabForm; diff --git a/lib/WebGUI/Collateral.pm b/lib/WebGUI/Collateral.pm deleted file mode 100644 index aecfa50df..000000000 --- a/lib/WebGUI/Collateral.pm +++ /dev/null @@ -1,292 +0,0 @@ -package WebGUI::Collateral; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - -use WebGUI::Attachment; -use WebGUI::DateTime; -use WebGUI::Id; -use WebGUI::Session; -use WebGUI::SQL; -use WebGUI::Utility; - -our @ISA = qw(WebGUI::Attachment); - -=head1 NAME - -Package WebGUI::Collateral - -=head1 DESCRIPTION - -Package to manipulate items in WebGUI's collateral manager. - -=head1 SYNOPSIS - - use WebGUI::Collateral; - - $collateral = WebGUI::Collateral->new(1234); - - $collateral = WebGUI::Collateral->find("My Snippet"); - - $collateral->delete; - $collateral->deleteFile; - $collateral->get("parameters"); - $collateral->set(\%hash); - -=head1 SEE ALSO - -This package is derived from WebGUI::Attachment. See that package for documentation of its methods. - -=head1 METHODS - -These methods are available from this class: - -=cut - -#------------------------------------------------------------------- -# extended only to save info to database -sub createThumbnail { - $_[0]->SUPER::createThumbnail($_[1]); - if ($_[1] != $_[0]->get("thumbnailSize")) { - $_[0]->set({thumbnailSize=>$_[1]}); - } -} - - -#------------------------------------------------------------------- - -=head2 delete ( ) - -Delete's this collateral item. - -=cut - -sub delete { - if ($_[0]->{_properties}->{collateralId}) { # blocks deletion of all collateral in the event that no valid collateral id exists - $_[0]->deleteNode; - WebGUI::SQL->write("delete from collateral where collateralId=".quote($_[0]->get("collateralId"))); - } -} - - -#------------------------------------------------------------------- - -=head2 deleteFile ( ) - -Deletes the file attached to this collateral item. - -=cut - -sub deleteFile { - $_[0]->SUPER::delete; - WebGUI::SQL->write("update collateral set filename='' where collateralId=".quote($_[0]->get("collateralId"))); - $_[0]->{_properties}{filename}=''; -} - - -#------------------------------------------------------------------- - -=head2 find ( name ) - -An alternative to the constructor "new", use find as a constructor by name rather than id. - -=head3 name - -The name of the collateral item you wish to instanciate. - -=cut - -sub find { - my ($collateralId) = WebGUI::SQL->quickArray("select collateralId from collateral where name=".quote($_[1])); - return WebGUI::Collateral->new($collateralId); -} - -#------------------------------------------------------------------- - -=head2 get ( [ propertyName ] ) - -Returns a hash reference containing all of the properties of this collateral item. - -=head3 propertyName - -If an individual propertyName is specified, then only that property value is returned as a scalar. - -=cut - -sub get { - if ($_[1] ne "") { - return $_[0]->{_properties}{$_[1]}; - } else { - return $_[0]->{_properties}; - } -} - - -#------------------------------------------------------------------- - -=head2 new ( collateralId ) - -Constructor. - -=head3 collateralId - -The unique identifier for this piece of collateral. If set to "new" an id will be generated. - -=cut - -sub new { - my ($class, $collateralId) = @_; - my $properties; - if ($collateralId eq "new") { - $properties = { - collateralId=>WebGUI::Id::generate(), - collateralFolderId=>0, - collateralType=>"image", - userId=>$session{user}{userId}, - dateUploaded=>time(), - thumbnailSize=>$session{setting}{thumbnailSize}, - name=>"untitled", - username=>$session{user}{username} - }; - WebGUI::SQL->write("insert into collateral (collateralId, collateralFolderId, collateraltype, userId, - dateUploaded, thumbnailSize, name, username) values ( ".quote($properties->{collateralId}).", - ".quote($properties->{collateralFolderId}).", ".quote($properties->{collateralType}).", - ".quote($properties->{userId}).", ".$properties->{dateUploaded}.", ".$properties->{thumbnailSize}.", - ".quote($properties->{name}).", ".quote($properties->{username}).")"); - } else { - $properties = WebGUI::SQL->quickHashRef("select * from collateral where collateralId=".quote($collateralId)); - } - return $class->_new($properties); -} - -#------------------------------------------------------------------- - -# Reuse this code for multiNew -sub _new { - my ($class,$properties) = @_; - return undef unless $properties; - my $self = WebGUI::Attachment->new($properties->{filename},"images",$properties->{collateralId}); - $self->{_properties} = $properties; - bless $self, $class; -} - -#------------------------------------------------------------------- - -=head2 multiDelete ( @collateraIds ) - -Deletes the nodes and database entries for a list of collateral items. - -=cut - -sub multiDelete { - my ($class,@ids) = @_; - return undef unless @ids; - - my @collateral = $class->multiNew(@ids); - foreach my $obj (@collateral) { - $obj->deleteNode(); - } - - my $clause = "collateralId in (".quoteAndJoin(\@ids).")"; - WebGUI::SQL->write("delete from collateral where $clause"); -} - -#------------------------------------------------------------------- - -=head2 multiNew ( @collateralIds ) - -Returns a list of WebGUI::Collateral objects. - -=cut - -sub multiNew { - my ($class,@collateralIds) = @_; - return () unless @collateralIds; - - my (@objs); - - my $clause = "collateralId in (".quoteAndJoin(\@collateralIds).")"; - my $sth = WebGUI::SQL->read("select * from collateral where $clause"); - - while (my $hash = $sth->hashRef()) { - push @objs,$class->_new($hash); - } - - return @objs; -} - -#------------------------------------------------------------------- - -=head2 set ( properties ) - -Sets the value of a property for this collateral item. - -=head3 properties - -A hash reference containing the list of properties to set. The valid property names are "name", "parameters", "userId", "username", "collateralFolderId", "collateralType", and "thumbnailSize". - -If username or userId are not specified, the current user will be used. - -=cut - -sub set { - my ($key, $sql, @update, $i); - my $self = shift; - my $properties = shift; - $self->{_properties}->{dateUploaded} = time(); - $properties->{userId} = $session{user}{userId} if ($properties->{userId} eq ""); - $properties->{username} = $session{user}{username} if ($properties->{username} eq ""); - $properties->{thumbnailSize} = $session{setting}{thumbnailSize} if ($properties->{thumbnailSize} eq ""); - $sql = "update collateral set"; - foreach $key (keys %{$properties}) { - $self->{_property}{$key} = $properties->{$key}; - if (isIn($key, qw(name parameters userId username collateralFolderId collateralType thumbnailSize))) { - $sql .= " ".$key."=".quote($properties->{$key}).","; - } - } - $sql .= " dateUploaded=".$self->{_properties}{dateUploaded}." - where collateralid=".quote($self->get("collateralId")); - WebGUI::SQL->write($sql); -} - - -#------------------------------------------------------------------- -# extended only to save info to database -sub save { - my $filename = $_[0]->SUPER::save($_[1],$_[2],$_[3]); - if ($filename) { - WebGUI::SQL->write("update collateral set filename=".quote($filename) - ." where collateralId=".quote($_[0]->get("collateralId"))); - $_[0]->{_properties}{filename} = $filename; - } - return $filename; -} - -#------------------------------------------------------------------- -# extended only to save info to database -sub saveFromFilesystem { - my $filename = $_[0]->SUPER::saveFromFilesystem($_[1],$_[2],$_[3]); - if ($filename) { - WebGUI::SQL->write("update collateral set filename=".quote($filename) - ." where collateralId=".quote($_[0]->get("collateralId"))); - $_[0]->{_properties}{filename} = $filename; - } - return $filename; -} - - - -1; - - diff --git a/lib/WebGUI/CollateralFolder.pm b/lib/WebGUI/CollateralFolder.pm deleted file mode 100644 index 7659e06a6..000000000 --- a/lib/WebGUI/CollateralFolder.pm +++ /dev/null @@ -1,82 +0,0 @@ -package WebGUI::CollateralFolder; - - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - - -use strict; -use warnings; - -use WebGUI::Collateral; -use WebGUI::Persistent::Tree; -use WebGUI::SQL; - -our @ISA = qw(WebGUI::Persistent::Tree); - -=head1 NAME - -Package WebGUI::CollateralFolder - -=head1 DESCRIPTION - -This is a management package for the collateral folder system. - -=head2 SYNOPSIS - - use WebGUI::CollateralFolder; - $collateralFolder->recursiveDelete; - -=head1 METHODS - -For inherited methods see L. - -=cut - -#------------------------------------------------------------------- - -sub classSettings { - return { - properties => { - name => { quote => 1 }, - parentId => { quote => 1 }, - collateralFolderId => { key => 1 }, - description => { quote => 1 } - }, - table => 'collateralFolder' - } -} - -#------------------------------------------------------------------- - -=head2 recursiveDelete () - -Recursively delete a folder, sub folders and contents - -=cut - -sub recursiveDelete { - my ($self) = @_; - my @ids = $self->SUPER::recursiveDelete(); - return unless @ids; - - # If WebGUI::Collateral inherited from WebGUI::Persistent then we would only - # need the following line: - # WebGUI::Collateral->multiDelete(collateralFolderId => \@ids); - - my @collateralIds = WebGUI::SQL->buildArray("select collateralId from collateral where collateralFolderId in (".quoteAndJoin(\@ids).")"); - WebGUI::Collateral->multiDelete(@collateralIds); -} - -1; diff --git a/lib/WebGUI/Help/WebGUI.pm b/lib/WebGUI/Help/WebGUI.pm index c955ed6cf..c84672b62 100644 --- a/lib/WebGUI/Help/WebGUI.pm +++ b/lib/WebGUI/Help/WebGUI.pm @@ -1,16 +1,6 @@ package WebGUI::Help::WebGUI; our $HELP = { - 'image add/edit' => { - title => '670', - body => '625', - related => [ - { - tag => 'collateral manage', - namespace => 'WebGUI' - } - ] - }, 'packages creating' => { title => '681', body => '636', @@ -395,10 +385,6 @@ our $HELP = { title => '669', body => '624', related => [ - { - tag => 'collateral macros', - namespace => 'WebGUI' - }, { tag => 'navigation macros', namespace => 'WebGUI' @@ -467,36 +453,6 @@ our $HELP = { } ] }, - 'collateral manage' => { - title => '785', - body => '786', - related => [ - { - tag => 'collateral macros', - namespace => 'WebGUI' - }, - { - tag => 'file add/edit', - namespace => 'WebGUI' - }, - { - tag => 'folder add/edit', - namespace => 'WebGUI' - }, - { - tag => 'image add/edit', - namespace => 'WebGUI' - }, - { - tag => 'themes manage', - namespace => 'WebGUI' - }, - { - tag => 'snippet add/edit', - namespace => 'WebGUI' - } - ] - }, 'template language' => { title => '825', body => '826', @@ -583,50 +539,6 @@ our $HELP = { } ] }, - 'collateral macros' => { - title => '831', - body => '832', - related => [ - { - tag => 'collateral manage', - namespace => 'WebGUI' - }, - { - tag => 'macros using', - namespace => 'WebGUI' - } - ] - }, - 'file add/edit' => { - title => '833', - body => '834', - related => [ - { - tag => 'collateral manage', - namespace => 'WebGUI' - } - ] - }, - 'snippet add/edit' => { - title => '835', - body => '836', - related => [ - { - tag => 'collateral manage', - namespace => 'WebGUI' - } - ] - }, - 'folder add/edit' => { - title => '837', - body => '838', - related => [ - { - tag => 'collateral manage', - namespace => 'WebGUI' - } - ] - }, 'programmer macros' => { title => '839', body => '840', @@ -689,10 +601,6 @@ our $HELP = { title => '931', body => '932', related => [ - { - tag => 'collateral manage', - namespace => 'WebGUI' - }, { tag => 'templates manage', namespace => 'WebGUI' diff --git a/lib/WebGUI/Macro/CanEditText.pm b/lib/WebGUI/Macro/CanEditText.pm index 64c050257..a17053642 100644 --- a/lib/WebGUI/Macro/CanEditText.pm +++ b/lib/WebGUI/Macro/CanEditText.pm @@ -12,13 +12,12 @@ package WebGUI::Macro::CanEditText; use strict; use WebGUI::Macro; -use WebGUI::Page; use WebGUI::Session; #------------------------------------------------------------------- sub process { my @param = WebGUI::Macro::getParams($_[0]); - if (WebGUI::Page::canEdit()) { + if (exists $session{asset} && $session{asset}->canEdit) { return $param[0]; } else { return ""; diff --git a/lib/WebGUI/Macro/EditableToggle.pm b/lib/WebGUI/Macro/EditableToggle.pm index ba58b722d..0aebc28cd 100644 --- a/lib/WebGUI/Macro/EditableToggle.pm +++ b/lib/WebGUI/Macro/EditableToggle.pm @@ -14,14 +14,13 @@ use strict; use WebGUI::Grouping; use WebGUI::International; use WebGUI::Macro; -use WebGUI::Page; use WebGUI::Session; use WebGUI::Template; use WebGUI::URL; #------------------------------------------------------------------- sub process { - if (WebGUI::Page::canEdit() && WebGUI::Grouping::isInGroup(12)) { + if (exists $session{asset} && $session{asset}->canEdit && WebGUI::Grouping::isInGroup(12)) { my %var; my @param = WebGUI::Macro::getParams($_[0]); my $turnOn = $param[0] || WebGUI::International::get(516); diff --git a/lib/WebGUI/Macro/RootTitle.pm b/lib/WebGUI/Macro/RootTitle.pm index 9a1992502..c722c4028 100644 --- a/lib/WebGUI/Macro/RootTitle.pm +++ b/lib/WebGUI/Macro/RootTitle.pm @@ -11,14 +11,20 @@ package WebGUI::Macro::RootTitle; #------------------------------------------------------------------- use strict; -use Tie::CPHash; -use WebGUI::Page; +use WebGUI::Asset; use WebGUI::Session; #------------------------------------------------------------------- sub process { - my $root = WebGUI::Page->getWebGUIRoot; - return $root->get("title"); + if (exists $session{asset}) { + my $lineage = $session{asset}->get("lineage"); + $lineage = substr($lineage,0,6); + my $root = WebGUI::Asset->newByLineage($lineage); + if (defined $root) { + return $root->get("title"); + } + } + return ""; } diff --git a/lib/WebGUI/Operation.pm b/lib/WebGUI/Operation.pm index 55a4b4010..aea30850c 100644 --- a/lib/WebGUI/Operation.pm +++ b/lib/WebGUI/Operation.pm @@ -94,23 +94,6 @@ sub getOperations { 'emptyClipboard' => 'WebGUI::Operation::Clipboard', 'emptyClipboardConfirm' => 'WebGUI::Operation::Clipboard', 'manageClipboard' => 'WebGUI::Operation::Clipboard', - 'editCollateral' => 'WebGUI::Operation::Collateral', - 'editCollateralSave' => 'WebGUI::Operation::Collateral', - 'deleteCollateral' => 'WebGUI::Operation::Collateral', - 'deleteCollateralConfirm' => 'WebGUI::Operation::Collateral', - 'listCollateral' => 'WebGUI::Operation::Collateral', - 'deleteCollateralFile' => 'WebGUI::Operation::Collateral', - 'editCollateralFolder' => 'WebGUI::Operation::Collateral', - 'editCollateralFolderSave' => 'WebGUI::Operation::Collateral', - 'deleteCollateralFolder' => 'WebGUI::Operation::Collateral', - 'deleteCollateralFolderConfirm' => 'WebGUI::Operation::Collateral', - 'emptyCollateralFolder' => 'WebGUI::Operation::Collateral', - 'emptyCollateralFolderConfirm' => 'WebGUI::Operation::Collateral', - 'htmlArealistCollateral' => 'WebGUI::Operation::Collateral', - 'htmlAreaviewCollateral' => 'WebGUI::Operation::Collateral', - 'htmlAreaUpload' => 'WebGUI::Operation::Collateral', - 'htmlAreaDelete' => 'WebGUI::Operation::Collateral', - 'htmlAreaCreateFolder' => 'WebGUI::Operation::Collateral', 'copyDatabaseLink' => 'WebGUI::Operation::DatabaseLink', 'deleteDatabaseLink' => 'WebGUI::Operation::DatabaseLink', 'deleteDatabaseLinkConfirm' => 'WebGUI::Operation::DatabaseLink', @@ -147,22 +130,6 @@ sub getOperations { 'saveMetaDataSettings' => 'WebGUI::Operation::MetaData', 'deployPackage' => 'WebGUI::Operation::Package', 'managePackages' => 'WebGUI::Operation::Package', - 'viewPageTree' => 'WebGUI::Operation::Page', - 'movePageUp' => 'WebGUI::Operation::Page', - 'movePageDown' => 'WebGUI::Operation::Page', - 'cutPage' => 'WebGUI::Operation::Page', - 'deletePageConfirm' => 'WebGUI::Operation::Page', - 'editPage' => 'WebGUI::Operation::Page', - 'editPageSave' => 'WebGUI::Operation::Page', - 'exportPage' => 'WebGUI::Operation::Page', - 'exportPageStatus' => 'WebGUI::Operation::Page', - 'pastePage' => 'WebGUI::Operation::Page', - 'moveTreePageUp' => 'WebGUI::Operation::Page', - 'rearrangeWobjects' => 'WebGUI::Operation::Page', - 'moveTreePageDown' => 'WebGUI::Operation::Page', - 'moveTreePageLeft' => 'WebGUI::Operation::Page', - 'moveTreePageRight' => 'WebGUI::Operation::Page', - 'richEditPageTree' => 'WebGUI::Operation::Page', 'editProfile' => 'WebGUI::Operation::Profile', 'editProfileSave' => 'WebGUI::Operation::Profile', 'viewProfile' => 'WebGUI::Operation::Profile', diff --git a/lib/WebGUI/Operation/Collateral.pm b/lib/WebGUI/Operation/Collateral.pm deleted file mode 100644 index e12d80c4a..000000000 --- a/lib/WebGUI/Operation/Collateral.pm +++ /dev/null @@ -1,665 +0,0 @@ -package WebGUI::Operation::Collateral; - -#------------------------------------------------------------------- -# WebGUI is Copyright 2001-2004 Plain Black Corporation. -#------------------------------------------------------------------- -# Please read the legal notices (docs/legal.txt) and the license -# (docs/license.txt) that came with this distribution before using -# this software. -#------------------------------------------------------------------- -# http://www.plainblack.com info@plainblack.com -#------------------------------------------------------------------- - - -# test for ImageMagick. if it's not installed set $hasImageMagick to 0, -# if it is installed it will be set to 1 -my $hasImageMagick=1; -eval " use Image::Magick; "; $hasImageMagick=0 if $@; - - -use strict; -use WebGUI::Collateral; -use WebGUI::CollateralFolder; -use WebGUI::DateTime; -use WebGUI::Grouping; -use WebGUI::HTMLForm; -use WebGUI::Icon; -use WebGUI::Id; -use WebGUI::International; -use WebGUI::Operation::Shared; -use WebGUI::Paginator; -use WebGUI::Privilege; -use WebGUI::Session; -use WebGUI::SQL; -use Tie::IxHash; -use WebGUI::URL; -use WebGUI::HTML; - - -#------------------------------------------------------------------- -sub _submenu { - my (%menu); - tie %menu, 'Tie::IxHash'; - $menu{WebGUI::URL::page('op=editCollateralFolder&fid=new')} = WebGUI::International::get(758); - $menu{WebGUI::URL::page('op=editCollateral&cid=new&type=image')} = WebGUI::International::get(761); - $menu{WebGUI::URL::page('op=editCollateral&cid=new&type=file')} = WebGUI::International::get(762); - $menu{WebGUI::URL::page('op=editCollateral&cid=new&type=snippet')} = WebGUI::International::get(763); - if ($session{form}{op} eq "editCollateral" || $session{form}{op} eq "deleteCollateral") { - $menu{WebGUI::URL::page('op=editCollateral&cid='.$session{form}{cid})} = WebGUI::International::get(764); - $menu{WebGUI::URL::page('op=deleteCollateral&cid='.$session{form}{cid})} = WebGUI::International::get(765); - } - $menu{WebGUI::URL::page('op=editCollateralFolder')} = WebGUI::International::get(759); - if (WebGUI::Grouping::isInGroup(3)) { - $menu{WebGUI::URL::page('op=emptyCollateralFolder')} = WebGUI::International::get(980); -# $menu{WebGUI::URL::page('op=deleteCollateralFolder')} = WebGUI::International::get(760); - } - $menu{WebGUI::URL::page('op=listCollateral')} = WebGUI::International::get(766); - return menuWrapper($_[0],\%menu); -} - -#------------------------------------------------------------------- -sub www_deleteCollateral { - my $collateral = WebGUI::Collateral->new($session{form}{cid}); - return WebGUI::Privilege::insufficient unless ($collateral->get("userId") == $session{user}{userId} || WebGUI::Grouping::isInGroup(3)); - my $output = '

'.WebGUI::International::get(42).'

'; - $output .= WebGUI::International::get(774).'

'; - $output .= '' - .WebGUI::International::get(44).''; - $output .= '    '; - $output .= ''.WebGUI::International::get(45).''; - $output .= '
'; - return _submenu($output); -} - -#------------------------------------------------------------------- -sub www_deleteCollateralConfirm { - my $collateral = WebGUI::Collateral->new($session{form}{cid}); - return WebGUI::Privilege::insufficient unless ($collateral->get("userId") == $session{user}{userId} || WebGUI::Grouping::isInGroup(3)); - $collateral->delete; - WebGUI::Session::deleteScratch("collateralPageNumber"); - return www_listCollateral(); -} - -#------------------------------------------------------------------- -sub www_deleteCollateralFile { - my $collateral = WebGUI::Collateral->new($session{form}{cid}); - return WebGUI::Privilege::insufficient unless ($collateral->get("userId") == $session{user}{userId} || WebGUI::Grouping::isInGroup(3)); - $collateral->deleteFile; - return www_editCollateral($collateral); -} - -#------------------------------------------------------------------- -sub www_deleteCollateralFolder { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(3)); - return WebGUI::Privilege::vitalComponent() if ($session{scratch}{collateralFolderId} eq "0" || $session{scratch}{collateralFolderId} eq ""); - my $output = '

'.WebGUI::International::get(42).'

'; - $output .= WebGUI::International::get(775).'

'; - $output .= '' - .WebGUI::International::get(44).''; - $output .= '    '; - $output .= ''.WebGUI::International::get(45).''; - $output .= '
'; - return _submenu($output); -} - -#------------------------------------------------------------------- -sub www_deleteCollateralFolderConfirm { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(3)); - return WebGUI::Privilege::vitalComponent() if ($session{scratch}{collateralFolderId} eq "0" || $session{scratch}{collateralFolderId} eq ""); - my $folders = WebGUI::CollateralFolder->getTree({-minimumFields => 1}); - if (my $deadFolder = $folders->{$session{scratch}{collateralFolderId}}) { - my $parentId = $deadFolder->get("parentId"); - $deadFolder->recursiveDelete(); - WebGUI::Session::setScratch("collateralFolderId",$parentId); - } - return www_listCollateral(); -} - -#------------------------------------------------------------------- -sub www_emptyCollateralFolder { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(3)); - my $output = '

'.WebGUI::International::get(42).'

'; - $output .= WebGUI::International::get(979).'

'; - $output .= '' - .WebGUI::International::get(44).''; - $output .= '    '; - $output .= ''.WebGUI::International::get(45).''; - $output .= '
'; - return _submenu($output); -} - -#------------------------------------------------------------------- -sub www_emptyCollateralFolderConfirm { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(3)); - my @collateralIds = WebGUI::SQL->buildArray("select collateralId from collateral where collateralFolderId=".quote($session{scratch}{collateralFolderId})); - WebGUI::Collateral->multiDelete(@collateralIds); - return www_listCollateral(); -} - -#------------------------------------------------------------------- -sub www_editCollateral { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(4)); - my ($canEdit, $file, $folderId, $output, $f, $collateral, $image, $error, $x, $y); - if ($session{form}{cid} eq "new") { - $collateral->{collateralType} = $session{form}{type}; - $collateral->{collateralId} = "new"; - $collateral->{username} = $session{user}{username}; - $collateral->{userId} = $session{user}{userId}; - $collateral->{parameters} = 'border="0"' if ($session{form}{type} eq "image"); - $collateral->{thumbnailSize} = $session{setting}{thumbnailSize}; - } else { - my $c = $_[1] || WebGUI::Collateral->new($session{form}{cid}); - $collateral = $c->get; - } - $canEdit = ($collateral->{userId} == $session{user}{userId} || WebGUI::Grouping::isInGroup(3)); - $folderId = $session{scratch}{collateralFolderId} || 0; - $f = WebGUI::HTMLForm->new; - $f->hidden("op","editCollateralSave"); - $f->hidden("collateralType",$collateral->{collateralType}); - $f->hidden("cid",$collateral->{collateralId}); - $f->hidden("userId", $collateral->{userId}); - $f->hidden("userName", $collateral->{userName}); - $f->readOnly( - -label=>WebGUI::International::get(767), - -value=>$collateral->{collateralId} - ); - $f->readOnly( - -label=>WebGUI::International::get(388), - -value=>epochToHuman($collateral->{dateUploaded},"%z") - ); - $f->readOnly( - -label=>WebGUI::International::get(387), - -value=>$collateral->{username} - ); - if ($canEdit) { - $f->text( - -name=>"name", - -value=>$collateral->{name}, - -label=>WebGUI::International::get(768) - ); - $f->selectList( - -name=>"collateralFolderId", - -value=>[$folderId], - -label=>WebGUI::International::get(769), - -options=>WebGUI::SQL->buildHashRef("select collateralFolderId,name from collateralFolder order by name") - ); - } else { - $f->readOnly( - -label=>WebGUI::International::get(768), - -value=>$collateral->{name} - ); - } - if ($collateral->{collateralType} eq "snippet") { - $output .= '

'.WebGUI::International::get(770).'

'; - if ($canEdit) { - $f->textarea( - -name=>"parameters", - -value=>$collateral->{parameters}, - -label=>WebGUI::International::get(771) - ); - } else { - $f->readOnly( - -value=>$collateral->{parameters}, - -label=>WebGUI::International::get(771) - ); - } - } elsif ($collateral->{collateralType} eq "file") { - $output .= '

'.WebGUI::International::get(772).'

'; - if ($canEdit) { - if ($collateral->{filename} ne "") { - $f->readOnly( - -value=>''.WebGUI::International::get(391).'', - -label=>WebGUI::International::get(773) - ); - } else { - $f->file( - -name=>"filename", - -label=>WebGUI::International::get(773) - ); - } - } - $file = WebGUI::Attachment->new($collateral->{filename},"images",$collateral->{collateralId}); - if ($file->getFilename ne "") { - $f->readOnly( - -value=>' ' - .$file->getFilename.'' - ); - } - } else { - $output .= helpIcon("image add/edit"); - $output .= '

'.WebGUI::International::get(382).'

'; - if ($canEdit) { - if ($collateral->{filename} ne "") { - $f->readOnly( - -value=>''.WebGUI::International::get(391).'', - -label=>WebGUI::International::get(384) - ); - } else { - $f->file( - -name=>"filename", - -label=>WebGUI::International::get(384) - ); - } - } - $file = WebGUI::Attachment->new($collateral->{filename},"images",$collateral->{collateralId}); - if ($file->getFilename ne "") { - $f->readOnly( - -value=>'' - ); - if ($hasImageMagick) { - $image = Image::Magick->new; - $error = $image->Read($file->getPath); - ($x, $y) = $image->Get('width','height'); - $f->readOnly( - -value=>$error ? "Error reading image: $error" : "$x x $y", - -label=>"Image dimensions" - ); - } - } - - if ($canEdit) { - $f->textarea( - -name=>"parameters", - -value=>$collateral->{parameters}, - -label=>WebGUI::International::get(385) - ); - } else { - $f->readOnly( - -label=>WebGUI::International::get(385), - -value=>$collateral->{parameters} - ); - } - if ($canEdit && $collateral->{collateralType} eq 'image') { - $f->text( - -name=>"thumbnailSize", - -value=>$collateral->{thumbnailSize}, - -label=>"Thumbnail size" - ); - } - } - $f->submit if ($canEdit); - $output .= $f->print; - return _submenu($output); -} - -#------------------------------------------------------------------- -sub www_editCollateralSave { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(4)); - WebGUI::Session::setScratch("collateralFolderId",$session{form}{collateralFolderId}); - my ($test, $file, $addFile); - my $collateral = WebGUI::Collateral->new($session{form}{cid}); - $session{form}{thumbnailSize} ||= $session{setting}{thumbnailSize}; - if ($session{form}{cid} eq "new") { - $session{form}{cid} = $collateral->get("collateralId"); - } elsif ($collateral->get("thumbnailSize") != $session{form}{thumbnailSize}) { - $collateral->createThumbnail($session{form}{thumbnailSize}); - } - $collateral->save("filename", $session{form}{thumbnailSize}); - $session{form}{name} = "untitled" if ($session{form}{name} eq ""); - while (($test) = WebGUI::SQL->quickArray("select name from collateral - where name=".quote($session{form}{name})." and collateralId<>".quote($collateral->get("collateralId")))) { - if ($session{form}{name} =~ /(.*)(\d+$)/) { - $session{form}{name} = $1.($2+1); - } elsif ($test ne "") { - $session{form}{name} .= "2"; - } - } - $collateral->set($session{form}); - $session{form}{collateralType} = ""; - return www_listCollateral(); -} - -#------------------------------------------------------------------- -sub www_editCollateralFolder { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(4)); - my ($output, $f, $folder, $folderId, $constraint); - $output .= '

'.WebGUI::International::get(776).'

'; - if ($session{form}{fid} eq "new") { - $folder->{collateralFolderId} = "new"; - $folder->{parentId} = $session{scratch}{collateralFolderId} || 0; - } else { - $folderId = $session{scratch}{collateralFolderId} || 0; - $folder = WebGUI::SQL->quickHashRef("select * from collateralFolder where collateralFolderId=".quote($folderId)); - $constraint = "where collateralFolderId<>".quote($folder->{collateralFolderId}); - } - $f = WebGUI::HTMLForm->new; - $f->hidden("op","editCollateralFolderSave"); - $f->hidden("fid",$session{form}{fid}); - $f->readOnly( - -value=>$folder->{collateralFolderId}, - -label=>WebGUI::International::get(777) - ); - if ($folder->{collateralFolderId} eq "0") { - $f->hidden("parentId",0); - } else { - $f->selectList( - -name=>"parentId", - -value=>[$folder->{parentId}], - -label=>WebGUI::International::get(769), - -options=>WebGUI::SQL->buildHashRef("select collateralFolderId,name from collateralFolder - $constraint order by name") - ); - } - $f->text( - -value=>$folder->{name}, - -name=>"name", - -label=>WebGUI::International::get(768) - ); - $f->textarea( - -value=>$folder->{description}, - -name=>"description", - -label=>WebGUI::International::get(778) - ); - $f->submit; - $output .= $f->print; - return _submenu($output); -} - -#------------------------------------------------------------------- -sub www_editCollateralFolderSave { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(4)); - if ($session{form}{fid} eq "new") { - $session{form}{fid} = WebGUI::Id::generate(); - WebGUI::Session::setScratch("collateralFolderId",$session{form}{fid}); - WebGUI::SQL->write("insert into collateralFolder (collateralFolderId) values (".quote($session{form}{fid}).")"); - } - my $folderId = $session{scratch}{collateralFolderId} || 0; - $session{form}{name} = "untitled" if ($session{form}{name} eq ""); - while (my ($test) = WebGUI::SQL->quickArray("select name from collateralFolder - where name=".quote($session{form}{name})." and collateralFolderId<>".quote($folderId))) { - if ($session{form}{name} =~ /(.*)(\d+$)/) { - $session{form}{name} = $1.($2+1); - } elsif ($test ne "") { - $session{form}{name} .= "2"; - } - } - WebGUI::SQL->write("update collateralFolder set parentId=".quote($session{form}{parentId}).", name=".quote($session{form}{name}) - .", description=".quote($session{form}{description}) - ." where collateralFolderId=".quote($folderId)); - return www_listCollateral(); -} - -#------------------------------------------------------------------- -sub www_listCollateral { - return WebGUI::Privilege::insufficient unless (WebGUI::Grouping::isInGroup(4)); - my (%type, %user, $f, $row, $data, $sth, $url, $output, $parent, $p, $thumbnail, $file, $page, $constraints, $folderId); - tie %type, 'Tie::IxHash'; - tie %user, 'Tie::IxHash'; - %type = ( - '-delete-'=>WebGUI::International::get(782), - image=>WebGUI::International::get(779), - file=>WebGUI::International::get(780), - snippet=>WebGUI::International::get(781) - ); - %user = ( - '-delete-'=>WebGUI::International::get(782), - %{WebGUI::SQL->buildHashRef("select distinct(userId), username from collateral order by username")} - ); - WebGUI::Session::setScratch("keyword",$session{form}{keyword}); - WebGUI::Session::setScratch("collateralUser",$session{form}{collateralUser}); - WebGUI::Session::setScratch("collateralType",$session{form}{collateralType}); - WebGUI::Session::setScratch("collateralPageNumber",$session{form}{pn}); - WebGUI::Session::setScratch("collateralFolderId",$session{form}{fid}); - $folderId = $session{scratch}{collateralFolderId} || 0; - $constraints = "collateralFolderId=".quote($folderId); - $constraints .= " and userId=".quote($session{scratch}{collateralUser}) if ($session{scratch}{collateralUser}); - $constraints .= " and collateralType=".quote($session{scratch}{collateralType}) if ($session{scratch}{collateralType}); - $constraints .= " and name like ".quote('%'.$session{scratch}{keyword}.'%') if ($session{scratch}{keyword}); - $p = WebGUI::Paginator->new(WebGUI::URL::page('op=listCollateral'),"",$session{scratch}{collateralPageNumber}); - $p->setDataByQuery("select collateralId, name, filename, collateralType, dateUploaded, username, parameters - from collateral where $constraints order by name"); - $page = $p->getPageData; - $output = helpIcon("collateral manage"); - $output .= '

'.WebGUI::International::get(757).'

'; - $f = WebGUI::HTMLForm->new(1); - $f->hidden("op","listCollateral"); - $f->hidden("pn",1); - $f->text( - -name=>"keyword", - -value=>$session{scratch}{keyword}, - -size=>15 - ); - $f->selectList( - -name=>"collateralUser", - -value=>[$session{scratch}{collateralUser}], - -options=>\%user - ); - $f->selectList( - -name=>"collateralType", - -value=>[$session{scratch}{collateralType}], - -options=>\%type - ); - $f->submit(WebGUI::International::get(170)); - $output .= '
'.$f->print.'
'; - $output .= ''; - $output .= ''; - if ($folderId) { - ($parent) = WebGUI::SQL->quickArray("select parentId from collateralFolder where collateralFolderId=".quote($folderId)); - $output .= ''; - } - $sth = WebGUI::SQL->read("select collateralFolderId, name, description from collateralFolder - where parentId=".quote($folderId)." order by name"); - while ($data = $sth->hashRef) { - $output .= ''; - } - $sth->finish; - foreach $row (@$page) { - $url = WebGUI::URL::page('op=editCollateral&cid='.$row->{collateralId}.'&fid='.$folderId); - $output .= ''; - $output .= ''; - $output .= ''; - $output .= ''; - $output .= ''; - if ($row->{filename} ne "" && $row->{collateralType} eq "image") { - $file = WebGUI::Attachment->new($row->{filename},"images",$row->{collateralId}); - $thumbnail = ''; - } elsif ($row->{filename} ne "" && $row->{collateralType} eq "file") { - $file = WebGUI::Attachment->new($row->{filename},"images",$row->{collateralId}); - $thumbnail = ''; - } elsif ($row->{collateralType} eq "snippet") { - $thumbnail = WebGUI::HTML::filter($row->{parameters},'all'); - $thumbnail =~ s/(\n[^\n]\r?|\r[^\r]\n?)/\↵/gs; - $thumbnail =~ s/\s{2,}//g; - $thumbnail =~ s/\s*\↵+\s*/\↵/g; - $thumbnail =~ s/^(\↵)+//; - my $crCount = $thumbnail =~ m/\↵/g; - $thumbnail = substr($thumbnail,0,$session{setting}{snippetsPreviewLength}+$crCount*6); - $thumbnail .= '...' if (length($row->{parameters}) > $session{setting}{snippetsPreviewLength}); - } else { - $thumbnail = ""; - } - $output .= ''; - $output .= "\n"; - } - $output .= '
'.WebGUI::International::get(768).'' - .WebGUI::International::get(783).''.WebGUI::International::get(387) - .''.WebGUI::International::get(388).'' - .WebGUI::International::get(784).'
' - .' '.WebGUI::International::get(542).'
' - .' '.$data->{name}.''.$data->{description}.'
'.$row->{name}.''.$type{$row->{collateralType}}.''.$row->{username}.''.epochToHuman($row->{dateUploaded},"%z").''.$thumbnail.'
'; - $output .= $p->getBarTraditional; - return _submenu($output); -} - -#------------------------------------------------------------------- -sub _htmlAreaCreateTree { - my ($output); - my ($name, $description, $url, $image, $indent, $target, $delete) = @_; - if($delete) { - $delete = qq//; - $delete .= deleteIcon().""; - } - $target = ' target="'.$target.'" ' if ($target); - $output .= ''; - $output .= ('') x$indent; - $output .= ''.$name.''; - $output .= ''.$name.''; - $output .= ''.$delete.''; - return $output; -} - -#------------------------------------------------------------------- -sub www_htmlArealistCollateral { - my (@parents, $sth, $data, $indent); - $session{page}{makePrintable}=1; $session{page}{printableStyleId}=10; - return "Only Content Managers are allowed to use WebGUI Collateral" unless (WebGUI::Grouping::isInGroup(4)); - - my $output = ''; - my $folderId = $session{form}{fid} || 0; - my $parent = $folderId; - # push parent folders in array so it can be reversed - unshift(@parents, $parent); - until($parent eq '0') { - ($parent) = WebGUI::SQL->quickArray("select parentId from collateralFolder where collateralFolderId=".quote($parent)); - unshift(@parents, $parent); - } - # Build tree for opened parent folders - foreach $parent (@parents) { - my ($name, $description) = WebGUI::SQL->quickArray("select name, description from - collateralFolder where collateralFolderId=".quote($parent)); - my ($itemsInFolder) = WebGUI::SQL->quickArray("select count(*) from collateral where collateralFolderId = ".quote($parent)); - my ($foldersInFolder)=WebGUI::SQL->quickArray("select count(*) from collateralFolder where parentId=".quote($parent)); - my $delete = "fid=$parent" unless ($itemsInFolder + $foldersInFolder); - $output .= _htmlAreaCreateTree($name, $description, - WebGUI::URL::page('op=htmlArealistCollateral&fid='.$parent), "opened.gif", - $indent++,"" ,$delete); - } - # Extend tree with closed folders in current folder - $sth = WebGUI::SQL->read("select collateralFolderId, name, description from collateralFolder - where parentId=".quote($folderId)." and collateralFolderId <> '0' order by name"); - while ($data = $sth->hashRef) { - my ($itemsInFolder) = WebGUI::SQL->quickArray("select count(*) from collateral where - collateralFolderId = ".quote($data->{collateralFolderId})); - my $delete = 'fid='.$data->{collateralFolderId} unless $itemsInFolder; - $output .= _htmlAreaCreateTree($data->{name}, $data->{description}, - WebGUI::URL::page('op=htmlArealistCollateral&fid='.$data->{collateralFolderId}), - "closed.gif", $indent, "", $delete); - } - # Extend tree with images in current folder - $sth = WebGUI::SQL->read("select collateralId, name, filename from collateral where collateralType = 'image' ". - "and collateralFolderId = ".quote($folderId)); - while ($data = $sth->hashRef) { - $data->{filename} =~ /\.([^\.]+)$/; # Get extension - my $fileType = $1.'.gif'; - $output .= _htmlAreaCreateTree($data->{filename}, $data->{name}, - WebGUI::URL::page('op=htmlAreaviewCollateral&cid='.$data->{collateralId}), - $fileType, $indent, "viewer", 'cid='.$data->{collateralId}.'&fid='.$folderId); - } - $output .= '
'; - $output .= '\n"; - $sth->finish; - return $output; -} - -#------------------------------------------------------------------- -sub www_htmlAreaviewCollateral { - my($output, $collateral, $file, $x, $y, $image, $error); - $session{page}{makePrintable}=1; $session{page}{printableStyleId}=10; - $output .= ''; - if($session{form}{cid} eq "" || ! WebGUI::Grouping::isInGroup(4)) { - $output .= '
'; - $output .= '


'; - $output .= '

WebGUI Image Manager
for TinyMCE

'; - $output .= '
'; - } else { - my $c = WebGUI::Collateral->new($session{form}{cid}); - $collateral = $c->get; - $file = WebGUI::Attachment->new($collateral->{filename},"images",$collateral->{collateralId}); - $output .= ''; - $output .= ''.$file->getFilename.'
'; - if ($hasImageMagick) { - $image = Image::Magick->new; - $error = $image->Read($file->getPath); - ($x, $y) = $image->Get('width','height'); - $output .= $error ? "Error reading image: $error" : "($x × $y)"; - } - $output .= ''; - $output .= ''; - $output .= ''; - $output .= '\n"; - } - return $output; -} - -#------------------------------------------------------------------- -sub www_htmlAreaUpload { - $session{page}{makePrintable}=1; $session{page}{printableStyleId}=10; - return "Only Content Managers are allowed to use WebGUI Collateral" unless (WebGUI::Grouping::isInGroup(4)); - return www_htmlArealistCollateral() if ($session{form}{image} eq ""); - my($test, $file); - $session{form}{fid} = $session{form}{collateralFolderId} = $session{form}{path}; - my $collateral = WebGUI::Collateral->new("new"); - $session{form}{thumbnailSize} ||= $session{setting}{thumbnailSize}; - $session{form}{cid} = $collateral->get("collateralId"); - $collateral->save("image", $session{form}{thumbnailSize}); - $session{form}{name} = "untitled" if ($session{form}{name} eq ""); - while (($test) = WebGUI::SQL->quickArray("select name from collateral - where name=".quote($session{form}{name})." and collateralId<>".quote($collateral->get("collateralId")))) { - if ($session{form}{name} =~ /(.*)(\d+$)/) { - $session{form}{name} = $1.($2+1); - } elsif ($test ne "") { - $session{form}{name} .= "2"; - } - } - $collateral->set($session{form}); - $session{form}{collateralType} = ""; - return www_htmlArealistCollateral(); -} - -#------------------------------------------------------------------- -sub www_htmlAreaDelete { - $session{page}{makePrintable}=1; $session{page}{printableStyleId}=10; - return "Only Content Managers are allowed to use WebGUI Collateral" unless (WebGUI::Grouping::isInGroup(4)); - if($session{form}{cid}) { # Delete Image - my $collateral = WebGUI::Collateral->new($session{form}{cid}); - $collateral->delete; - } elsif($session{form}{fid} and not($session{form}{cid})) { - return WebGUI::Privilege::vitalComponent() unless ($session{form}{fid} > 999); - my ($parent) = WebGUI::SQL->quickArray("select parentId from collateralFolder where collateralFolderId=".quote($session{form}{fid})); - WebGUI::SQL->write("delete from collateralFolder where collateralFolderId=".quote($session{form}{fid})); - $session{form}{fid}=$parent; - } - return www_htmlArealistCollateral(); -} - -#------------------------------------------------------------------- -sub www_htmlAreaCreateFolder { - $session{page}{makePrintable}=1; $session{page}{printableStyleId}=10; - return "Only Content Managers are allowed to use WebGUI Collateral" unless (WebGUI::Grouping::isInGroup(4)); - $session{form}{fid} = WebGUI::Id::generate(); - WebGUI::Session::setScratch("collateralFolderId",$session{form}{fid}); - WebGUI::SQL->write("insert into collateralFolder (collateralFolderId) values (".quote($session{form}{fid}).")"); - my $folderId = $session{scratch}{collateralFolderId} || 0; - $session{form}{name} = $session{form}{folder}; - $session{form}{name} = "untitled" if ($session{form}{name} eq ""); - while (my ($test) = WebGUI::SQL->quickArray("select name from collateralFolder - where name=".quote($session{form}{name})." and collateralFolderId<>".quote($folderId))) { - if ($session{form}{name} =~ /(.*)(\d+$)/) { - $session{form}{name} = $1.($2+1); - } elsif ($test ne "") { - $session{form}{name} .= "2"; - } - } - WebGUI::SQL->write("update collateralFolder set parentId=".quote($session{form}{path}).", name=".quote($session{form}{name}) - .", description=".quote($session{form}{description})." where collateralFolderId=".quote($folderId)); - $session{form}{fid} = $session{form}{path}; - return www_htmlArealistCollateral(); -} - - -1; diff --git a/lib/WebGUI/Operation/Root.pm b/lib/WebGUI/Operation/Root.pm deleted file mode 100644 index 65140121b..000000000 --- a/lib/WebGUI/Operation/Root.pm +++ /dev/null @@ -1,61 +0,0 @@ -package WebGUI::Operation::Root; - -#------------------------------------------------------------------- -# WebGUI is Copyright 2001-2004 Plain Black Corporation. -#------------------------------------------------------------------- -# Please read the legal notices (docs/legal.txt) and the license -# (docs/license.txt) that came with this distribution before using -# this software. -#------------------------------------------------------------------- -# http://www.plainblack.com info@plainblack.com -#------------------------------------------------------------------- - -use strict; -use Tie::CPHash; -use WebGUI::Grouping; -use WebGUI::Icon; -use WebGUI::International; -use WebGUI::Operation::Shared; -use WebGUI::Paginator; -use WebGUI::Privilege; -use WebGUI::Session; -use WebGUI::SQL; -use WebGUI::URL; - -#------------------------------------------------------------------- -sub _submenu { - my (%menu); - tie %menu, 'Tie::IxHash'; - $menu{WebGUI::URL::page('op=editPage&npp=0')} = WebGUI::International::get(409); - return menuWrapper($_[0],\%menu); -} - -#------------------------------------------------------------------- -sub www_listRoots { - return WebGUI::Privilege::adminOnly() unless(WebGUI::Grouping::isInGroup(3)); - my ($output, $p, $sth, %data, @row, $i); - $output = helpIcon("root manage"); - $output .= '

'.WebGUI::International::get(408).'

'; - $sth = WebGUI::SQL->read("select * from page where title<>'Reserved' and parentId='0' order by title"); - while (%data = $sth->hash) { - $row[$i] = '' - .deleteIcon('op=deletePageConfirm',$data{urlizedTitle},WebGUI::International::get(101)) - .editIcon('op=editPage',$data{urlizedTitle}) - .cutIcon('op=cutPage',$data{urlizedTitle}) - .''; - $row[$i] .= ''.$data{title}.''; - $row[$i] .= ''.$data{urlizedTitle}.''; - $i++; - } - $sth->finish; - $p = WebGUI::Paginator->new(WebGUI::URL::page('op=listRoots')); - $p->setDataByArrayRef(\@row); - $output .= ''; - $output .= $p->getPage; - $output .= '
'; - $output .= $p->getBarTraditional; - return _submenu($output); -} - - -1; diff --git a/lib/WebGUI/Operation/Settings.pm b/lib/WebGUI/Operation/Settings.pm index c811ad72e..6da620016 100644 --- a/lib/WebGUI/Operation/Settings.pm +++ b/lib/WebGUI/Operation/Settings.pm @@ -115,11 +115,6 @@ sub www_editSettings { -label=>$i18n->get(946), -value=>$session{setting}{sharedTrash} ); - $tabform->getTab("ui")->integer( - -name=>"snippetsPreviewLength", - -label=>$i18n->get(888), - -value=>$session{setting}{snippetsPreviewLength} - ); $tabform->getTab("ui")->integer( -name=>"textAreaRows", -label=>$i18n->get(463), diff --git a/lib/WebGUI/Persistent.pm b/lib/WebGUI/Persistent.pm deleted file mode 100644 index 8ee8350bd..000000000 --- a/lib/WebGUI/Persistent.pm +++ /dev/null @@ -1,481 +0,0 @@ -package WebGUI::Persistent; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - -use strict; -use warnings; -use WebGUI::SQL; -use WebGUI::Persistent::Query::Select; -use WebGUI::Persistent::Query::Delete; -use WebGUI::Persistent::Query::Update; -use WebGUI::Persistent::Query::Insert; -use WebGUI::ErrorHandler; - -our %classData = (); - -=head1 NAME - -Package WebGUI::Persistent - -=head1 DESCRIPTION - -An abstract base class for objects stored in the database. - -This class provides simple get() and set() methods that interact with the -database. - -=head1 SYNOPSIS - - package MyClass; - - use WebGUI::Persistent; - our @ISA = qw(WebGUI::Persistent); - - sub classSettings { - { - properties => { - A => { key => 1 }, - B => { defaultValue => 5}, - C => { quote => 1 , defaultValue => "hello world"}, - D => { }, - }, - table => 'myTable' - } - } - - 1; - - . - . - . - - use MyClass; - - # create a new instance - my $obj = MyClass->new( -properties => {B => 3} ); - - # commit it to the database - $obj->set(); - - # find out what id it has - my $id = $obj->get('A'); - -This would leave a row in the table: - - +---+---+-------------+------+ - | A | B | C | D | - +---+---+-------------+------+ - | 1 | 3 | hello world | NULL | - +---+---+-------------+------+ - -Rows can be retrieved from the database individually: - - my $sameObj = MyClass->new(A => $id); - -Or multiple rows can be fetched: - - my @objs = MyClass->multiNew(-where => ["A > 5"], B => 3); - -Rows can also be deleted from the database individually or many at once. - -=head1 METHODS - -These methods are available from this class: - -=cut - -#------------------------------------------------------------------- - -# Provides access to various stored classData. -sub classData { - my ($self) = @_; - my $class = ref($self) || $self; - return $classData{$class} ||= {}; -} - -#------------------------------------------------------------------- - -=head2 classSettings - -This class method must be overridden to return a hash reference with one or -more of the following keys. - - sub classSettings { - { - properties => { - A => { key => 1 }, - B => { defaultValue => 5}, - C => { quote => 1 , defaultValue => "hello world"}, - D => { }, - }, - table => 'myTable' - } - } - -=head3 properties - -This should be a hash reference keyed by the field names of the table that -this class refers to (and should be able to be manipulated with this classes -get() and set() methods). The values of the hash reference should be hash -references containing settings for each field. - -=head3 * defaultValue - -The default value for this field (optional). - -=head3 * key - -Should be true for the primary key column (one field must be set in this way). - -=head3 * quote - -Should be true for fields that need to be quoted in database queries. - -=head3 table - -This must be set to the name of the table that this class represents. - -=cut - -sub classSettings { - WebGUI::ErrorHandler::fatalError("classSettings() must be overridden"); -} - -#------------------------------------------------------------------- - -=head2 delete - -An instance method to delete the currently instantiated row. - -=cut - -sub delete { - my ($self) = @_; - my $delete = WebGUI::Persistent::Query::Delete->new( - table => $self->table(), - where => { $self->keyColumn() => $self->get($self->keyColumn()) } - ); - WebGUI::SQL->write($delete->buildQuery()); -} - -#------------------------------------------------------------------- - -=head2 get( $propertyName ) - -Returns the value of a field. - -=cut - -sub get { - my ($self,$propertyName) = @_; - if ($propertyName) { - if (exists($self->{_property}{$propertyName})) { - return $self->{_property}{$propertyName}; - } elsif ($self->properties->{$propertyName}) { - WebGUI::ErrorHandler::warn( - ref($self)." $propertyName not retrieved from database" - ); - } - } - return $self->{_property}; -} - -#------------------------------------------------------------------- - -=head2 keyColumn - -Returns the name of the column that is the primary key for this table. - -See classSettings() for details on how to set this value. - -=cut - -sub keyColumn { - my ($class) = @_; - unless ($class->classData->{keyColumn}) { - my $properties = $class->properties(); - foreach my $key (keys %$properties) { - next unless $properties->{$key}{key}; - $class->classData->{keyColumn} = $key; - } - } - return $class->classData->{keyColumn}; -} - -#------------------------------------------------------------------- - -sub _mergeWhere { - my ($class,$where,$p) = @_; - $where ||= []; - if (%$p) { - push @$where,$p if ref($where) eq 'ARRAY'; - $where = [$where,$p] if ref($where) eq 'HASH'; - } - return $where; -} - -#------------------------------------------------------------------- - -=head2 minimumFields - -Returns an array reference to the minimum subset of fields that maybe -selected from the database. This list defaults to the keyColum(). - -=cut - -sub minimumFields { - my ($class) = @_; - unless ($class->classData->{minimumFields}) { - $class->classData->{minimumFields} = [$class->keyColumn()] - } - return $class->classData->{minimumFields}; -} - -#------------------------------------------------------------------- - -=head2 multiDelete( -where => @whereClauses, %p ) - -=head3 -where - -See multiNew(). - -=cut - -sub multiDelete { - my $class = shift; - my ($where,%p) = $class->_pluck([qw(-where)],@_); - - my $delete = WebGUI::Persistent::Query::Delete->new( - table => $class->table(), - properties => $class->properties(), - where => $class->_mergeWhere($where,\%p) - ); - my $query = $delete->buildQuery(); - WebGUI::SQL->write($query); -} - -#------------------------------------------------------------------- - -=head2 multiNew( %p ) - -Returns a list of objects matching the query arguments. - -Unrecognised parameters are combined to form the where clause: - - MyClass->multiNew(A => [1,2], B => 3); - -Additional, more complicated parameters maybe passed using the -where option. - -=head3 -where - -If provided -where must be an array reference, which is evaluated to generate -an Sql where clause using the properties in classSettings. Any left over named -parameters to this method are built into the where clause. - -For a class with settings as defined in the sysnopsis above the following -argument to -where would be evaluated as: - - -where => [{A => [1,2]},[{B => 3,C => 'hello'}],"D = (B * 3)"] - -Evaluates to: - - A in (1,2) AND (B = 3 OR C = 'hello') AND D = (B * 3) - -=head3 -fields - -This maybe an array reference of fields to be selected from the database, -otherwise, all fields in properties are selected unless the -minimumFields -option is true. - -=head3 -minimumFields - -If true the minimum fields are selected from the database. - -=cut - -sub multiNew { - my $class = shift; - my ($where,$fields,$minimumFields,%p) - = $class->_pluck([qw(-where -fields -minimumFields)],@_); - $minimumFields = $class->minimumFields if $minimumFields; - my (@objs); - - my $select = WebGUI::Persistent::Query::Select->new( - table => $class->table(), - properties => $class->properties(), - where => $class->_mergeWhere($where,\%p), - fields => $minimumFields ? $minimumFields : $fields - ); - my $query = $select->buildQuery(); - my $sth = WebGUI::SQL->read($query); - while (my $hash = $sth->hashRef()) { - push @objs, $class->new(-properties => $hash); - } - - return @objs; -} - -#------------------------------------------------------------------- - -=head2 new - -=head3 -properties - -If a hash reference of property names to values is provided to this method, -then the database is not queried. This is mainly used for creating new rows -by calling set afterwards (if not specified the value of the key column is -set to 'new', so that when set() is called, and insert takes place). - -=head3 -where - -See multiNew(). - -=head3 -fields - -See multiNew(). - -=head3 -minimumFields - -See multiNew(). - -=head3 -noSet - -If true this stops the set() method from doing writing to the database. - -=cut - -sub new { - my $class = shift; - my ($properties,$where,$fields,$minimumFields,$noSet,%p) - = $class->_pluck( - [qw(-properties -where -fields -minimumFields -noSet)],@_ - ); - $minimumFields = $class->minimumFields if $minimumFields; - - if ($properties) { - my $classProperties = $class->properties(); - foreach my $propertyName (keys %$classProperties) { - next if exists $properties->{$propertyName}; - $properties->{$propertyName} - = $classProperties->{$propertyName}{defaultValue}; - } - unless (defined($properties->{$class->keyColumn()})) { - $properties->{$class->keyColumn()} = 'new'; - } - return bless {_property => $properties,_noSet => $noSet}, $class; - } else { - $where = $class->_mergeWhere($where,\%p); - my $select = WebGUI::Persistent::Query::Select->new( - table => $class->table(), - properties => $class->properties(), - where => $where, - fields => $minimumFields ? $minimumFields : $fields - ); - my $query = $select->buildQuery(); - my $hash = WebGUI::SQL->quickHashRef($query); - return undef unless defined %$hash; - return bless {_property => $hash,_noSet => $noSet}, $class; - } -} - -#------------------------------------------------------------------- - -sub _pluck { - my ($class,$p,%q) = @_; - return ((map {delete($q{$_})} @$p),%q); -} - -#------------------------------------------------------------------- - -=head2 properties - -Returns a cached hash reference containing the "properties" defined in -classSettings() - -=cut - -sub properties { - my ($class) = @_; - unless ($class->classData->{properties}) { - $class->classData->{properties} = $class->classSettings->{properties}; - } - return $class->classData->{properties} -} - -#------------------------------------------------------------------- - -=head2 set( [ \%p ] ) - -This method optionally takes a hash reference of property to value and updates -the object and database: - - $obj->set({ B => 9, D => 60 }); - -If no arguments are provided then the object's current state is written to the -database. - - $obj->set(); - -=cut - -sub set { - my ($self,$properties) = @_; - $properties ||= {}; - - foreach my $propertyName (keys %$properties) { - $self->{_property}{$propertyName} = $properties->{$propertyName}; - } - - return if $self->{_noSet}; - - if ($self->get($self->keyColumn()) ne 'new') { - my $update = WebGUI::Persistent::Query::Update->new( - table => $self->table(), - where => { $self->keyColumn => $self->get($self->keyColumn()) }, - data => $properties, - properties => $self->properties() - ); - WebGUI::SQL->write($update->buildQuery()); - } else { - $self->{_property}{$self->keyColumn()} = getNextId($self->keyColumn()); - my $insert = WebGUI::Persistent::Query::Insert->new( - table => $self->table(), - data => $self->{_property}, - properties => $self->properties() - ); - WebGUI::SQL->write($insert->buildQuery()); - } -} - -#------------------------------------------------------------------- - -=head2 table - -Returns the table name set in classSettings(). - -=cut - -sub table { - my ($class) = @_; - unless ($class->classData->{table}) { - unless ($class->classSettings->{table}) { - WebGUI::ErrorHandler::fatalError("table() must be overridden"); - } - $class->classData->{table} = $class->classSettings->{table}; - } - return $class->classData->{table} -} - -1; diff --git a/lib/WebGUI/Persistent/Query.pm b/lib/WebGUI/Persistent/Query.pm deleted file mode 100644 index ef5846f38..000000000 --- a/lib/WebGUI/Persistent/Query.pm +++ /dev/null @@ -1,234 +0,0 @@ -package WebGUI::Persistent::Query; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - - -use strict; -use warnings; -use WebGUI::SQL (); -use WebGUI::ErrorHandler; - -=head1 NAME - -Package WebGUI::Persistent::Query - -=head1 DESCRIPTION - -An abstract base class for objects that build queries, providing funtionality -for building the where clause. See WebGUI::Persistent::Query::Select for more -details. - -=head1 SYNOPSIS - - use WebGUI::Persistent::Query; - our @ISA = qw(WebGUI::Persistent::Query); - - sub buildQuery { - # build the query... - . - . - . - } - -=head1 METHODS - -#------------------------------------------------------------------- - -=head2 buildQuery - -Build the query from the properties. This method must be overridden by -subclasses - -=cut - -sub buildQuery { - WebGUI::ErrorHandler::fatalError("buildQuery() must be overridden"); -} -; - -#------------------------------------------------------------------- - -=head2 buildWhere - -Build the where clause for this query. - -=cut - -sub buildWhere { - my ($self) = @_; - my @clauses; - - if (my $where = $self->parseWhereArgs(@{$self->{_where}})) { - return "WHERE $where"; - } - - return undef; -} - -#------------------------------------------------------------------- - -=head2 buildWhereElement( $name, @values ) - -Builds an element of a where clause. - -=cut - -sub buildWhereElement { - my ($self,$name,@vals) = @_; - @vals = @{$vals[0]} if ref($vals[0]); - return undef unless @vals; - return "$name = ".$self->quote($name,@vals) if (@vals == 1); - return "$name IN (".join(',',map {$self->quote($name,$_)} @vals).")"; -} - -#------------------------------------------------------------------- - -=head2 new( %p ) - -=head3 properties - -A hashref of field name to a hash reference of property settings. - -Currently used settings are: - -=head3 * quote - -If true values for this field are automatically quoted. - -=head3 table - -The name of the table to query. - -=head3 where - -A hash reference or array reference of arguments to build a where clause from. -See parseWhereArgs for details. - -=cut - -sub new { - my ($class,%p) = @_; - $p{where} ||= []; - $p{where} = [$p{where}] unless ref($p{where}) eq 'ARRAY'; - my $self = bless { - _where => $p{where}, - _properties => $p{properties}, - _table => $p{table}, - }, $class; - return $self; -} - -#------------------------------------------------------------------- - -sub _parsePart { - my ($self,$part,$or,$no_bracket) = @_; - - return $part unless ref($part); - if (ref($part) eq 'ARRAY') { - my @parts; - foreach my $sub_part (@$part) { - $sub_part = $self->_parsePart($sub_part,!$or); - push @parts,$sub_part if $sub_part; - } - if (@parts) { - my $ret_val = join(($or ? ' OR ' : ' AND '),@parts); - return ($no_bracket ? $ret_val : "($ret_val)"); - } - } elsif (ref($part) eq 'HASH') { - my @parts; - foreach my $key (keys %$part) { - my $clause = $self->buildWhereElement($key,$part->{$key}); - push @parts,$clause if $clause; - } - return $self->_parsePart(\@parts,!$or,1); - } - return ''; -} - -#------------------------------------------------------------------- - -=head2 parseWhereArgs( @argumentList) - -Recursivley parses a list of where arguments joining them with "AND" or "OR". Arguments -may take a number of forms: - -=head3 * scalar - -("A = 1") is left unchanged. - -=head3 * array reference - -An array reference causes the joining argument to switch from 'AND' to 'OR' -(or visa-versa) for its contents: - -([ "A = 1","C = 2" ]) - -becomes: - -"(A = 1 OR C = 2)" - -=head3 * hash reference - -These are a convienent way of being able to dynamically build up complex -queries gradually. - -({ A => 1 , C => 2 }) - -becomes: - -"A = 1 AND C = 2" - -This routine is flexiable enough to be able to parse arguments of the form: - -({A => [1,2]},[{B => 3,C => 4}],{D => 5}) - -becomes: - -"A in (1,2) AND (B = 3 OR C = 4) AND D = 5" - -=cut - -sub parseWhereArgs { - my ($self,@where_arg_list) = @_; - my @where_parts; - foreach my $where_part (@where_arg_list) { - my $part = $self->_parsePart($where_part,1,0); - push @where_parts,$part if $part; - } - return $self->_parsePart(\@where_parts,0,1); -} - -#------------------------------------------------------------------- - -=head2 quote( $propertyName, $propertyVaule ) - -Returns a quoted value for inclusion in a query, by refering to the properties -supplied to new(). - -=cut - -sub quote { - my ($self,$propertyName,$propertyValue) = @_; - - return 'NULL' unless defined($propertyValue); - - if ($self->{_properties}{$propertyName}{quote}) { - return WebGUI::SQL::quote($propertyValue); - } - - return $propertyValue; -} - -1; diff --git a/lib/WebGUI/Persistent/Query/Delete.pm b/lib/WebGUI/Persistent/Query/Delete.pm deleted file mode 100644 index c52be1a2d..000000000 --- a/lib/WebGUI/Persistent/Query/Delete.pm +++ /dev/null @@ -1,87 +0,0 @@ -package WebGUI::Persistent::Query::Delete; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - -use strict; -use warnings; -use WebGUI::Persistent::Query; - -our @ISA = qw(WebGUI::Persistent::Query); - -=head1 NAME - -Package WebGUI::Persistent::Query::Delete - -=head1 DESCRIPTION - -This class allows reliable dynamic building of Sql delete queries. - -=head1 SYNOPSIS - - my $query = WebGUI::Persistent::Query::Delete->new( - table => 'myTable', - where => [A => [1,2],[{C => 'hello',B => 1}]] - ); - - $query->buildQuery(); - -Returns: - - DELETE FROM myTable - WHERE A IN (1,2) AND (C = 'hello' OR B = 1) - -=cut - -#------------------------------------------------------------------- - -=head2 buildQuery - -=cut - -sub buildQuery { - my ($self,%p) = @_; - - my $query = 'DELETE FROM '.$self->{_table}; - if (my $where = $self->buildWhere()) { - $query .= " $where"; - } - - return $query; -} - -=head2 new( %p ) - -=head3 properties - -A hashref of field name to a hash reference of property settings. - -Currently used settings are: - -=head3 * quote - -If true values for this field are automatically quoted. - -=head3 table - -The name of the table to query. - -=head3 where - -A hash reference or array reference of arguments to build a where clause from. -See parseWhereArgs for details. - -=cut - -1; diff --git a/lib/WebGUI/Persistent/Query/Insert.pm b/lib/WebGUI/Persistent/Query/Insert.pm deleted file mode 100644 index d1d0a4452..000000000 --- a/lib/WebGUI/Persistent/Query/Insert.pm +++ /dev/null @@ -1,107 +0,0 @@ -package WebGUI::Persistent::Query::Insert; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - - -use strict; -use warnings; -use WebGUI::Persistent::Query::Insert; - -our @ISA = qw(WebGUI::Persistent::Query); - -=head1 NAME - -Package WebGUI::Persistent::Query::Insert - -=head1 DESCRIPTION - -This class allows reliable dynamic building of Sql insert queries. - -=head1 SYNOPSIS - - my $query = WebGUI::Persistent::Query::Insert->new( - table => 'myTable', - data => { - A => 1, - B => 2, - C => 'hello', - D => 'world' - }, - properties => { - A => { }, - B => { }, - C => { quote => 1 }, - D => { quote => 1 }, - } - ); - - $query->buildQuery(); - -Returns: - - INSERT INTO myTable (A,B,C,D) VALUES (1,2,'hello','world'); - -=cut - -#------------------------------------------------------------------- - -sub buildFieldValues { - my ($self) = @_; - - my @fields = keys %{$self->{_data}}; - my @values = map { $self->quote($_,$self->{_data}{$_})} @fields; - - return "(".join(', ',@fields).") VALUES (".join(', ',@values).")"; -} - -#------------------------------------------------------------------- - -=head2 buildQuery - -=cut - -sub buildQuery { - my ($self) = @_; - return join(' ','INSERT INTO',$self->{_table},$self->buildFieldValues()); -} - -#------------------------------------------------------------------- - -=head2 new( %p ) - -=head3 data - -A hash reference of field name to value. - -=head3 properties - -=head3 * quote - -If true values for this field are automatically quoted. - -=head3 table - -The name of the table to query. - -=cut - -sub new { - my ($class,%p) = @_; - my $self = $class->SUPER::new(%p); - $self->{_data} = $p{data} || {}; - return $self; -} - -1; diff --git a/lib/WebGUI/Persistent/Query/Select.pm b/lib/WebGUI/Persistent/Query/Select.pm deleted file mode 100644 index d77fc0483..000000000 --- a/lib/WebGUI/Persistent/Query/Select.pm +++ /dev/null @@ -1,165 +0,0 @@ -package WebGUI::Persistent::Query::Select; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - - -use strict; -use warnings; -use WebGUI::Persistent::Query; - -=head1 NAME - -Package WebGUI::Persistent::Query::Select - -=head1 DESCRIPTION - -This class allows reliable dynamic building of Sql select queries. - -=head1 SYNOPSIS - - my $query = WebGUI::Persistent::Query::Select->new( - where => [A => [1,2],[{C => 'hello',B => 1}]], - table => 'myTable', - limit => 1, - groupBy => 'D', - properties => { - A => { }, - B => { }, - C => { quote => 1 }, - D => { quote => 1 }, - } - ); - - $query->buildQuery(); - -Returns: - - SELECT A,B,C,D - FROM myTable - WHERE A IN (1,2) AND (C = 'hello' OR B = 1) LIMIT 1 GROUP BY D - -=cut - -our @ISA = qw(WebGUI::Persistent::Query); - -#------------------------------------------------------------------- - -sub buildFrom { "FROM ".$_[0]->{_table} } - -#------------------------------------------------------------------- - -sub buildGroupBy { - my ($self) = @_; - return '' unless $self->{_groupBy} && @{$self->{_groupBy}}; - return 'GROUP BY '.join(',',@{$self->{_groupBy}}); -} - -#------------------------------------------------------------------- - -sub buildLimit { $_[0]->{_limit} ? "LIMIT ".$_[0]->{_limit} : '' } - -#------------------------------------------------------------------- - -sub buildOrderBy { - my ($self) = @_; - return '' unless $self->{_orderBy} && @{$self->{_orderBy}}; - return 'ORDER BY '.join(',',@{$self->{_orderBy}}); -} - -#------------------------------------------------------------------- - -=head2 buildQuery - -=cut - -sub buildQuery { - my ($self) = @_; - - my @clauses = ('SELECT', - $self->buildSelectFields(), - $self->buildFrom()); - - if (my $where = $self->buildWhere()) { - push @clauses,$where; - } - if (my $group_by = $self->buildGroupBy()) { - push @clauses,$group_by; - } - if (my $order_by = $self->buildOrderBy()) { - push @clauses,$order_by; - } - if (my $limit = $self->buildLimit()) { - push @clauses,$limit; - } - return join(' ',@clauses); -} - -#------------------------------------------------------------------- - -sub buildSelectFields { - my ($self) = @_; - return join(', ',@{$self->{_fields}}) if @{$self->{_fields}}; - return join(', ',keys %{$self->{_properties}}) if %{$self->{_properties}}; - return '*'; -} - -#------------------------------------------------------------------- - -=head2 new( %p ) - -=head3 fields - -An array reference of field names (optional). - -=head3 groupBy - -An array reference of fields to group results by - -=head3 limit - -A scalar limit. - -=head3 orderBy - -An array reference of fields to order results by - -=head3 properties - -=head3 * quote - -If true values for this field are automatically quoted. - -=head3 table - -The name of the table to query. - -=head3 where - -A hash reference or array reference of arguments to build a where clause from. -See WebGUI::Persistent::Query::parseWhereArgs for details. - -=cut - -sub new { - my ($class,%p) = @_; - my $self = $class->SUPER::new(%p); - $self->{_fields} = $p{fields} || []; - $self->{_limit} = $p{limit}; - $self->{_group_by} = $p{groupBy}; - $self->{_order_by} = $p{orderBy}; - return $self; -} - -1; diff --git a/lib/WebGUI/Persistent/Query/Update.pm b/lib/WebGUI/Persistent/Query/Update.pm deleted file mode 100644 index 38ac3cecb..000000000 --- a/lib/WebGUI/Persistent/Query/Update.pm +++ /dev/null @@ -1,110 +0,0 @@ -package WebGUI::Persistent::Query::Update; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - - -use strict; -use warnings; -use WebGUI::Persistent::Query; - -our @ISA = qw(WebGUI::Persistent::Query); - -=head1 NAME - -Package WebGUI::Persistent::Query::Update - -=head1 DESCRIPTION - -This class allows reliable dynamic building of Sql update queries. - -=head1 SYNOPSIS - - my $query = WebGUI::Persistent::Query::Update->new( - table => 'myTable', - where => [A => [1,2],[{C => 'hello',B => 1}]], - data => { - A => 1, - B => 2, - C => 'hello', - D => 'world' - }, - properties => { - A => { }, - B => { }, - C => { quote => 1 }, - D => { quote => 1 }, - } - ); - - $query->buildQuery(); - -Returns: - - UPDATE myTable SET A = 1, B = 2, C = 'hello' C = 'world' - WHERE A IN (1,2) AND (C = 'hello' OR B = 1) - -=cut - -=head2 buildQuery - -=cut - -sub buildQuery { - my ($self) = @_; - - my @clauses = ('UPDATE',$self->{_table},$self->buildSet()); - if (my $where = $self->buildWhere()) { - push @clauses,$where; - } - - return join(' ',@clauses); -} - -sub buildSet { - my ($self) = @_; - 'SET '.join(', ',map { - "$_ = ". $self->quote($_,$self->{_data}{$_}) - } keys %{$self->{_data}}); -} - -=head2 new( %p ) - -=head3 data - -A hash reference of field name to value. - -=head3 properties - -=head3 * quote - -If true values for this field are automatically quoted. - -=head3 table - -=head3 where - -A hash reference or array reference of arguments to build a where clause from. -See WebGUI::Persistent::Query::parseWhereArgs for details. - -=cut - -sub new { - my ($class,%p) = @_; - my $self = $class->SUPER::new(%p); - $self->{_data} = $p{data} || {}; - return $self; -} - -1; diff --git a/lib/WebGUI/Persistent/Tree.pm b/lib/WebGUI/Persistent/Tree.pm deleted file mode 100644 index e936abbfc..000000000 --- a/lib/WebGUI/Persistent/Tree.pm +++ /dev/null @@ -1,638 +0,0 @@ -package WebGUI::Persistent::Tree; - -=head1 LEGAL - - ------------------------------------------------------------------- - WebGUI is Copyright 2001-2004 Plain Black Corporation. - ------------------------------------------------------------------- - Please read the legal notices (docs/legal.txt) and the license - (docs/license.txt) that came with this distribution before using - this software. - ------------------------------------------------------------------- - http://www.plainblack.com info@plainblack.com - ------------------------------------------------------------------- - -=cut - - -use strict; -use warnings; - -use Tree::DAG_Node; -use WebGUI::Persistent; -use WebGUI::SQL (); -use WebGUI::Persistent::Query::Update; - -our @ISA = qw(WebGUI::Persistent Tree::DAG_Node); - -=head1 NAME - -Package WebGUI::Persistent - -=head1 DESCRIPTION - -An abstract base class for objects stored in the database, that represent tree -structures. - -This class inherits from both WebGUI::Persistent (to provide get() and set() -methods), and from Tree::DAG_Node (to provide tree manipulation methods). - -=head1 SYNOPSIS - - package MyTreeClass; - - use WebGUI::Persistent::Tree; - our @ISA = qw(WebGUI::Persistent::Tree); - - sub classSettings { - { - properties => { - A => { key => 1 }, - B => { defaultValue => 5}, - C => { quote => 1 , defaultValue => "hello world"}, - parentId => { defaultValue => 0 }, - sequenceNumber => { defaultValue => 1 } - }, - table => 'myTreeTable' - } - } - - 1; - - . - . - . - - use MyTreeClass; - - my $nodes = $class->getTree({-minmumFields}); - print join("\n",@{$nodes->{0}->draw_ascii_tree()}); - -=head1 METHODS - -#------------------------------------------------------------------- - -=head2 buildTree( \@objs, [ \%nodes ] ) - -Given an array reference of objects this method will attempt to build them -into a tree. - -=cut - -sub buildTree { - my ($class,$objs,$nodes) = @_; - - $nodes ||= {}; - my %parentToChild = (); - my $keyColumn = $class->keyColumn(); - foreach my $obj (grep {$_} @$objs) { - $nodes->{$obj->get($keyColumn)} = $obj; - $obj->{daughters} ||= []; - next if ($obj->get('parentId') eq $obj->get($keyColumn)); - push @{ $parentToChild{$obj->get('parentId')} }, $obj; - } - - foreach my $parentId (keys %parentToChild) { - if (my $parent = $nodes->{$parentId}) { - $parent->add_daughters($class->sortSiblings($parentToChild{$parentId})); - } - } - - return $nodes; -} - -#------------------------------------------------------------------- - -=head2 canDown - -Returns tree if this object can be moved down within the current tree. - -=cut - -sub canDown { $_[0]->right_sister } - -#------------------------------------------------------------------- - -=head2 canLeft - -Returns tree if this object can be moved left within the current tree. - -=cut - -sub canLeft { $_[0]->mother ? 1 : 0 } - -#------------------------------------------------------------------- - -=head2 canRight - -Returns tree if this object can be moved right within the current tree. - -=cut - -sub canRight { $_[0]->left_sister } - -#------------------------------------------------------------------- - -=head2 canUp - -Returns tree if this object can be moved up within the current tree. - -=cut - -sub canUp { $_[0]->left_sister } - -#------------------------------------------------------------------- - -=head2 classSettings - -This class method must be overridden to return a hash reference with one or -more of the following keys. - -=head3 useDummyRoot - -This should be set to true for classes that don't store their root node in -the database. - -=head3 properties - -This should be a hash reference keyed by the field names of the table that -this class refers to (and should be able to be manipulated with this classes -get() and set() methods). The values of the hash reference should be hash -references containing settings for each field. - -=head3 * defaultValue - -The default value for this field (optional). - -=head3 * key - -Should be true for the primary key column (one field must be set in this way). - -=head3 * quote - -Should be true for fields that need to be quoted in database queries. - -=cut - -#------------------------------------------------------------------- - -=head2 dummyRoot - -This creates a dummy root object for classes that do not store their root in -the database. - -=cut - -sub dummyRoot { - $_[0]->new( - -properties => { pageId => 0 }, - -noSet => 1 - ); -} - -#------------------------------------------------------------------- - -=head2 getTree ( [ \%p, $maxDepth, \%nodes ] ) - -This method has varying behaviour depending on the context from which it is -called. - -In instance context rows from the table will be recursivley selected using the -current object as the root, and then the tree will be built: - - $self->getTree(); - -In class context, the all rows are selected from the table, and then the tree -is built. - - $class->getTree(); - -In all cases a hashref is returned. - - { keyColumnValue => WebGUI::Persistent::Tree object } - -If defined $maxDepth maybe used to limit the depth of the recursion. - -If %p is defined, the arguments are passed directly to the new or multiNew -methods, this allows multiple trees to be easily stored in one table: - - $class->getTree({treeId => 4}); - -$nodes can be a hash reference to objects that have already been obtained from -the database. - -=cut - -sub getTree { - my ($self,$p,$maxDepth,$nodes) = @_; - my $class = ref($self) || $self; - $nodes ||= {}; - $p ||={}; - - unless (ref($self)) { - if ($class->useDummyRoot()) { - $nodes->{0} = $self = $class->dummyRoot(); - } - - if (!defined($maxDepth)) { - return $class->buildTree([$class->multiNew(%$p)],$nodes); - } elsif (!ref($self)) { - $self = $class->new(%$p,$class->keyColumn() => 0); - } - } - $nodes->{$self->get($class->keyColumn())} ||= $self; - - return $nodes if (defined($maxDepth) && --$maxDepth < 0); - - my @objs = $class->multiNew( - parentId => $self->get($class->keyColumn()),%$p - ); - if (@objs) { - $self->buildTree(\@objs,$nodes); - return $nodes if (defined($maxDepth) && !$maxDepth) ; - $_->getTree($p,$maxDepth,$nodes) foreach @objs; - } - - return $nodes; -} - -#------------------------------------------------------------------- - -=head2 grandmotherChildrenAndSelf( $keyColumnId ) - -Using the given $keyColumnId this method fetches the grandmother, children, -and the object refered to by the $keyColumnId. - -Returns a list of objects. - -=cut - -sub grandmotherChildrenAndSelf { - my ($class,$keyColumnId) = @_; - return undef unless defined($keyColumnId); - my $self = $class->new(-minimumFields=>1,$class->keyColumn() => $keyColumnId); - return undef unless $self; - return ($self,$class->motherSelfAndSisters($self->get('parentId'))); -} - -#------------------------------------------------------------------- - -=head2 minimumFields - -The minimumFields for Trees must also include the parentId, and the -sequenceNumber. - -See WebGUI::Persistent. - -=cut - -sub minimumFields { - my ($class) = @_; - unless ($class->classData->{minimumFields}) { - my $fields = $class->SUPER::minimumFields(); - push @$fields, 'parentId'; - push @$fields, 'sequenceNumber' if ($class->properties->{sequenceNumber}); - } - return $class->classData->{minimumFields}; -} - -#------------------------------------------------------------------- - -sub name { - my $self = shift; - return $self->keyColumn().':'.$self->get($self->keyColumn()); -} - -#------------------------------------------------------------------- - -# Avoid a bug in Tree::DAG_Node. -# When a new node is created and has no daughters. This sometimes causes -# problems for Tree::DAG_Node::walk_down() - -sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - $self->{daughters} ||= [] if $self; - $self->attributes({}); - return $self; -} - -#------------------------------------------------------------------- - -=head2 motherSelfAndSisters( $keyColumnId ) - -Given the $keyColumnId, this method fetches the related mother and sisters. - -Returns a list of objects. - -=cut - -sub motherSelfAndSisters { - my ($class,$keyColumnId) = @_; - return undef unless defined($keyColumnId); - my $self = $class->new(-minimumFields=>1,$class->keyColumn() => $keyColumnId); - return undef unless $self; - - my $parentId = $self->get('parentId'); - my @objs = $class->multiNew( - -minimumFields => 1, - -where => [ - [{ - parentId => $parentId, - $class->keyColumn() => $parentId, - }], - $class->keyColumn()." != $keyColumnId", - ] - ); - if ($class->useDummyRoot() && $parentId eq '0') { - push @objs, $class->dummyRoot(); - } - return ($self,@objs); -} - -#------------------------------------------------------------------- - -=head2 moveDown( [ $keyColumnId ] ) - -In class context: - - $class->moveDown($keyColumnId); - -The required parent, sister and child objects are fetched from the database, -and the tree is built and manipulated.This class' inheritance from -WebGUI::Persistent takes care of any database work. - -In instance context: - - $self->moveDown(); - -The current object is assumed to be in a pre-built tree, and so the tree is -simply manipulated. This class' inheritance from WebGUI::Persistent takes care -of any database work. - -=cut - -sub moveDown { - my ($self,$keyColumnId) = @_; - my $class = ref($self) || $self; - return unless $class->properties->{sequenceNumber}; - - unless (ref($self)) { - my $nodes = $class->buildTree([$class->motherSelfAndSisters($keyColumnId)]); - $self = $nodes->{$keyColumnId}; - } - - return unless ($self && $self->canDown()); - - my $right = $self->right_sister; - $self->swapSisters($right); -} - -#------------------------------------------------------------------- - -=head2 moveLeft( [ $keyColumnId ] ) - -In class context: - - $class->moveLeft($keyColumnId); - -The required parent, sister and child objects are fetched from the database, -and the tree is built and manipulated.This class' inheritance from -WebGUI::Persistent takes care of any database work. - -In instance context: - - $self->moveLeft(); - -The current object is assumed to be in a pre-built tree, and so the tree is -simply manipulated. This class' inheritance from WebGUI::Persistent takes care -of any database work. - -=cut - -sub moveLeft { - my ($self,$keyColumnId) = @_; - my $class = ref($self) || $self; - - unless (ref($self)) { - my $nodes = $class->buildTree([$class->grandmotherChildrenAndSelf($keyColumnId)]); - $self = $nodes->{$keyColumnId}; - } - - return unless ($self && $self->canLeft()); - - my $sister = $self->mother; - - # Close up hole left by imminent move - map { - $_->set({sequenceNumber => $_->get('sequenceNumber') - 1 }) - } $self->right_sisters(); - - $self->unlink_from_mother; - $sister->add_right_sister($self); - - my $newSequenceNumber = $sister->get('sequenceNumber') + 1; - - map { - $_->set({sequenceNumber => $_->get('sequenceNumber') + 1 }) - } $self->right_sisters(); - - $self->set({ - parentId => $sister->get('parentId'), - sequenceNumber => $newSequenceNumber - }); -} - -#------------------------------------------------------------------- - -=head2 moveRight( [ $keyColumnId ] ) - -In class context: - - $class->moveRight($keyColumnId); - -The required parent, sister and child objects are fetched from the database, -and the tree is built and manipulated.This class' inheritance from -WebGUI::Persistent takes care of any database work. - -In instance context: - - $self->moveRight(); - -The current object is assumed to be in a pre-built tree, and so the tree is -simply manipulated. This class' inheritance from WebGUI::Persistent takes care -of any database work. - -=cut - -sub moveRight { - my ($self,$keyColumnId) = @_; - my $class = ref($self) || $self; - - unless (ref($self)) { - my @objs = $class->motherSelfAndSisters($keyColumnId); - my $nodes = $class->buildTree(\@objs); - $self = $nodes->{$keyColumnId}; - } - - return unless ($self && $self->canRight()); - - my $keyColumn = $class->keyColumn(); - my $mother = $self->left_sister; - $mother->getTree({-minimumFields => 1},1); - - # Close up hole left by imminent move - map { - $_->set({sequenceNumber => $_->get('sequenceNumber') -1 }) - } $self->right_sisters(); - - # Add as right-most daughter of current left-sister - $self->unlink_from_mother; - $mother->add_daughter($self); - - my $newSequenceNumber = 1; - if (my $sister = $self->left_sister()) { - $newSequenceNumber = $sister->get('sequenceNumber') + 1; - } - - $self->set({ - parentId => $mother ? $mother->get($keyColumn) : 0, - sequenceNumber => $newSequenceNumber - }); -} - -#------------------------------------------------------------------- - -=head2 moveUp( [ $keyColumnId ] ) - -In class context: - - $class->moveUp($keyColumnId); - -The required parent, sister and child objects are fetched from the database, -and the tree is built and manipulated.This class' inheritance from -WebGUI::Persistent takes care of any database work. - -In instance context: - - $self->moveUp(); - -The current object is assumed to be in a pre-built tree, and so the tree is -simply manipulated. This class' inheritance from WebGUI::Persistent takes care -of any database work. - -=cut - -sub moveUp { - my ($self,$keyColumnId) = @_; - my $class = ref($self) || $self; - return unless $class->properties->{sequenceNumber}; - - unless (ref($self)) { - my $nodes = $class->buildTree([$class->motherSelfAndSisters($keyColumnId)]); - $self = $nodes->{$keyColumnId}; - } - - return unless ($self && $self->canUp()); - - my $left = $self->left_sister; - $self->swapSisters($left); -} - -#------------------------------------------------------------------- - -=head2 recursiveDelete - -Deletes this element, and all subsequent elements in the tree. The C -method must have been called to build the tree. - -=cut - -sub recursiveDelete { - my ($self) = @_; - my @ids; - $self->walk_down({callback => sub {push @ids, $_[0]->get($_[0]->keyColumn())}}); - $self->multiDelete(collateralFolderId => \@ids) if @ids; - return @ids; -} - -#------------------------------------------------------------------- - -=head2 pedigree - -=cut - -sub pedigree { - my $node = shift; - my @flexMenu = ($node->left_sisters,$node,$node->daughters,$node->right_sisters); - while(defined($node = $node->{'mother'} ) && ref($node)) { - @flexMenu = ($node->left_sisters,$node,@flexMenu,$node->right_sisters); - } - return @flexMenu; -} - -#------------------------------------------------------------------- - -=head2 self_and_ancestors - -=cut - -sub self_and_ancestors { - my $node = shift; - return ($node, $node->ancestors); -} - -#------------------------------------------------------------------- - -=head2 sortSiblings( \@siblings ) - -Sorts an array of objects according to sequenceNumber - -=cut - -sub sortSiblings { - my ($class,$siblings) = @_; - return @$siblings unless $class->properties->{sequenceNumber}; - return sort { - ($a->get('sequenceNumber') <=> $b->get('sequenceNumber')) - } @$siblings; -} - -#------------------------------------------------------------------- - -=head2 swapSisters( $sister ) - -Swaps two sisters over (they must be in a built tree), and updates their -sequenc numbers. - -=cut - -sub swapSisters { - my $self = shift; - my ($other) = @_; - my @daughters = $self->self_and_sisters; - my $a = $self ->my_daughter_index; - my $b = $other->my_daughter_index; - @daughters[$a, $b] = ($other, $self); - $self->mother->set_daughters(@daughters); - - my $tmp = $self->get('sequenceNumber'); - $self->set({sequenceNumber => $other->get('sequenceNumber')}); - $other->set({sequenceNumber => $tmp}); -} - -=head2 useDummyRoot - -Returns true if useDummyRoot is set in classSettings(). - -=cut - -sub useDummyRoot { - my ($class) = @_; - unless ($class->classData->{useDummyRoot}) { - $class->classData->{useDummyRoot} = $class->classSettings->{useDummyRoot}; - } - return $class->classData->{useDummyRoot} -} - -1; diff --git a/lib/WebGUI/i18n/English/WebGUI.pm b/lib/WebGUI/i18n/English/WebGUI.pm index b0a78b4d6..b3c9cbc70 100644 --- a/lib/WebGUI/i18n/English/WebGUI.pm +++ b/lib/WebGUI/i18n/English/WebGUI.pm @@ -81,11 +81,6 @@ our $I18N = { lastUpdated => 1031514049 }, - '767' => { - message => q|Collateral Id|, - lastUpdated => 1036892929 - }, - '798' => { message => q|Page Title|, lastUpdated => 1036978688 @@ -485,11 +480,6 @@ The URL of the web site for this theme's designer. If you are in the business of lastUpdated => 1056151382 }, - '833' => { - message => q|File, Add/Edit|, - lastUpdated => 1038871497 - }, - '139' => { message => q|No|, lastUpdated => 1031514049 @@ -545,11 +535,6 @@ The URL of the web site for this theme's designer. If you are in the business of lastUpdated => 1050430737 }, - '758' => { - message => q|Add a folder.|, - lastUpdated => 1036892705 - }, - '783' => { message => q|Type|, lastUpdated => 1036954378 @@ -590,29 +575,6 @@ The URL of the web site for this theme's designer. If you are in the business of lastUpdated => 1031514049 }, - '834' => { - message => q|You can upload any kind of file to the repository to be used later. -

- -Name
-Give this file a unique name that you can use to retrieve it later. -

- -Organize in Folder
-Which collateral folder should hold this file? -

- -File
-Select a file from your hard drive to upload. -

|, - lastUpdated => 1038871497 - }, - - '772' => { - message => q|Edit File|, - lastUpdated => 1036893140 - }, - '993' => { message => q|DSN|, lastUpdated => 1056151382 @@ -636,11 +598,6 @@ Select a file from your hard drive to upload. lastUpdated => 1031514049 }, - '388' => { - message => q|Upload Date|, - lastUpdated => 1031514049 - }, - '364' => { message => q|Search|, lastUpdated => 1031514049 @@ -1105,11 +1062,6 @@ The description of this forum as passed by the calling object. lastUpdated => 1035246389 }, - '778' => { - message => q|Folder Description|, - lastUpdated => 1036906132 - }, - '685' => { message => q|Template, Delete|, lastUpdated => 1038791020 @@ -1276,11 +1228,6 @@ How should this user be notified when they get a new WebGUI message? lastUpdated => 1060433963 }, - '835' => { - message => q|Snippet, Add/Edit|, - lastUpdated => 1038871744 - }, - '430' => { message => q|Last Page View|, lastUpdated => 1031514049 @@ -1426,16 +1373,6 @@ How should this user be notified when they get a new WebGUI message? lastUpdated => 1044705162 }, - '765' => { - message => q|Delete this collateral item.|, - lastUpdated => 1036892866 - }, - - '784' => { - message => q|Thumbnail|, - lastUpdated => 1036954393 - }, - '312' => { message => q|Allow business information?|, lastUpdated => 1031514049 @@ -1483,11 +1420,6 @@ As with any delete operation, you are prompted to be sure you wish to proceed wi lastUpdated => 1031514049 }, - '762' => { - message => q|Add a file.|, - lastUpdated => 1036892774 - }, - '638' => { message => q|Templates are used to affect how content is laid out in WebGUI. There are many templates that come with WebGUI, and using the template management system, you can add your own templates to the system to ensure that your site looks exactly how you want it to look. |, @@ -1579,11 +1511,6 @@ As with any delete operation, you are prompted to be sure you wish to proceed wi lastUpdated => 1031514049 }, - '773' => { - message => q|File|, - lastUpdated => 1036893165 - }, - '813' => { message => q|Groups In This Group|, lastUpdated => 1037583186 @@ -1599,11 +1526,6 @@ As with any delete operation, you are prompted to be sure you wish to proceed wi lastUpdated => 1031514049 }, - '759' => { - message => q|Edit this folder.|, - lastUpdated => 1036892731 - }, - '851' => { message => q|Edit this template.|, lastUpdated => 1039926394 @@ -1674,16 +1596,6 @@ As with any delete operation, you are prompted to be sure you wish to proceed wi lastUpdated => 1066034603 }, - '916' => { - message => q|Snippet|, - lastUpdated => 1050232301 - }, - - '386' => { - message => q|Edit Image|, - lastUpdated => 1031514049 - }, - '796' => { message => q|View page statistics.|, lastUpdated => 1036978043 @@ -1898,11 +1810,6 @@ The user id of the currently logged in user. lastUpdated => 1031514049 }, - '775' => { - message => q|Are you certain you wish to delete this folder and move its contents to it's parent folder?|, - lastUpdated => 1036903002 - }, - '582' => { message => q|Leave Blank|, lastUpdated => 1031514049 @@ -1938,11 +1845,6 @@ The user id of the currently logged in user. lastUpdated => 1031514049 }, - '888' => { - message => q|Snippet Preview Length|, - lastUpdated => 1045312362 - }, - '1011' => { message => q|Code|, lastUpdated => 1060433339 @@ -1984,9 +1886,9 @@ The user id of the currently logged in user. }, '932' => { - message => q|Themes are a mechanism to quickly install new styles, templates, and collateral into a WebGUI site. They are also great for moving those same items from one site to another. + message => q|Themes are a mechanism to quickly install new styles, templates, and assets into a WebGUI site. They are also great for moving those same items from one site to another.

-TIP: When building a theme, be sure to name the components (styles, templates collateral) in the theme with some name that is unique to the theme. This is useful so that your users can find the components in your theme, as well as to avoid name conflicts.|, +TIP: When building a theme, be sure to name the components (styles, templates, assets) in the theme with some name that is unique to the theme. This is useful so that your users can find the components in your theme, as well as to avoid name conflicts.|, lastUpdated => 1070027889 }, @@ -1995,21 +1897,11 @@ The user id of the currently logged in user. lastUpdated => 1031514049 }, - '764' => { - message => q|Edit this collateral item.|, - lastUpdated => 1036892856 - }, - '349' => { message => q|Latest version available|, lastUpdated => 1031514049 }, - '769' => { - message => q|Organize in Folder|, - lastUpdated => 1036893015 - }, - '983' => { message => q|Edit this database link.|, lastUpdated => 1056151382 @@ -2317,11 +2209,6 @@ A message stating that the user is receiving the message because they subscribed context => q|Title of the login history viewer for the admin console.| }, - '542' => { - message => q|Previous..|, - lastUpdated => 1031514049 - }, - '369' => { message => q|Expire Date|, lastUpdated => 1031514049 @@ -2788,11 +2675,6 @@ The Groups page displays all groups that you are allowed to edit. The form on t lastUpdated => 1031514049 }, - '766' => { - message => q|Back to collateral list.|, - lastUpdated => 1036892898 - }, - '1077' => { message => q|The function you are attempting to call is not available for this authentication module|, lastUpdated => 1067951805 @@ -2860,11 +2742,6 @@ One package that many people create is a Page/Article package. It is often the c lastUpdated => 1052850265 }, - '979' => { - message => q|Are you certain you wish to delete all items in this folder? They cannot be recovered once deleted. Items in sub-folders will not be removed.|, - lastUpdated => 1055908341 - }, - '1005' => { message => q|SQL Query|, lastUpdated => 1057208065 @@ -2915,11 +2792,6 @@ One package that many people create is a Page/Article package. It is often the c lastUpdated => 1031514049 }, - '387' => { - message => q|Uploaded By|, - lastUpdated => 1031514049 - }, - '245' => { message => q|Date|, lastUpdated => 1031514049 @@ -3067,21 +2939,11 @@ Loops come with special condition variables of their own. They are __FIRST__, __ lastUpdated => 1066580782 }, - '757' => { - message => q|Manage Collateral|, - lastUpdated => 1036892669 - }, - '951' => { message => q|Are you certain that you wish to empty the clipboard to the trash?|, lastUpdated => 1052850265 }, - '782' => { - message => q|Any|, - lastUpdated => 1036913053 - }, - '85' => { message => q|Description|, lastUpdated => 1031514049 @@ -3113,105 +2975,6 @@ Loops come with special condition variables of their own. They are __FIRST__, __ lastUpdated => 1035872437 }, - '832' => { - message => q|The collateral management system has several macros for its specific purpose. -

- -^File();
-^File(collateralFileName);
-^File(collateralFileName,templateName);
-This macro builds a quick link to a file in the Collateral Manager. It creates an icon for the file and outputs the files' name. Then it links them both to the file for downloading. The following variables are available for use in the template: -

-file.url
-The URL to the file. -

-file.icon
-The file's icon. -

-file.name
-The name of the file. -

-file.size
-The size of the file. -

-file.thumbnail
-The file's thumbnail. -

- -An optional second parameter, a template name, allows a custom template -from the Macro/File template namespace to be used instead of the default. -If a template with that name is not found, then the default is used.
-

- -^I();
-This macro retrieves an image from the collateral management system along with an HTML image tag so that you can quickly display an image from the repository in your content. -

-Example: ^I("logo"); -

- -^i();
-This macro retrieves the URL for any file in the collateral management system. -

-Example: ^i("status report"); -

- - -^RandomImage();
-This macro takes the name of a collateral folder as a parameter. If the folder name is omitted, then the root folder will be used. The macro then randomly chooses an image in the folder and returns it in much the same way the ^I(); macro works. -

-Example: ^RandomImage("site headers"); -

- -^RandomSnippet();
-This macro takes the name of a collateral folder as a parameter. If the folder name is omitted, then the root folder will be used. The macro then randomly chooses a snippet from the folder and returns it in much the same way the ^Snippet(); macro works. -

-Example: ^RandomSnippet("quips"); -

- - -^SI();
-The Scaled Image macro allows images to be found in the collateral and scaled (on the server-side), either maintaining the original aspect ratio or an entirely new ratio of your design. -

-It takes four parameters. The first is the image name or optionally the collateral id. The second is the width. Set the width to "0" to maintain aspect ratio by height. The third is height. Set the height to "0" to maintain aspect ratio by width. The fourth parameter allows you to specify additional parameters to the image. -

-Examples:
-Retrieving an image by name (no scaling)
-^SI(myimage); -

-Retrieving an image by collateralId (no scaling)
-^SI(8ucfhA1Joswj59UFIubr1Q); -

-Scaling by width, maintaining aspect ratio
-^SI(8ucfhA1Joswj59UFIubr1Q,25); -

-Scaling by height, maintaining aspect ratio
-^SI(8ucfhA1Joswj59UFIubr1Q,0,25); -

-Playing with the aspect ratio
-^SI(8ucfhA1Joswj59UFIubr1Q,148,25); -

-Using parameters
-^SI(8ucfhA1Joswj59UFIubr1Q,0,0,'border="0"'); -

- - -^Snippet();
-^Snippet(snippet name);
-This macro retrieves the contents of a snippet in the collateral management system and inserts it into the page. You can optionally specify up to 9 additional parameters that will be replace these special characters in the snippet: ^1; ^2; ^3; ^4; ^5; ^6; ^7; ^8; ^9; -

-Example: ^Snippet("flash code"); -

- -^Thumbnail();
-^Thumbnail(image name);
-This macro retrieves the URL for the thumbnail of any image in the collateral management system. -

-Example: ^Thumbnail("logo"); -

-|, - lastUpdated => 1101886126, - }, - '736' => { message => q|7 Expert|, lastUpdated => 1033836692 @@ -3222,11 +2985,6 @@ This macro retrieves the URL for the thumbnail of any image in the collateral ma lastUpdated => 1031514049 }, - '781' => { - message => q|Snippet|, - lastUpdated => 1036912954 - }, - '828' => { message => q|Most wobjects have templates that allow you to change the layout of the wobject's user interface. Those wobjects that do have templates all have a common set of template variables that you can use for layout, as well as their own custom variables. The following is a list of the common template variables shared among all wobjects.

@@ -3512,11 +3270,6 @@ The translated label for the link to the home page or the text that you supply t lastUpdated => 1031514049 }, - '409' => { - message => q|Add a new root.|, - lastUpdated => 1031514049 - }, - '642' => { message => q|Page, Add/Edit|, lastUpdated => 1078569027 @@ -3898,11 +3651,6 @@ Large sites using external group data will be making many calls to the external lastUpdated => 1053278089 }, - '776' => { - message => q|Edit Folder|, - lastUpdated => 1036905944 - }, - '894' => { message => q|Allow discussion?|, lastUpdated => 1031514049 @@ -3934,11 +3682,6 @@ Large sites using external group data will be making many calls to the external lastUpdated => 1052850265 }, - '385' => { - message => q|Parameters|, - lastUpdated => 1031514049 - }, - '502' => { message => q|Are you certain you wish to delete this template and set all pages using this template to the default template?|, lastUpdated => 1031514049 @@ -4472,11 +4215,6 @@ The description of this forum as passed by the calling object. lastUpdated => 1038889471 }, - '831' => { - message => q|Collateral Macros|, - lastUpdated => 1050441851 - }, - '552' => { message => q|Pending|, lastUpdated => 1031514049 @@ -4497,11 +4235,6 @@ The description of this forum as passed by the calling object. lastUpdated => 1044705137 }, - '780' => { - message => q|File|, - lastUpdated => 1036912946 - }, - '433' => { message => q|User Agent|, lastUpdated => 1031514049 @@ -4616,15 +4349,6 @@ div.tabs { lastUpdated => 1046067380 }, - '786' => { - message => q|WebGUI's collateral management system allows you to upload files and text to a central repository for use elsewhere in your site. -

-You can organize collateral into different folders, but names must be unique, even if they are in different folders or of different types. If you attempt to use a name that is already in use, WebGUI will rename the file for you by appending and/or incrementing a number to the end of the name. -

-|, - lastUpdated => 1099512407 - }, - '440' => { message => q|Contact Information|, lastUpdated => 1031514049 @@ -4846,11 +4570,6 @@ A list of links to the 10 nearest in the paginator relative to the current page. lastUpdated => 1031514049 }, - '774' => { - message => q|Are you certain you wish to delete this collateral? It cannot be recovered once deleted.|, - lastUpdated => 1036902945 - }, - '229' => { message => q|Subject|, lastUpdated => 1031514049 @@ -4871,11 +4590,6 @@ A list of links to the 10 nearest in the paginator relative to the current page. lastUpdated => 1031514049 }, - '770' => { - message => q|Edit Snippet|, - lastUpdated => 1036893050 - }, - '68' => { message => q|The account information you supplied is invalid. Either the account does not exist or the username/password combination was incorrect.|, lastUpdated => 1031514049 @@ -4896,28 +4610,6 @@ A list of links to the 10 nearest in the paginator relative to the current page. lastUpdated => 1031514049 }, - '838' => { - message => q|Folders are used to organize collateral, much the same way you'd use folders on your hard drive or in a file cabinet. Unlike files on your hard drive, collateral names must be unique, even if they are in different folders. -

-Organize in Folder
-Folders can be inside of other folders. In which folder would you like to put this folder? -

- -Name
-Give this folder a name so you can recognize what's in it. -

- -Description
-Describe the folder so that you remember why you created it and what it's supposed to contain. -

|, - lastUpdated => 1094406796 - }, - - '761' => { - message => q|Add an image.|, - lastUpdated => 1036892765 - }, - '576' => { message => q|Delete|, lastUpdated => 1031514049 @@ -5083,11 +4775,6 @@ The headings of columns on things like message boards and user contributions. lastUpdated => 1078243385 }, - '777' => { - message => q|Folder Id|, - lastUpdated => 1036905972 - }, - '464' => { message => q|Text Area Columns|, lastUpdated => 1031514049 @@ -5208,28 +4895,6 @@ As with any delete operation, you are prompted to be sure you wish to proceed wi lastUpdated => 1046637952 }, - '384' => { - message => q|File|, - lastUpdated => 1031514049 - }, - - '836' => { - message => q|Snippets are bits of text that may be reused on your site. Thinks like java scripts, style sheets, flash animations, or even slogans are all great snippets. Best of all, if you need to change the text, you can change it in only one location. -

-Name
-Give your snippet a unique name that you can use later to retrieve it. -

- -Organize in Folder
-Which collateral folder should contain this snippet? -

- -Snippet
-Start typing! Or better yet, copy the snippet from some other electronic document and paste it here. -

|, - lastUpdated => 1101775475, - }, - '942' => { message => q|Radio List|, lastUpdated => 1051464141 @@ -5260,11 +4925,6 @@ Start typing! Or better yet, copy the snippet from some other electronic documen lastUpdated => 1031514049 }, - '785' => { - message => q|Collateral, Manage|, - lastUpdated => 1050430118 - }, - '125' => { message => q|Company Name|, lastUpdated => 1031514049 @@ -5320,11 +4980,6 @@ Start typing! Or better yet, copy the snippet from some other electronic documen lastUpdated => 1031514049 }, - '779' => { - message => q|Image|, - lastUpdated => 1036912938 - }, - '551' => { message => q|Notice|, lastUpdated => 1031514049 @@ -5477,11 +5132,6 @@ Macros always begin with a caret (^) and follow with at least one other char lastUpdated => 1031514049 }, - '771' => { - message => q|Snippet|, - lastUpdated => 1036893079 - }, - '435' => { message => q|Session Signature|, lastUpdated => 1031514049 @@ -5532,11 +5182,6 @@ Macros always begin with a caret (^) and follow with at least one other char lastUpdated => 1031514049 }, - '760' => { - message => q|Delete this folder.|, - lastUpdated => 1036892740 - }, - '1046' => { message => q|Archived|, lastUpdated => 1066406723 @@ -5929,11 +5574,6 @@ Privileges and styles assigned to pages in the package will not be copied when t lastUpdated => 1031514049 }, - '670' => { - message => q|Image, Add/Edit|, - lastUpdated => 1038871530 - }, - '929' => { message => q|Import!|, lastUpdated => 1050265357 @@ -5970,37 +5610,6 @@ Privileges and styles assigned to pages in the package will not be copied when t context => q|Title of the user manager for the admin console.| }, - '625' => { - message => q|Upload any images that you'll possibly use in more than one location on your site. Image collateral differ from regular file collateral in that thumbnails can be displayed instead of icons and additional parameters can be added to the HTML tag when they are displayed. -

- -Name
-The label that this image will be referenced by to include it into pages. -

- -Organize In Folder
-Which collateral folder should this image be placed in. -

- -File
-Select a file from your local drive to upload to the server. -

- -Parameters
-Add any HTML <img> parameters that you wish to act as the defaults for this image. -

- -Example:
-align="right"
-alt="This is an image"
-

- -Thumbnail Size
-How big (in pixels) should the thumbnail for this image be? -

|, - lastUpdated => 1096524176 - }, - '304' => { message => q|Language|, lastUpdated => 1031514049 @@ -6056,11 +5665,6 @@ How big (in pixels) should the thumbnail for this image be? lastUpdated => 1047842270 }, - '763' => { - message => q|Add a snippet.|, - lastUpdated => 1036892785 - }, - '70' => { message => q|Error|, lastUpdated => 1031514049 @@ -6184,11 +5788,6 @@ You can move an existing forum to another Message Board. If set to 'No Change' t lastUpdated => 1101775516, }, - '793' => { - message => q|Pieces of Collateral|, - lastUpdated => 1036971785 - }, - '88' => { message => q|Users In Group|, lastUpdated => 1031514049 @@ -6474,11 +6073,6 @@ A randomly generated number. This is often used on images (such as banner ads) t lastUpdated => 1031514049 }, - '408' => { - message => q|Manage Roots|, - lastUpdated => 1031514049 - }, - '528' => { message => q|Template Name|, lastUpdated => 1031514049 @@ -6777,8 +6371,6 @@ The primary URL of your company. This will appear on all automated emails sent f

Thumbnail Size
When images are uploaded to your system, they will automatically have thumbnails generated at the size specified here (unless overridden on a case-by-case basis). Thumbnail size is measured in pixels. -

Snippet Preview Length
How many characters of a snippet should be displayed in the collateral management system main listing. - Text Area Rows, Text Area Columns and Text Box Size allow the size of forms that WebGUI generates to be customized on a site-by-site basis. diff --git a/sbin/preload.perl b/sbin/preload.perl index 7282c4301..1703a88d6 100644 --- a/sbin/preload.perl +++ b/sbin/preload.perl @@ -58,7 +58,6 @@ use Parse::PlainConfig (); use Date::Manip (); use Tie::CPHash (); use Tie::IxHash (); -use Tree::DAG_Node (); #---------------------------------------- # WebGUI modules. @@ -67,11 +66,10 @@ use Tree::DAG_Node (); # core use WebGUI (); use WebGUI::Affiliate (); -use WebGUI::Attachment (); +use WebGUI::Asset (); +use WebGUI::Asset::Wobject (); use WebGUI::Auth (); use WebGUI::Cache (); -use WebGUI::Collateral (); -use WebGUI::CollateralFolder (); use WebGUI::Config (); use WebGUI::DatabaseLink (); use WebGUI::DateTime (); @@ -91,29 +89,19 @@ use WebGUI::International (); use WebGUI::Macro (); use WebGUI::Mail (); use WebGUI::MessageLog (); -#use WebGUI::Navigation (); -use WebGUI::Node (); use WebGUI::Operation (); -use WebGUI::Persistent (); -use WebGUI::Persistent::Query (); -use WebGUI::Persistent::Tree (); -use WebGUI::Persistent::Query::Delete (); -use WebGUI::Persistent::Query::Insert (); -use WebGUI::Persistent::Query::Select (); -use WebGUI::Persistent::Query::Update (); -use WebGUI::Page (); use WebGUI::Paginator (); use WebGUI::Privilege (); use WebGUI::Search (); use WebGUI::Session (); use WebGUI::SQL (); +use WebGUI::Storage (); use WebGUI::Style (); use WebGUI::TabForm (); use WebGUI::Template (); use WebGUI::URL (); use WebGUI::User (); use WebGUI::Utility (); -use WebGUI::Wobject (); # help use WebGUI::Help::Article (); @@ -122,13 +110,11 @@ use WebGUI::Help::AuthSMB (); use WebGUI::Help::AuthWebGUI (); use WebGUI::Help::DataForm (); use WebGUI::Help::EventsCalendar (); -use WebGUI::Help::FileManager (); use WebGUI::Help::HttpProxy (); use WebGUI::Help::IndexedSearch (); use WebGUI::Help::MessageBoard (); use WebGUI::Help::Poll (); use WebGUI::Help::Product (); -use WebGUI::Help::SiteMap (); use WebGUI::Help::SQLReport (); use WebGUI::Help::Survey (); use WebGUI::Help::SyndicatedContent (); @@ -140,19 +126,17 @@ use WebGUI::Help::WSClient (); # i18n use WebGUI::i18n::English (); use WebGUI::i18n::English::Article (); -use WebGUI::i18n::English::AuthLDAP (); -use WebGUI::i18n::English::AuthSMB (); +#use WebGUI::i18n::English::AuthLDAP (); +#use WebGUI::i18n::English::AuthSMB (); use WebGUI::i18n::English::AuthWebGUI (); use WebGUI::i18n::English::DataForm (); use WebGUI::i18n::English::EventsCalendar (); -use WebGUI::i18n::English::FileManager (); use WebGUI::i18n::English::HttpProxy (); use WebGUI::i18n::English::IndexedSearch (); use WebGUI::i18n::English::MessageBoard (); use WebGUI::i18n::English::Navigation (); use WebGUI::i18n::English::Poll (); use WebGUI::i18n::English::Product (); -use WebGUI::i18n::English::SiteMap (); use WebGUI::i18n::English::SQLReport (); use WebGUI::i18n::English::Survey (); use WebGUI::i18n::English::SyndicatedContent (); @@ -164,22 +148,27 @@ use WebGUI::i18n::English::WSClient (); # you can significantly reduce your memory usage by preloading the plugins used on your sites, only the most commonly used ones are preloaded by default -# wobjects -use WebGUI::Wobject::Article (); -use WebGUI::Wobject::USS (); +# assets +use WebGUI::Asset::File (); +use WebGUI::Asset::File::Image (); +use WebGUI::Asset::Snippet (); +use WebGUI::Asset::Wobject::Article (); +use WebGUI::Asset::Wobject::Layout (); +use WebGUI::Asset::Wobject::Navigation (); +use WebGUI::Asset::Wobject::USS (); # auth methods use WebGUI::Auth::WebGUI (); -#use WebGUI::Auth::LDAP (); #use Net::LDAP (); # used by ldap authentication +use WebGUI::Auth::LDAP (); -#use WebGUI::Auth::SMB (); #use Authen::Smb (); #uncomment when using this type of authentication. +#use WebGUI::Auth::SMB (); # macros use WebGUI::Macro::AdminBar (); -#use WebGUI::Macro::Navigation (); +use WebGUI::Macro::AssetProxy ();