Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
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

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others exploiting the Monastery: (4)
As of 2024-03-29 10:20 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found