Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

GNS::Node

by mr.nick (Chaplain)
on Mar 06, 2001 at 22:49 UTC ( #62542=sourcecode: print w/ replies, xml ) Need Help??

Category: CGI Programming
Author/Contact Info mr.nick
Description: Okay folks, this is my Node class that I've been spewing about. Please take a look and see if it makes sense to you. If it does, and you have constructive criticism, please make them. Oh, and ignore the zillions of calls to GNS::User->new().
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__

Comment on GNS::Node
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://62542]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (13)
As of 2015-07-03 12:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (53 votes), past polls