package GNS::Node;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use IO::Scalar;
use IO::File;
use POSIX;
use LWP::Simple;
use Safe;
use GNS::User;
use GNS::DB;
use GNS::Cache;
require Exporter;
require AutoLoader;
@ISA = qw(Exporter AutoLoader);
@EXPORT = qw( );
$VERSION = '0.1';
######################################################################
+########
## several globals we use
use vars qw( $db $error $cache);
## our list of fields
my @fields=qw( id p_id date modified expires user_id mimetype type pri
+vate
reader_ids writer_ids exclude_ids
description title body );
## the types of node's we understand so far (some are handled internal
+ly, some aren't)
## this list is not definitive. Userspace apps can use any type they w
+ant.
my @types=qw ( file text perl url link chat home );
## the account that can't do shit
## (quasi-artifact -- I use a different set of checks)
my $dead_account='nobody-x';
######################################################################
+########
## some initialization
$db=new GNS::DB || die "Couldn't access DB server: $!";
## just to make sure $cache is empty
undef $cache;
######################################################################
+########
## non class stuff
## link handeling stuff
## the default link-replacement handler.
sub default_link {
my $name=shift;
my $link=shift;
if (my $id=$db->diysval("select id from node where title like \"\Q$l
+ink\E\"")) {
return "$name($id)";
}
$name;
}
my %callbacks=(
link => \&default_link,
);
## we allow the userspace program to interpret links
sub setlinkcallback {
$callbacks{link}=shift;
}
## handles the replacement of links in a body.
sub makelinks {
my $txt=shift;
while ($txt=~/\[(.+?)\]/m) {
my $old=$1;
my $link;
my $name;
if ($old=~/(.+)\|(.+)/) {
$name=$2;
$link=$1;
}
else {
$link=$old;
$name=$link;
}
my $new;
## alright, the link might contain a special character
## at the start of the string. It could be
##
## # which means it's a node number
## < which means to inplace display the node (which could be <#382
+ or <new nodes)
##
## * which is an external URL reference (which has to be handled b
+y the userspace program)
##
## okay, some stuff is handled internally
## if the begining of the "link" is a "<" sign, it
## means to resolve the node in-place
if ($link=~/^\<(.+)/) {
my $rest=$1;
## next bit will be a name or "# number"
if ($rest=~/^\#(.+)/) {
my $id=$1;
my $node=new GNS::Node(id=>$id);
if ($node) {
local $_;
$new.=$_ while $_=$node->body;
}
else {
### hmm error
$new="($error)";
}
}
else {
## not a number, must be a search string
my @ids=search($rest);
## only inplace if there is an exact match
if ($#ids!=0) {
$new="(too many results)";
}
else {
## get that node
my $node=new GNS::Node(id => $ids[0]);
if ($node) {
local $_;
$new.=$_ while $_=$node->body;
}
else {
### hmm error
$new="($error)";
}
}
}
}
## everything else is handled by the userspace callback
else {
$new=&{$callbacks{link}}($name,$link);
}
$txt=~s/\Q[$old]\E/$new/;
}
$txt;
}
## and some generic routines
## (not used)
sub inlist {
my $id=shift;
my @list=split /[\s+,:;]/,shift;
for my $x (@list) {
return 1 if $x eq $id;
}
return;
}
## *_ids aren't numberic, they are now usernames
sub inlist2 {
my $user=shift;
my @list=split /[\s+,:;]/,shift;
for my $x (@list) {
my $u=new GNS::User(name => $x);
return 1 if $u->{id} == $user->{id};
}
return;
}
## does the passed user have read access to this node?
sub canread {
my $node=shift;
my $user=shift;
if ($node->{user_id} == $user->{id}) {
return 1;
}
## if in exclude, bye!
if (inlist2($user,$node->{exclude_ids})) {
$error="You are excluded from this node";
return;
}
## check to see if this user is in the reader_ids list
if (inlist2($user,$node->{reader_ids})) {
return 1;
}
if ($node->{private} eq 'Y') {
$error="Cannot read node, private";
return;
}
return 1;
}
## can this user write to this node?
sub canwrite {
my $node=shift;
my $user=shift;
if (!$node || !$user) {
$error="Parameter error to canwrite";
return;
}
if ($node->{user_id} == $user->{id}) {
return 1;
}
## if in exclude, bye!
if (inlist2($user,$node->{exclude_ids})) {
$error="You are excluded from this node";
return;
}
## check to see if this user is in the writer_ids list
if (inlist2($user,$node->{writer_ids})) {
return 1;
}
$error="Cannot write node, not owner";
return;
}
sub fields {
return @fields;
}
sub error {
return $error;
}
sub types {
return @types;
}
sub mimetypes {
my @mime;
open IN,"</etc/mime.types" || return;
while (<IN>) {
next if /^\#/;
next if /^\s*$/;
push @mime,$1 if /^([^\s]+)/;
}
close IN;
@mime;
}
## converts the arrayref into a simple hash reference
sub arraytohash {
my $node=shift;
my $newnode={};
for my $fn (0..$#fields) {
$newnode->{$fields[$fn]}=$node->[$fn];
}
$newnode;
}
## gets a raw node (no translations/executions)
sub getrawnode {
my $id=shift;
my $user=new GNS::User( this => 1);
if (! defined $user) {
$error=GNS::User::error();
return;
}
if (! $id) {
$error="No ID passed to getrawnode";
return undef;
}
# ## cache (must be careful, check for security here also)
if ($cache) {
if (my $c=$cache->check($id)) {
if (!canread($c,$user)) {
## we fake the node not being there for people who can't read
$error="Node $id not found";
return;
}
return $c;
}
}
my $rawnode;
$rawnode=$db->diys("select ".join(",",@fields)." from node where id
+= $id");
my $node;
if (defined $rawnode && defined $rawnode->[0]) {
$node=arraytohash($rawnode->[0]);
if (!canread($node,$user)) {
$error="Node $id not found";
return;
}
}
else {
$error="Node $id not found";
return;
}
$cache->insert($id,$node) if $cache;
$node;
}
## returns an array of ids
sub search {
my $term=shift;
if (! defined $term) {
$error="No search term specified";
return undef;
}
my $user=new GNS::User(this=>1);
if (! defined $user) {
$error=GNS::User::error();
return;
}
## check for exact match
my $id=$db->diysval("select id from node where title like \"\Q$term\
+E\"");
return $id if $id;
## okay, we need to construct a statement
my @buf;
my @words=split /\s+/,$term;
for my $w (@words) {
push @buf,"( body rlike \"\Q$w\E\" or title rlike \"\Q$w\E\" )";
}
my $rawnodes=$db->diys("select id from node where ".
join(" and ",@buf).
" order by date desc limit 100");
if (! defined $rawnodes || ! defined $rawnodes->[0]) {
$error="No node matching search found";
return;
}
my @results;
## go through and make sure this user can read these nodes
for my $n (@$rawnodes) {
my $ah=getrawnode($n->[0]);
next unless $ah;
push @results,$n->[0];
}
@results;
}
## a generic select function
sub selectnodes {
my $where=shift;
if (!$where) {
$error="No where passed to selectnodes";
return;
}
my $nodes=$db->diys("select id from node where $where");
my @results;
if ($nodes && $nodes->[0]) {
for my $n (@$nodes) {
## do this for security's sake
my $node=getrawnode($n->[0]);
push @results,$node->{id} if $node;
}
}
else {
$error="Nothing found where $where";
return;
}
@results;
}
sub expirenodes {
my $time=time;
my $nodes=$db->diys("select id from node where ".
"( modified > 0 and expires > 0 and expires + mo
+dified < $time )".
" or ".
"( modified = 0 and expires > 0 and expires + da
+te < $time )");
my @todie;
## don't expire anything that has children
for my $n (@$nodes) {
push @todie,$n->[0] unless $db->diysval("select id from node where
+ p_id = $n->[0]");
}
## kill all in @todie
for my $i (@todie) {
$db->diys("delete from node where id = $i");
}
}
expirenodes;
######################################################################
+########
######################################################################
+########
sub new {
my $class=shift;
my %args=@_;
my $self={ };
## parse any arguments
if (defined $args{id}) {
## preloaded with an ID
my $node=getrawnode($args{id});
## and it worked?
if (!$node) {
return;
}
## and make it an instance of this class
$self=$node;
}
elsif (defined $args{reply}) {
## set this up as a reply to the node ID passed
my $node=getrawnode($args{reply});
if (!$node) {
## well damn
return;
}
## do it by copying various information
$self->{p_id}=$node->{id};
for my $f (qw(private readers_id type mimetype expires)) {
$self->{$f}=$node->{$f} if defined $node->{$f};
}
## and some tweaks
## homenode replies don't remain homenodes
$self->{type}="text" if $node->{type} eq 'home';
## the title is special
if ($node->{title}!~/^re:/i) {
$self->{title}="re: $node->{title}";
}
else {
$self->{title}=$node->{title};
}
}
else {
$self->{type}='text';
$self->{mimetype}='text/html';
$self->{title}="(untitled)";
}
bless $self,$class;
$self;
}
#############
sub body {
my $self=shift;
my $buff;
## if there is a filehandle already, it's been opened and ready
if (defined $self->{fh}) {
## return a block of information
if (sysread($self->{fh},$buff,1024)) {
return $buff;
}
else {
## failed, close the handle and quit
delete $self->{fh};
return;
}
}
## or a simple flag for simple bodies
elsif (defined $self->{retrieved}) {
delete $self->{retrieved};
return;
}
## okay,
if ($self->{type} eq 'file') {
## create a file handle for this file
my $fh=new IO::File;
## try to open the file
if (!$fh->open($self->{body})) {
## hmm, that failed
$error="Unable to open file: $!";
return;
}
## we're good
$self->{fh}=$fh;
## return the first block
return $self->body;
}
elsif ($self->{type} eq 'perl') {
local *FH;
my $fh;
tie (*FH,'IO::Scalar',\$fh);
my $oldfh=select FH;
## okay, we'll cheat for me
if ($self->{user_id}==1) {
eval $self->{body};
}
else {
my $safe=new Safe;
$safe->reval($self->{body});
}
select $oldfh;
$self->{retrieved}=1;
return $@.$fh;
}
else {
## simple body, just return it
$self->{retrieved}=1;
return makelinks($self->{body});
}
}
sub childrenids {
my $self=shift;
my $childs=$db->diys("select id from node where p_id = $self->{id} o
+rder by date");
## not really an error
if (! defined $childs) {
$error="No children found";
return;
}
my @results;
my $user=new GNS::User(this=>1);
if (! defined $user) {
$error=GNS::User::error();
return;
}
for my $n (@$childs) {
## security again
my $ah=getrawnode($n->[0]);
next unless $ah;
push @results,$n->[0];
}
return if $#results==-1;
@results;
}
sub change {
my $self=shift;
my $new=shift;
my $user=new GNS::User(this=>1);
## check a couple of things here
if (!$user) {
$error=GNS::User::error;
return;
}
## also chekc $dead_account
if ($user->{name} eq $dead_account) {
$error="Access denied";
return;
}
## can this user write to this node?
if ($user->{id}==$self->{user_id} ||
canwrite($self,$user)) {
## sure can
}
else {
$error="You may not write to this node";
return;
}
## check the ID
if (!getrawnode($self->{id})) {
$error="This node no longer exists";
return;
}
## update modified
$self->{modified}=time;
my @buf;
## okay, change the values
for my $f (@fields) {
## but ignore certain ones
next if $f eq 'id';
next if $f eq 'date';
next if $f eq 'user_id';
## quote the string
my $str="\Q$new->{$f}\E";
## but change any \% back to %
$str=~s/\\%/%/g;
push @buf,"$f = \"$str\"";
}
my $buf="update node set ".join(", ",@buf)." where id = $self->{id}"
+;
$cache->purge if $cache;
$db->diys($buf);
$self->{id};
}
sub add {
my $self=shift;
my $user=new GNS::User(this=>1);
## check a couple of things here
if (!$user) {
$error=GNS::User::error;
return;
}
## also chekc $dead_account
if ($user->{name} eq $dead_account) {
$error="Access denied";
return;
}
$cache->purge if $cache;
## if the p_id is not readable, can't reply
if ($self->{p_id}) {
my $p=new GNS::Node(id => $self->{p_id});
## the above checks readness automatically
if (!$p) {
$error="You may not reply to that node";
return;
}
}
## set stuff
$self->{date}=time;
$self->{user_id}=$user->{id};
$self->{type}='text' unless defined $self->{type};
$self->{mimetype}='text/plain' unless defined $self->{type};
my @fie;
my @val;
## okay, change the values
for my $f (@fields) {
## but ignore certain ones
next if $f eq 'id';
## quote the string
my $str="\Q$self->{$f}\E";
## but change any \% back to %
$str=~s/\\%/%/g;
push @fie,$f;
push @val,"\"$str\"";
}
my $buf="insert into node (".join(",",@fie).") values (".join(",",@v
+al).")";
$db->diys($buf);
$db->diysval("select LAST_INSERT_ID()");
}
sub deletenode {
my $self=shift;
## make sure this user can delete,
my $user=new GNS::User(this=>1);
if (!$user) {
$error=GNS::User::error();
return;
}
if (!canwrite($self,$user)) {
$error="You may not delete this node";
return;
}
$db->diys("delete from node where id = $self->{id}");
## now, if this node has children, and this one a parent, move those
+ children to the parent
## if no parent, then they become rooties (pid of 0)
my $newpid=0;
$newpid=$self->{p_id} if defined $self->{p_id};
$db->diys("update node set p_id = $newpid where p_id = $self->{id}")
+;
1;
}
######################################################################
+########
1;
__END__
In reply to GNS::Node
by mr.nick
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.