From slash5234 @ users.sourceforge.jp Tue Oct 18 18:49:06 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 18 Oct 2005 18:49:06 +0900 Subject: [Affelio-cvs 586] CVS update: affelio/apps/Mixi/extlib/WWW Message-ID: <20051018094906.E5E2A2AC089@users.sourceforge.jp> Index: affelio/apps/Mixi/extlib/WWW/Mixi.pm diff -u affelio/apps/Mixi/extlib/WWW/Mixi.pm:1.4 affelio/apps/Mixi/extlib/WWW/Mixi.pm:1.5 --- affelio/apps/Mixi/extlib/WWW/Mixi.pm:1.4 Mon Aug 29 19:41:04 2005 +++ affelio/apps/Mixi/extlib/WWW/Mixi.pm Tue Oct 18 18:49:06 2005 @@ -4,7 +4,7 @@ use Carp (); use vars qw($VERSION @ISA); -$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/); require LWP::RobotUA; @ISA = qw(LWP::RobotUA); @@ -76,8 +76,9 @@ if (not $res) { return "ページを取得できていません。"; } elsif (not $res->is_success) { return sprintf('ページ取得に失敗しました。(%s)', $res->message); } else { + my $re_attr = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s+'; my $content = $res->content; - return 0 if ($content !~ /]+action=["']?([^"'\s<>]*)["']?.*?>/); + return 0 if ($content !~ /
]+)/); return 0 if ($self->absolute_url($1) ne $self->absolute_url('login.pl')); $self->{'mixi'}->{'next_url'} = ($content =~ //) ? $1 : '/home.pl'; return "Login Failed ($1)" if ($content =~ /(.*?)<\/font><\/b>/); @@ -233,17 +234,32 @@ my $base = $res->base->as_string; my $content = $res->content; my @items = (); - if ($content =~ /(.*?)<\/table>/s) { + if ($content =~ /]+ ALT=お知らせ VSPACE=1 WIDTH=100 HEIGHT=37>.*?(.*?)<\/table>/is) { $content = $1; - $content =~ s/[\r\n]//g; + $content =~ s/[\r\n]+//gs; $content =~ s///g; while ($content =~ s/
(.*?)<\/td>(.*?)<\/td>(.*?)<\/td><\/tr>//i) { my ($subject, $linker) = ($1, $3); + my $re_attr_val = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s*'; + my $style = {}; + $subject =~ s/^.*?・<\/font>(?: | )//; + while ($subject =~ s/^\s*<([^<>]*)>\s*//) { + my $tag = lc($1); + my ($tag_part, $attr_part) = split(/\s+/, $tag, 2); + $style->{'font-weight'} = 'bold' if ($tag_part eq 'b'); + while ($attr_part =~ s/([^\s<>=]+)(?:=($re_attr_val))?//) { + my ($attr, $val) = ($1, $2); + $val =~ s/^"(.*)"$/$1/ or $val =~ s/^'(.*)'$/$1/; + $val = $self->unescape($val); + if ($attr eq 'style') { $style->{$1} = $2 while ($val =~ s/([^\s:]+)\s*:\s*([^\s:]+)//); } + elsif ($attr eq 'color') { $style->{'color'} = $val; } + } + } $subject =~ s/\s*<.*?>\s*//g; - $subject =~ s/^・//; my ($link, $description) = ($1, $2) if ($linker =~ /(.*?)<\/a>/i); my $item = { 'subject' => $self->rewrite($subject), + 'style' => $style, 'link' => $self->absolute_url($link, $base), 'description' => $self->rewrite($description) }; @@ -253,95 +269,205 @@ return @items; } -sub parse_calendar { +sub parse_home_new_album { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - my %icons = ('i_sc-.gif' => '予定', 'i_bd.gif' => '誕生日', 'i_iv1.gif' => '参加イベント', 'i_iv2.gif' => 'イベント'); - my %whethers = ('1' => '晴', '2' => '曇', '3' => '雨', '4' => '雪', '8' => 'のち', '9' => 'ときどき'); my @items = (); - my $term = $self->parse_calendar_term($res) or return undef; - if ($content =~ /(.+?)<\/table>/s) { + if ($content =~ /マイミクシィ最新アルバム(.*?)
/s) { $content = $1; - $content =~ s/.*?<\/tr>//is; - while ($content =~ s/
]*>(\S*?)<\/font>(.*?)<\/td>//is) { - my $date = $1; - my $text = $2; - next unless ($date =~ /(\d+)/); - $date = sprintf('%04d/%02d/%02d', $term->{'year'}, $term->{'month'}, $1); - if ($text =~ s/(.*?)<\/font><\/font>//) { - my $item = { 'subject' => "天気", 'link' => undef, 'name' => $2, 'time' => $date, 'icon' => $1}; - $item->{'icon'} = $self->absolute_url($item->{'icon'}, $base); - my $weather = ($item->{'icon'} =~ /i_w(\d+).gif$/) ? $1 : '不明'; - $weather =~ s/(\d)/$whethers{$1}/g; - $item->{'name'} = sprintf("%s(%s\%)", $weather, $self->rewrite($item->{'name'})); - push(@items, $item); - } - my @events = split(/
/, $text); - foreach my $event (@events) { - my $item = {}; - if ($event =~ /(.*?)<\/a>/) { - $item = { 'subject' => $1, 'link' => $2, 'name' => $3, 'time' => $date, 'icon' => $1}; - } elsif ($event =~ /(.*?)<\/a>/) { - $item = { 'subject' => $2, 'link' => $1, 'name' => $3, 'time' => $date, 'icon' => $2}; - } else { - next; - } - $item->{'subject'} = ($item->{'subject'} =~ /([^\/]+)$/ and $icons{$1}) ? $icons{$1} : "不明($1)"; - $item->{'link'} = $self->absolute_url($item->{'link'}, $base); - $item->{'icon'} = $self->absolute_url($item->{'icon'}, $base); - $item->{'subject'} = $self->rewrite($item->{'subject'}); - $item->{'name'} = $self->rewrite($item->{'name'}); - push(@items, $item); - } + while ($content =~ s/(\d{2})月(\d{2})日.*?(.*?)<\/a>.*?\((.+?)\)
//is) { + my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); + $subj = $self->rewrite($subj); + $name = $self->rewrite($name); + $link = $self->absolute_url($link, $base); + push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); + } + } + return @items; +} + +sub parse_home_new_bbs { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /コミュニティ最新書き込み(.*?)/s) { + $content = $1; + while ($content =~ s/(\d{2})月(\d{2})日.*?(.*?)<\/a>.*?\((.+?)\)
//is) { + my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); + $subj = $self->rewrite($subj); + $name = $self->rewrite($name); + $link = $self->absolute_url($link, $base); + push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); + } + } + return @items; +} + +sub parse_home_new_comment { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /日記コメント記入履歴(.*?)
/s) { + $content = $1; + while ($content =~ s/(\d{2})月(\d{2})日.*?(.*?)<\/a>.*?\((.+?)\)
//is) { + my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); + $subj = $self->rewrite($subj); + $name = $self->rewrite($name); + $link = $self->absolute_url($link, $base); + push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); + } + } + return @items; +} + +sub parse_home_new_friend_diary { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /
マイミクシィ最新日記<\/font>.*?<\/td>(.*?)/s) { + $content = $1; + while ($content =~ s/(\d{2})月(\d{2})日.*?(.*?)<\/a>.*?\((.+?)\)
//is) { + my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); + $subj = $self->rewrite($subj); + $name = $self->rewrite($name); + $link = $self->absolute_url($link, $base); + push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); + } + } + return @items; +} + +sub parse_home_new_review { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /マイミクシィ最新レビュー(.*?)
/s) { + $content = $1; + while ($content =~ s/(\d{2})月(\d{2})日.*?(.*?)<\/a>.*?\((.+?)\)
//is) { + my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); + $subj = $self->rewrite($subj); + $name = $self->rewrite($name); + $link = $self->absolute_url($link, $base); + push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); } } return @items; } -sub parse_calendar_term { +sub parse_ajax_new_diary { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - return unless ($content =~ /
[^&]*?<\/a>/); - return {'year' => $1, 'month' => $2}; + my @items = (); + my $re_date = '(\d{1,2})月(\d{1,2})日'; + my $re_link = ']*href="?([^<> ]*?)"?(?: [^<>]*)?>(.*?)<\/a>'; + my $re_name = '\((.*?)\)'; + my @today = reverse((localtime)[3..5]); + $today[0] += 1900; + $today[1] += 1; + foreach my $row ($content =~ /
(.*?)<\/div>/isg) { + next unless ($row =~ /$re_date … $re_link/); + my $item = {}; + my @date = (undef, $1, $2); + $item->{'link'} = $self->absolute_url($3, $base); + $item->{'subject'} = (defined($4) and length($4)) ? $self->rewrite($4) : '(削除)'; + $date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0])); + $item->{'time'} = sprintf('%04d/%02d/%02d', @date); + map { $item->{$_} =~ s/^\s+|\s+$//gs } (keys(%{$item})); + push(@items, $item); + } + return @items; +} + +sub parse_community_id { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my $item; + if ($content =~ /view_community.pl\?id=(\d+) /) { + $item = $1; + } + return $item; +} + +sub parse_list_bbs { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + my $re_date = '
'; + my $re_subj = ''; + my $re_desc = ''; + my $re_name = '\((.*?)\)'; + my $re_link = '書き込み\((\d+)\)<\/a>'; + if ($content =~ /
(\d{2})月(\d{2})日
(\d{1,2}):(\d{2})
 (.+?)(.*?)\n
(.+)<\/table>/s) { + $content = $1 ; + while ($content =~ s/.*?${re_date}.*?${re_subj}(.*?)${re_desc}.*?${re_link}.*?<\/tr>//is) { + my $time = sprintf('%02d/%02d %02d:%02d', $1, $2, $3, $4); + my ($subj, $thumbs, $desc, $link, $count) = ($5, $6, $7, $8, $9); + $subj = $self->rewrite($subj); + $desc = $self->rewrite($desc); + $desc =~ s/^$//g; + $link = $self->absolute_url($link, $base); + my @images = (); + while ($thumbs =~ s/MM_openBrWindow\('(.*?)',.+?]*?)['"]? border//is){ + my $img = $self->absolute_url($1, $base); + my $thumbimg = $self->absolute_url($2, $base); + push(@images, {'thumb_link' => $thumbimg, 'link' => $img}); + } + push(@items, {'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $link, 'count' => $count, 'images' => [@images]}); + } + } + return @items; } -sub parse_calendar_next { +sub parse_list_bbs_next { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - return unless ($content =~ /([^<>]+?) >>/); + return unless ($content =~ /
.*?]*?list_bbs.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/); my $subject = $2; my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $subject}; + my $next = {'link' => $link, 'subject' => $2}; return $next; } -sub parse_calendar_previous { +sub parse_list_bbs_previous { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - return unless ($content =~ /<< ([^<>]+)/); + return unless ($content =~ /]*?list_bbs.pl[^<>]*?)>([^<>]*?)<\/a>/); my $subject = $2; my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $subject}; + my $next = {'link' => $link, 'subject' => $2}; return $next; } -sub parse_diary { - my $self = shift; - return $self->parse_view_diary(@_); -} - sub parse_list_bookmark { my $self = shift; my $res = (@_) ? shift : $self->response(); @@ -349,7 +475,7 @@ my $base = $res->base->as_string; my $content = $res->content; my @items = (); - if ($content =~ /(.+?)/s) { + if ($content =~ /
(.+?)]*?>/s) { $content = $1; while ($content =~ s/
(.*?)<\/table>//is) { my $record = $1; @@ -516,9 +642,10 @@ my $base = $res->base->as_string; my $content = $res->content; my @items = (); - if ($content =~ /(.+)/s) { + if ($content =~ /各月の日記(.+?)<\/table>/is) { $content = $1; - while ($content =~ s/.*?<\/a>//is) { + $content =~ s/\s+/ /gs; + while ($content =~ s/.*?<\/a>//is) { push(@items, {'link' => $self->absolute_url($1, $base), 'year' => $2, 'month' => $3}); } } @@ -590,6 +717,64 @@ return $previous; } +sub parse_list_member { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /
(.+?)<\/table>/s) { + $content = $1 ; + while ($content =~ s/(.*?)(.*?)<\/tr>//is) { + my ($image_part, $text_part) = ($1, $2); + my @images = ($image_part =~ /
.*?<\/td>/gi); + my @texts = ($text_part =~ /(.*?)<\/td>/gi); + for (my $i = 0; $i < @images or $i < @texts; $i++) { + my $item = {}; + my ($image, $text) = ($images[$i], $texts[$i]); + ($item->{'subject'}, $item->{'count'}) = ($1, $2) if ($text =~ /^\s*(.+?)\((\d+)\)/); + ($item->{'background'}, $item->{'link'}, $item->{'image'}) = ($1, $2, $3) if ($image =~ / ]*).*?><\/a>/i); + if ($item->{'link'}) { + $item->{'subject'} = $self->rewrite($item->{'subject'}); + $item->{'link'} = $self->absolute_url($item->{'link'}, $base); + $item->{'id'} = $2 if ($item->{'link'} =~ /(.*?)?id=(\d*)/); + $item->{'image'} = $self->absolute_url($item->{'image'}, $base); + $item->{'background'} = $self->absolute_url($item->{'background'}, $base); + push(@items, $item); + } + } + } + } + return @items; +} + +sub parse_list_member_next { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + return unless ($content =~ /  ]*?list_member.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>/); + my $subject = $2; + my $link = $self->absolute_url($1, $base); + my $next = {'link' => $link, 'subject' => $2}; + return $next; +} + +sub parse_list_member_previous { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->request->uri->as_string; + my $content = $res->content; + return unless ($content =~ /\s]*list_member.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>  /); + my $subject = $2; + my $link = $self->absolute_url($1, $base); + my $previous = {'link' => $link, 'subject' => $2}; + return $previous; +} + sub parse_list_message { my $self = shift; my $res = (@_) ? shift : $self->response(); @@ -656,6 +841,43 @@ return @items; } +sub parse_list_request { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /(.+?)
/s) { + $content = $1; + while ($content =~ s/
(.*?)<\/table>//is) { + my $record = $1; + my @lines = ($record =~ /(.*?)<\/tr>/gis); + my $item = {}; + # parse record + ($item->{'link'}, $item->{'image'}) = ($1, $2) if ($lines[0] =~ /'; + my $re_desc = ''; + if ($content =~ /新機能リリース・障害のご報告(.*?)/s) { + $content = $1; + while ($content =~ s/
/is); + ($item->{'subject'}, $item->{'gender'}) = ($1, $2) if ($lines[0] =~ /(.*?) \((.*?)\)<\/td>/is); + $item->{'description'} = $1 if ($lines[1] =~ /(.*?)<\/td>/is); + $item->{'message'} = $1 if ($lines[2] =~ /(.*?)<\/td>/is); + $item->{'time'} = $1 if ($lines[3] =~ /(.*?)<\/td>/is); + while ($lines[3] =~ s/["']?(.*?)['"]?]*?><\/a>//) { + my $button = { 'link' => $1, 'image' => $2, 'title' => $3 }; + map { $button->{$_} = $self->absolute_url($button->{$_}, $base) } qw(link image); + map { $button->{$_} = $self->rewrite($button->{$_}, $base) } qw(title); + $item->{'button'} = [] unless ($item->{'button'}); + push(@{$item->{'button'}}, $button); + } + # format + map { $item->{$_} = $self->absolute_url($item->{$_}, $base) } qw(link image); + map { $item->{$_} = $self->rewrite($item->{$_}, $base) } qw(subject description message gender); + $item->{'time'} = $self->convert_login_time($item->{'time'}) if ($item->{'time'}); + push(@items, $item) if ($item->{'subject'} and $item->{'link'}); + } + } + @items = sort { $b->{'time'} cmp $a->{'time'} } @items; + return @items; +} + sub parse_new_album { my $self = shift; return $self->parse_standard_history(@_); @@ -681,7 +903,62 @@ return $self->parse_standard_history(@_); } -sub parse_new_diary { +sub parse_new_friend_diary { + my $self = shift; + return $self->parse_standard_history(@_); +} + +sub parse_new_friend_diary_next { + my $self = shift; + return $self->parse_standard_history_next(@_); +} + +sub parse_new_friend_diary_previous { + my $self = shift; + return $self->parse_standard_history_previous(@_); +} + +sub parse_new_review { + my $self = shift; + return $self->parse_standard_history(@_); +} + +sub parse_release_info { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + my $re_subj = '(.+?)'; + my $re_date = '(\d{4}).(\d{2}).(\d{2})(.*?)
.*?${re_subj}.*?${re_date}.*?${re_desc}.*?//is) { + my $subj = $1; + my $date = sprintf('%04d/%02d/%02d', $2, $3, $4); + my $desc = $5; + $subj = $self->rewrite($subj); + $desc = $self->rewrite($desc); + $desc =~ s/^$//g; + push(@items, {'time' => $date, 'description' => $desc, 'subject' => $subj}); + } + } + return @items; +} + +sub parse_self_id { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my $self_id = ($content =~ /\(URL は http:\/\/mixi.jp\/show_friend.pl\?id=(\d+) です。\)/) ? $1 : 0; + return $self_id; +} + +sub parse_search_diary { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); @@ -690,7 +967,7 @@ my @items = (); my @time = localtime(); my ($month, $year) = ($time[4] + 1, $time[5] + 1900); - if ($content =~ /(.+?)/s) { + if ($content =~ m{(.+?)}s) { $content = $1; while ($content =~ s/
(.*?)<\/table>//is) { my $record = $1; @@ -717,80 +994,114 @@ return @items; } -sub parse_new_diary_next { +sub parse_search_diary_next { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - return unless ($content =~ /'; + my $re_c_date = ''; + my $re_link = '(.*?)<\/a>'; + if ($content =~ s/.*?${re_date}.*?${re_subj}.*?${re_link}(.*?)${re_desc}(.*?)$//is) { + my ($time, $subj, $link, $name, $imgs, $desc, $comm) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8, $9, $10, $11); + ($desc, $subj) = map { s/[\r\n]+//g; s/
/\n/g; $_ = $self->rewrite($_); } ($desc, $subj); + my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [] , 'name' => $name, 'name_link' => $self->absolute_url($link, $base)}; + foreach my $image ($imgs =~ /
'; my $re_subj = ''; my $re_desc = ''; -# my $re_c_date = '.*?${re_date}.*?${re_subj}(.*?)${re_desc}(.+)//is) { my ($time, $subj, $imgs, $desc, $comm) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8, $9); + my $level = { 'description' => $self->rewrite($2), 'link' => $self->absolute_url($1, $base) } if ($content =~ /([^/); ($desc, $subj) = map { s/[\r\n]+//g; s/
/\n/g; $_ = $self->rewrite($_); } ($desc, $subj); - my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [] }; + my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [], 'level' => $level }; foreach my $image ($imgs =~ /
'; + my $re_subj = ''; + my $re_link = '(.*?)<\/a>'; + my $re_hold = ''; + my $re_dead = ''; + my $re_desc = '
.*?]*?new_diary.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/); + return unless ($content =~ /.*?]*?search_diary.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/); my $subject = $2; my $link = $self->absolute_url($1, $base); my $next = {'link' => $link, 'subject' => $2}; return $next; } -sub parse_new_diary_previous { +sub parse_search_diary_previous { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - return unless ($content =~ /]*?new_diary.pl[^<>]*?)>([^<>]*?)<\/a>/); + return unless ($content =~ /]*?search_diary.pl[^<>]*?)>([^<>]*?)<\/a>/); my $subject = $2; my $link = $self->absolute_url($1, $base); my $next = {'link' => $link, 'subject' => $2}; return $next; } -sub parse_new_friend_diary { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_new_friend_diary_next { - my $self = shift; - return $self->parse_standard_history_next(@_); -# my $self = shift; -# my $res = (@_) ? shift : $self->response(); -# return unless ($res and $res->is_success); -# my $base = $res->base->as_string; -# my $content = $res->content; -# # return unless ($content =~ /[^\r\n]*?([^<>]+)<\/a><\/td><\/tr>/); -# return unless ($content =~ /[^\r\n]*?]+?)['"]?>([^<>]+)<\/a><\/td><\/tr>/); -# my $subject = $2; -# my $link = $self->absolute_url($1, $base); -# my $next = {'link' => $link, 'subject' => $2}; -# return $next; +sub parse_show_calendar { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my %icons = ('i_sc-.gif' => '予定', 'i_bd.gif' => '誕生日', 'i_iv1.gif' => '参加イベント', 'i_iv2.gif' => 'イベント'); + my %whethers = ('1' => '晴', '2' => '曇', '3' => '雨', '4' => '雪', '8' => 'のち', '9' => 'ときどき'); + my @items = (); + my $term = $self->parse_show_calendar_term($res) or return undef; + if ($content =~ /(.+?)<\/table>/s) { + $content = $1; + $content =~ s/.*?<\/tr>//is; + while ($content =~ s/.*?.*?'; + my $re_subj = ''; + my $re_desc = '
]*>(\S*?)<\/font>(.*?)<\/td>//is) { + my $date = $1; + my $text = $2; + next unless ($date =~ /(\d+)/); + $date = sprintf('%04d/%02d/%02d', $term->{'year'}, $term->{'month'}, $1); + if ($text =~ s/(.*?)<\/font><\/font>//) { + my $item = { 'subject' => "天気", 'link' => undef, 'name' => $2, 'time' => $date, 'icon' => $1}; + $item->{'icon'} = $self->absolute_url($item->{'icon'}, $base); + my $weather = ($item->{'icon'} =~ /i_w(\d+).gif$/) ? $1 : '不明'; + $weather =~ s/(\d)/$whethers{$1}/g; + $item->{'name'} = sprintf("%s(%s%%)", $weather, $self->rewrite($item->{'name'})); + push(@items, $item); + } + my @events = split(/
/, $text); + foreach my $event (@events) { + my $item = {}; + if ($event =~ /(.*?)<\/a>/) { + $item = { 'subject' => $1, 'link' => $2, 'name' => $3, 'time' => $date, 'icon' => $1}; + } elsif ($event =~ /(.*?)<\/a>/) { + $item = { 'subject' => $2, 'link' => $1, 'name' => $3, 'time' => $date, 'icon' => $2}; + } else { + next; + } + $item->{'subject'} = ($item->{'subject'} =~ /([^\/]+)$/ and $icons{$1}) ? $icons{$1} : "不明($1)"; + $item->{'link'} = $self->absolute_url($item->{'link'}, $base); + $item->{'icon'} = $self->absolute_url($item->{'icon'}, $base); + $item->{'subject'} = $self->rewrite($item->{'subject'}); + $item->{'name'} = $self->rewrite($item->{'name'}); + push(@items, $item); + } + } + } + return @items; } -sub parse_new_friend_diary_previous { +sub parse_show_calendar_term { my $self = shift; - return $self->parse_standard_history_previous(@_); -# my $res = (@_) ? shift : $self->response(); -# return unless ($res and $res->is_success); -# my $base = $res->request->uri->as_string; -# my $content = $res->content; -# return unless ($content =~ /
([^<>]+)<\/a>[^\r\n]*?<\/td><\/tr>/); -# my $subject = $2; -# my $link = $self->absolute_url($1, $base); -# my $previous = {'link' => $link, 'subject' => $2}; -# return $previous; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + return unless ($content =~ /[^&]*?<\/a>/); + return {'year' => $1, 'month' => $2}; } -sub parse_new_review { +sub parse_show_calendar_next { my $self = shift; - return $self->parse_standard_history(@_); + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + return unless ($content =~ /([^<>]+?) >>/); + my $subject = $2; + my $link = $self->absolute_url($1, $base); + my $next = {'link' => $link, 'subject' => $subject}; + return $next; } -sub parse_self_id { +sub parse_show_calendar_previous { my $self = shift; my $res = (@_) ? shift : $self->response(); return unless ($res and $res->is_success); my $base = $res->base->as_string; my $content = $res->content; - my $self_id = ($content =~ /\(URL は http:\/\/mixi.jp\/show_friend.pl\?id=(\d+) です。\)/) ? $1 : 0; - return $self_id; + return unless ($content =~ /<< ([^<>]+)/); + my $subject = $2; + my $link = $self->absolute_url($1, $base); + my $next = {'link' => $link, 'subject' => $subject}; + return $next; } sub parse_show_friend_outline { @@ -858,6 +1169,33 @@ return; } +sub parse_show_intro { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /からの紹介文(.+?)/s) { + $content = $1; + while ($content =~ s/
\n(.*?)\n(.*?)<\/td>//is) { + my ($link, $img, $name, $rel, $desc) = ($1, $2, $3, $4, $5); + $rel =~ s/関係:(.+?)
/$1/; + my $intro = ($desc =~ /edit_intro.pl\?id=.+?\&type=edit/) ? "1" : "0"; + my $delete = ($desc =~ s/削除<\/a>//s) ? "1" : "0"; + $name = $self->rewrite($name); + $rel = $self->rewrite($rel); + $desc = $self->rewrite($desc); + $desc =~ s/この友人を紹介する//; + $desc =~ s/[\r\n]+//ig; + $link = $self->absolute_url($link, $base); + my $item = {'link' => $link, 'name' => $name, 'image' => $img, 'relation' => $rel, 'description' => $desc, 'introduction' => $intro, 'detele' => $delete}; + push(@items, $item); + } + } + return @items; +} + sub parse_show_log { my $self = shift; my $res = (@_) ? shift : $self->response(); @@ -879,16 +1217,108 @@ return @items; } -sub parse_show_log_count { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my $count = ($content =~ /ページ全体のアクセス数:(\d+)<\/b> アクセス/) ? $1 : 0; - return $count; -} - +sub parse_show_log_count { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my $count = ($content =~ /ページ全体のアクセス数:(\d+)<\/b> アクセス/) ? $1 : 0; + return $count; +} + +sub parse_view_album { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /概要ここから(.+?)/s) { + my $img = $1 if ($content =~ /width=250><\/td>/); + my $name = $1 if ($content =~ /(.*?)さんのフォトアルバム/); + my $subj = $1 if ($content =~ /タイトル.*?(.*?)<\/b>/s); + my $desc = $1 if ($content =~ /説明.*?CLASS=h120>(.*?)<\/td>/s); + my $level = $1 if ($content =~ /公開レベル.*?
(.*?)
/s); + my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $5, $5) if ($content =~ /作成日時.*?
(\d{4})年(\d{2})月(\d{2})日 (\d{2}):(\d{2})<\/td>/s); + my $comm = $1 if ($content =~ />コメント\((\d+)\)/); + my $number = $1 if ($content =~ /写真一覧.*?\ (\d+)枚/); + $name = $self->rewrite($name); + $subj = $self->rewrite($subj); + $desc = $self->rewrite($desc); + my $item = { 'image' => $self->absolute_url($img, $base), 'name' => $name, 'subject' => $subj, 'description' => $desc, 'level' => $level, 'time' => $time, 'comment_number' => $comm, 'photo_number' => $number}; + push(@items, $item); + } + return @items; +} + +sub parse_view_album_comment { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /写真一覧ここまで(.*?)/s) { + $content = $1; + while ($content =~ s/\n(\d{4})年(\d{2})月(\d{2})日
(\d{2}):(\d{2})\n<\/td>.*?(.+?)<\/a>.*?
(.*?)<\/td>//s) { + my ($time, $link, $name, $desc) = ((sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5)), $6, $7, $8); + my $item = { 'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $self->rewrite($name), 'description' => $self->rewrite($desc)}; + push(@items, $item); + } + } + return @items; +} + +sub parse_view_album_photo { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + if ($content =~ /写真一覧ここから(.*?)写真一覧ここまで/s) { + $content = $1; + while ($content =~ s/(.+?)<\/a><\/td>//) { + my ($alt, $thumb, $link, $subj) = ($1, $2, $3, $4); + my $item = { 'description' => $alt, 'thumb_link' => $self->absolute_url($thumb, $base), 'link' => $self->absolute_url($link, $base), 'subject' => $self->rewrite($subj)}; + push(@items, $item); + } + } + return @items; +} + +sub parse_view_bbs { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + my $re_date = '(\d{4})年(\d{2})月(\d{2})日
(\d{1,2}):(\d{2})
 (.+?)
(.+?)
\n(\d{4})年(\d{2})月(\d{2})日
\n(\d{1,2}):(\d{2})'; + my $re_c_desc = '
(.+?)\n]*>(.*?)<\/td>/g) { + next unless ($image =~ /]*'show_picture.pl\?img_src=(.*?)'[^<>]*>/); + push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)}); + } + while ($comm =~ s/.*?${re_c_date}.*?${re_link}.*?${re_c_desc}.*?<\/table>//is){ + my ($time, $link, $name, $desc) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8); + ($name, $desc) = map { s/[\r\n]+//g; s/
/\n/g; $_ = $self->rewrite($_); } ($name, $desc); + push(@{$item->{'comments'}}, {'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $name, 'description' => $desc}); + } + push(@items, $item); + } + return @items; +} + sub parse_view_diary { my $self = shift; my $res = (@_) ? shift : $self->response(); @@ -899,13 +1329,13 @@ my $re_date = '
(\d{4})年(\d{2})月(\d{2})日
(\d{1,2}):(\d{2})
 (.+?)(.+?)\n(\d{4})年(\d{2})月(\d{2})日
(\d{1,2}):(\d{2})
'; my $re_c_date = '
\n(\d{4})年(\d{2})月(\d{2})日
(\d{1,2}):(\d{2})'; my $re_link = '(.+?)<\/a>'; if ($content =~ s/
]*>(.*?)<\/td>/g) { next unless ($image =~ /]*'show_picture.pl\?img_src=(.*?)'[^<>]*>/); push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)}); @@ -920,6 +1350,45 @@ return @items; } +sub parse_view_event { + my $self = shift; + my $res = (@_) ? shift : $self->response(); + return unless ($res and $res->is_success); + my $base = $res->base->as_string; + my $content = $res->content; + my @items = (); + my $re_date = '(\d{4})年(\d{2})月(\d{2})日
(\d{1,2}):(\d{2})
 (.+?)\n (.*?)\n (.*?)
(.*?)'; + my $re_c_date = ''; + if ($content =~ s/
\n(\d{1,2}):(\d{2})
\n'; + my $re_c_desc = '
(.*?)\n
.*?${re_date}(.*?)${re_subj}.*?${re_link}.*?${re_hold}.*?${re_hold}.*?${re_desc}.*?${re_dead}(.*?)(.*?)//is) { + my ($time, $imgs, $subj, $link, $name, $date, $location, $desc, $deadline, $join, $comm) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8, $9, $10, $11, $12, $13, $14, $15); + if ($join =~ /VALUE=" イベントに参加する "/i) { $join = 1; + } elsif ($join =~ /VALUE=" 参加をキャンセルする "/i) { $join = 2; + } else { $join = 0; + } + ($desc, $subj) = map { s/[\r\n]+//g; s/
/\n/g; $_ = $self->rewrite($_); } ($desc, $subj); + my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [] , 'name' => $name, 'name_link' => $self->absolute_url($link, $base), 'date' => $date, 'location' => $location, 'deadline' => $deadline, 'join' => $join}; + foreach my $image ($imgs =~ /
]*>(.*?)<\/td>/g) { + next unless ($image =~ /]*'show_picture.pl\?img_src=(.*?)'[^<>]*>/); + push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)}); + } + while ($comm =~ s/${re_c_date}.*?${re_link}.*?${re_c_desc}//is) { + my ($time, $link, $name, $desc) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8); + my $imgs; + ($imgs, $desc) = ($1, $2) if ($desc =~ /(.+?)<\/table>.*?(.+?)<\/td>/); + ($name, $desc) = map { s/[\r\n]+//g; s/
/\n/g; $_ = $self->rewrite($_); } ($name, $desc); + push(@{$item->{'comments'}}, {'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $name, 'description' => $desc}); + } + push(@items, $item); + } + return @items; +} + sub parse_view_message { my $self = shift; my $res = (@_) ? shift : $self->response(); @@ -1108,44 +1577,66 @@ return $self->parse_tool_bar(); } -sub get_information { +sub get_information { my $self = shift; return $self->get_standard_data('parse_information', 'home.pl', @_); } +sub get_home_new_album { my $self = shift; return $self->get_standard_data('parse_home_new_album', 'home.pl', @_); } +sub get_home_new_bbs { my $self = shift; return $self->get_standard_data('parse_home_new_bbs', 'home.pl', @_); } +sub get_home_new_comment { my $self = shift; return $self->get_standard_data('parse_home_new_comment', 'home.pl', @_); } +sub get_home_new_friend_diary { my $self = shift; return $self->get_standard_data('parse_home_new_friend_diary', 'home.pl', @_); } +sub get_home_new_review { my $self = shift; return $self->get_standard_data('parse_home_new_review', 'home.pl', @_); } + +sub get_ajax_new_diary { my $self = shift; - my $url = 'home.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_information(); + my $url = 'ajax_new_diary.pll'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'friend_id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'friend_id'}) and length($param{'friend_id'}) and $url !~ /[\?\&]friend_id=/) { + $url .= ($url =~ /\?/) ? "&friend_id=$param{'friend_id'}" : "?friend_id=$param{'friend_id'}"; + } + return $self->get_standard_data('parse_ajax_new_diary', qr/ajax_new_diary\.pl/, $url, $refresh); } -sub get_calendar { +sub get_community_id { my $self = shift; - my $url = 'calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_calendar(); + return $self->get_standard_data('parse_community_id', qr/view_community\.pl/, @_); } -sub get_calendar_term { - my $self = shift; - my $url = 'calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_calendar_term(); +sub get_list_bbs { + my $self = shift; + my $url = 'list_bbs.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + return $self->get_standard_data('parse_list_bbs', qr/list_bbs\.pl/, $url, $refresh); } -sub get_calendar_next { - my $self = shift; - my $url = 'calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_calendar_next(); +sub get_list_bbs_next { + my $self = shift; + my $url = 'list_bbs.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + $self->set_response($url, $refresh) or return; + return $self->parse_list_bbs_next(); } -sub get_calendar_previous { - my $self = shift; - my $url = 'calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_calendar_previous(); +sub get_list_bbs_previous { + my $self = shift; + my $url = 'list_bbs.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + $self->set_response($url, $refresh) or return; + return $self->parse_list_bbs_previous(); } sub get_list_bookmark { @@ -1252,6 +1743,44 @@ return $self->parse_list_friend_previous(); } +sub get_list_member { + my $self = shift; + my $url = 'list_member.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + return $self->get_standard_data('parse_list_member', qr/list_member\.pl/, $url, $refresh); +} + +sub get_list_member_next { + my $self = shift; + my $url = 'list_member.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + $self->set_response($url, $refresh) or return; + return $self->parse_list_member_next(); +} + +sub get_list_member_previous { + my $self = shift; + my $url = 'list_member.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + $self->set_response($url, $refresh) or return; + return $self->parse_list_member_previous(); +} + sub get_list_message { my $self = shift; my $url = 'list_message.pl'; @@ -1268,6 +1797,14 @@ return $self->parse_list_outbox(); } +sub get_list_request { + my $self = shift; + my $url = 'list_request.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); + $self->set_response($url, @_) or return; + return $self->parse_list_request(); +} + sub get_new_album { my $self = shift; my $url = 'new_album.pl'; @@ -1308,9 +1845,56 @@ return $self->parse_new_comment(); } -sub get_new_diary { +sub get_new_friend_diary { + my $self = shift; + my $url = 'new_friend_diary.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); + $self->set_response($url, @_) or return; + return $self->parse_new_friend_diary(); +} + +sub get_new_friend_diary_next { + my $self = shift; + my $url = 'new_friend_diary.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); + $self->set_response($url, @_) or return; + return $self->parse_new_friend_diary_next(); +} + +sub get_new_friend_diary_previous { + my $self = shift; + my $url = 'new_friend_diary.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); + $self->set_response($url, @_) or return; + return $self->parse_new_friend_diary_previous(); +} + +sub get_new_review { + my $self = shift; + my $url = 'new_review.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); + $self->set_response($url, @_) or return; + return $self->parse_new_review(); +} + +sub get_release_info { + my $self = shift; + my $url = 'release_info.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); + $self->set_response($url, @_) or return; + return $self->parse_release_info(); +} + +sub get_self_id { + my $self = shift; + my $url = 'show_profile.pl'; + $self->set_response($url, @_) or return; + return $self->parse_self_id(); +} + +sub get_search_diary { my $self = shift; - my $url = 'new_diary.pl'; + my $url = 'search_diary.pl'; $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword'); my $refresh = shift if (@_ and $_[0] eq 'refresh'); my %param = @_; @@ -1319,13 +1903,14 @@ $param{'keyword'} =~ tr/ /+/; $url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}"; } - $self->set_response($url, $refresh) or return; - return $self->parse_new_diary(); + @_ = grep { defined($_) } ($url, $refresh); + $self->set_response(@_) or return; + return $self->parse_search_diary(); } -sub get_new_diary_next { +sub get_search_diary_next { my $self = shift; - my $url = 'new_diary.pl'; + my $url = 'search_diary.pl'; $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword'); my $refresh = shift if (@_ and $_[0] eq 'refresh'); my %param = @_; @@ -1335,12 +1920,12 @@ $url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}"; } $self->set_response($url, $refresh) or return; - return $self->parse_new_diary_next(); + return $self->parse_search_diary_next(); } -sub get_new_diary_previous { +sub get_search_diary_previous { my $self = shift; - my $url = 'new_diary.pl'; + my $url = 'search_diary.pl'; $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword'); my $refresh = shift if (@_ and $_[0] eq 'refresh'); my %param = @_; @@ -1350,46 +1935,47 @@ $url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}"; } $self->set_response($url, $refresh) or return; - return $self->parse_new_diary_previous(); + return $self->parse_search_diary_previous(); } -sub get_new_friend_diary { +sub get_show_calendar { my $self = shift; - my $url = 'new_friend_diary.pl'; + my $url = 'show_calendar.pl'; $url = shift if (@_ and $_[0] ne 'refresh'); $self->set_response($url, @_) or return; - return $self->parse_new_friend_diary(); + return $self->parse_show_calendar(); } -sub get_new_friend_diary_next { +sub get_show_calendar_term { my $self = shift; - my $url = 'new_friend_diary.pl'; + my $url = 'show_calendar.pl'; $url = shift if (@_ and $_[0] ne 'refresh'); $self->set_response($url, @_) or return; - return $self->parse_new_friend_diary_next(); + return $self->parse_show_calendar_term(); } -sub get_new_friend_diary_previous { +sub get_show_calendar_next { my $self = shift; - my $url = 'new_friend_diary.pl'; + my $url = 'show_calendar.pl'; $url = shift if (@_ and $_[0] ne 'refresh'); $self->set_response($url, @_) or return; - return $self->parse_new_friend_diary_previous(); + return $self->parse_show_calendar_next(); } -sub get_new_review { +sub get_show_calendar_previous { my $self = shift; - my $url = 'new_review.pl'; + my $url = 'show_calendar.pl'; $url = shift if (@_ and $_[0] ne 'refresh'); $self->set_response($url, @_) or return; - return $self->parse_new_review(); + return $self->parse_show_calendar_previous(); } -sub get_self_id { +sub get_show_intro { my $self = shift; - my $url = 'show_profile.pl'; + my $url = 'show_intro.pl'; + $url = shift if (@_ and $_[0] ne 'refresh'); $self->set_response($url, @_) or return; - return $self->parse_self_id(); + return $self->parse_show_intro(); } sub get_show_log { @@ -1408,20 +1994,75 @@ return $self->parse_show_log_count(); } -sub get_show_show_friend_outline { +sub get_show_friend_outline { my $self = shift; my $url = shift or return undef; $self->set_response($url, @_) or return undef; return $self->parse_show_friend_outline(); } -sub get_show_show_friend_profile { +sub get_show_friend_profile { my $self = shift; my $url = shift or return undef; $self->set_response($url, @_) or return undef; return $self->parse_show_friend_profile(); } +sub get_view_album { + my $self = shift; + my $url = 'view_album.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + return $self->get_standard_data('parse_view_album', qr/view_album\.pl/, $url, $refresh); +} + +sub get_view_album_comment { + my $self = shift; + my $url = 'view_album.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}&mode=comment"; + } + return $self->get_standard_data('parse_view_album_comment', qr/view_album\.pl/, $url, $refresh); +} + +sub get_view_album_photo { + my $self = shift; + my $url = 'view_album.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + return $self->get_standard_data('parse_view_album_photo', qr/view_album\.pl/, $url, $refresh); +} + +sub get_view_bbs { + my $self = shift; + my $url = shift or return; + $self->set_response($url, @_) or return undef; + return $self->parse_view_bbs(); +} + +sub get_view_community { + my $self = shift; + my $url = 'view_community.pl'; + $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); + my $refresh = shift if (@_ and $_[0] eq 'refresh'); + my %param = @_; + if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { + $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; + } + return $self->get_standard_data('parse_view_community', qr/view_community\.pl/, $url, $refresh); +} + sub get_view_diary { my $self = shift; my $url = shift or return; @@ -1429,6 +2070,13 @@ return $self->parse_view_diary(); } +sub get_view_event { + my $self = shift; + my $url = shift or return; + $self->set_response($url, @_) or return undef; + return $self->parse_view_event(); +} + sub get_view_message { my $self = shift; my $url = shift or return undef; @@ -1541,8 +2189,9 @@ sub absolute_url { my $self = shift; my $url = shift; - return undef unless ($url); my $base = (@_) ? shift : $self->{'mixi'}->{'base'}; + return undef unless (length($url)); + $url =~ s/^"(.*)"$/$1/ or $url =~ s/^'(.*)'$/$1/; $url .= '.pl' if ($url and $url !~ /[\/\.]/); return URI->new($url)->abs($base)->as_string; } @@ -1551,8 +2200,7 @@ my $self = shift; my $url = shift; return $url unless ($url and $self->response()); - my $res = $self->response(); - my $base = $res->request->uri->as_string; + my $base = $self->response->base->as_string; return $self->absolute_url($url, $base); } @@ -1665,7 +2313,7 @@ } sub callback_abort { - die; + die @_; } sub rewrite { @@ -1678,6 +2326,7 @@ my $str = shift; $str = $self->remove_tag($str); $str = $self->unescape($str); + $str =~ s/\s+$//s; return $str; } @@ -1695,12 +2344,7 @@ my $str = shift; my %unescaped = ('amp' => '&', 'quot' => '"', 'gt' => '>', 'lt' => '<', 'nbsp' => ' ', 'apos' => "'", 'copy' => '(c)'); my $re_target = join('|', keys(%unescaped)); - $str =~ s[&(.*?);]{ - local $_ = lc($1); - /^($re_target)$/ ? $unescaped{$1} : - /^#x([0-9a-f]+)$/ ? chr(hex($1)) : - $_ - }gex; + $str =~ s/&($re_target|#x([0-9a-z]+));/defined($unescaped{$1}) ? $unescaped{$1} : defined($2) ? chr(hex($2)) : "&$1;"/ige; return $str; } @@ -1708,7 +2352,6 @@ my $self = shift; my $str = shift; my $re_standard_tag = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; -# my $re_standard_tag = q{[^"'<>]*(?:"[^"]*"'?[^"'<>]*|'[^']*'"?[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; # のような余計なダブルクォート対応 my $re_comment_tag = '-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)'; my $re_html_tag = qq{$re_comment_tag|<$re_standard_tag}; $str =~ s/$re_html_tag//g; @@ -1734,6 +2377,24 @@ return 1; } +sub get_standard_data { + # default url is pased, so url is not necessary. + my $self = shift; + my $parser = shift; + my $def_url = shift; # defined url + my $url = shift if (@_ and $_[0] ne 'refresh'); # specified url + if (defined($def_url) and ref($def_url) eq 'Regexp') { + return unless (defined($url) and length($url)); + return unless ($url =~ $def_url); + } elsif (not (ref($url) eq '' and length($url))) { + $url = $def_url; + } + $self->abort("url \"$url\" is invalid.") unless (defined($url) and length($url)); # invalid url + $self->can($parser) or $self->abort("parser \"$parser\" is not available."); # invalid method + $self->set_response($url, @_) or $self->abort("set_response failed."); # request can not processed + return $self->$parser(); +} + sub parse_standard_history { my $self = shift; my $res = (@_) ? shift : $self->response(); @@ -1742,21 +2403,37 @@ my $content = $res->content; my @items = (); my $re_date = '(?:(\d{4})年)?(\d{2})月(\d{2})日 (\d{1,2}):(\d{2})'; - my $re_name = '\(([^\r\n]*)\)'; - my $re_link = '(.+?)\s*<\/a>'; + my $re_link = ']*href="?([^<> ]*?)"?(?: [^<>]*)?>(.*?)<\/a>'; + my $re_name = '\((.*?)\)'; if ($content =~ /
(.+?)<\/table>/s) { $content = $1; my @today = reverse((localtime)[3..5]); $today[0] += 1900; $today[1] += 1; - while ($content =~ s/.*?${re_date}.*?${re_link}\s*${re_name}.*?<\/tr>//is) { - my @date = ($1, $2, $3, $4, $5); - $date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0])); - my $time = sprintf('%04d/%02d/%02d %02d:%02d', @date); - my $subj = $self->rewrite($7); - my $name = $self->rewrite($8); - my $link = $self->absolute_url($6, $base); - push(@items, {'time' => $time, 'subject' => $subj, 'name' => $name, 'link' => $link}); + foreach my $row ($content =~ /(.*?)<\/tr>/isg) { + $row =~ s/\s*[\r\n]\s*//gs; + my @cols = ($row =~ /]*>(.*?)<\/td>/gs); + my $item = {}; + next unless ($cols[0] =~ s/$re_date//); + my @date = ($1, $2, $3, $4, $5); + next unless ($cols[1] =~ /${re_link}\s*$re_name/); + $item->{'link'} = $self->absolute_url($1, $base); + $item->{'subject'} = (defined($2) and length($2)) ? $self->rewrite($2) : '(削除)'; + $item->{'name'} = $self->rewrite($3); + $date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0])); + $item->{'time'} = sprintf('%04d/%02d/%02d %02d:%02d', @date); + map { $item->{$_} =~ s/^\s+|\s+$//gs } (keys(%{$item})); + if ($cols[1] =~ /(]*>)\s*(]*>)\s*<\/a>/is) { + my $image = {}; + my @tags = ($1, $2); + if ($_ = $self->parse_standard_tag($tags[0]) and $_->{'attr'}->{'href'} or $_->{'attr'}->{'onclick'}) { + $_ = ($_->{'attr'}->{'onclick'}) ? $_->{'attr'}->{'onclick'} : $_->{'attr'}->{'href'}; + $_ = $1 if ($_ =~ /MM_openBrWindow\('(.*?)'/); + $item->{'image'}->{'link'} = $self->absolute_url($_, $base); + } + $item->{'image'}->{'src'} = $self->absolute_url($_, $base) if ($_ = $self->parse_standard_tag($tags[1]) and $_ = $_->{'attr'}->{'src'}); + } + push(@items, $item); } } return @items; @@ -1826,11 +2503,26 @@ return @items; } +sub parse_standard_tag { + my $self = shift; + my $str = shift; + return undef unless ($str =~ s/^\s*<(.*)>\s*$/$1/s); + return undef if ($str =~ /^\!--/); + my $re_word = q{[^"'<>\s=]+}; #"]} + my $re_quote = q{(?:"[^"]*"|'[^']*')}; #")} + my $re_pair = qq{$re_word\\s*=\\s*(?:$re_quote|$re_word\\((?:[^)]*|$re_quote)*\\)|[^"'<>\\s]+)?}; + my $re_parse = qq{$re_pair|$re_word|$re_quote}; + my @parsed = ($str =~ /$re_parse/gs); + my $tag = lc(shift(@parsed)); + @parsed = map { /^($re_word)\s*=\s*(.*)$/ ? (lc($1) => $2) : (lc($_) => '') } @parsed; + @parsed = map { /^\s*=\s*$/ ? '=' :/^"(.*)"$/ ? $1 : /^'(.*)'$/ ? $1 : $_ } @parsed; + return { 'tag' => $tag, , 'attr' => {@parsed} }; +} sub set_response { my $self = shift; my $url = shift; - my $refresh = (@_ and $_[0] eq 'refresh') ? 1 : 0; + my $refresh = (@_ and defined($_[0]) and $_[0] eq 'refresh') ? 1 : 0; my $latest = ($self->response) ? $self->response->request->uri->as_string : undef; $url = $self->query_sorted_url($self->absolute_url($url)); return 0 unless ($url); @@ -1875,12 +2567,11 @@ my $self = shift; my %values = @_; $self->dumper_log(\%values); - $values{'id'} = $values{'diary_id'} if (not $values{'id'} and defined($values{'diary_id'})); my $url = exists($values{'__action__'}) ? $values{'__action__'} : 'edit_diary.pl?id=' . $values{'id'}; - my @fields = qw(submit diary_title diary_body photo1 photo2 photo3 submit); + my @fields = qw(submit diary_title diary_body photo1 photo2 photo3 submit post_key); my @required = qw(submit diary_title diary_body); my @files = qw(photo1 photo2 photo3); - my %label = ('id' => '日記ID', 'diary_title' => '日記のタイトル', 'diary_body' => '日記の本文', 'photo1' => '写真1', 'photo2' => '写真2', 'photo3' => '写真3'); + my %label = ('id' => '日記ID', 'diary_title' => '日記のタイトル', 'diary_body' => '日記の本文', 'photo1' => '写真1', 'photo2' => '写真2', 'photo3' => '写真3', 'post_key' => '送信キー'); my @errors; # データの生成とチェック my %form = map { $_ => $values{$_} } @fields; @@ -1911,7 +2602,6 @@ my %label = ('id' => '日記ID', 'post_key' => '送信キー'); # データの生成とチェック my %form = map {$_ => $values{$_}} @fields; - $form{'id'} = $values{'diary_id'} if (not $form{'id'} and defined($values{'diary_id'})); $form{'id'} = $1 if ($values{'__action__'} and $values{'__action__'} =~ /delete_diary.pl?id=(\d+)/); my @errors = map { "$label{$_}を指定してください。" } grep { not $form{$_} } @required; if (@errors) { @@ -1944,9 +2634,9 @@ my $self = shift; my $time = @_ ? shift : 0; if ($time =~ /^\d+$/) { 1; } - elsif ($time =~ /^(\d+)分/) { $time = $time * 60; } - elsif ($time =~ /^(\d+)時間/) { $time = $time * 60 * 60; } - elsif ($time =~ /^(\d+)日/) { $time = $time * 60 * 60 * 24; } + elsif ($time =~ /^(\d+)分/) { $time = $1 * 60; } + elsif ($time =~ /^(\d+)時間/) { $time = $1 * 60 * 60; } + elsif ($time =~ /^(\d+)日/) { $time = $1 * 60 * 60 * 24; } else { $self->log("[error] ログイン時刻\"$time\"を解析できませんでした。\n"); } $time = time() - $time; my @date = localtime($time); @@ -1975,16 +2665,12 @@ my $mixi = &test_new($mail, $pass, $logger); # オブジェクトの生成 $mixi->test_login; # ログイン $mixi->test_get; # GET(トップページ) - $mixi->test_get_main_menu; # メインメニューの解析 - $mixi->test_get_banner; # バナーの解析 - $mixi->test_get_tool_bar; # ツールバーの解析 - $mixi->test_get_mainly_categories; # 主要データの取得と解析 - $mixi->test_get_mainly_categories_pagelinks; # 主要データの次のページと前のページ - $mixi->test_get_details; # 詳細表示(view_〜など)の取得と解析 + $mixi->test_scenario; # 主要データの取得と解析 $mixi->test_get_add_diary_preview; # 日記のプレビュー $mixi->test_save_and_read_cookies; # Cookieの読み書き # 終了 $mixi->log("終了しました。\n"); + $mixi->dumper_log({'テストレコード' => $mixi->{'__test_record'}, 'テストリンク' => $mixi->{'__test_link'}}); exit 0; } @@ -2080,183 +2766,133 @@ } } -sub test_get_main_menu { - my $mixi = shift; - my $error = ''; - $mixi->log("メインメニューの解析をします。\n"); - my @items = eval '$mixi->get_main_menu()'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not @items) { - $error = "[error] メニュー項目が見つかりませんでした。\n"; - } - if ($error) { - $mixi->log("メインメニューの解析に失敗しました。\n", $error); - $mixi->dumper_log($mixi->response); - exit 8; - } else { - $mixi->dumper_log([@items]); - } -} - -sub test_get_banner { +sub test_record { my $mixi = shift; - my $error = ''; - $mixi->log("バナーの解析をします。\n"); - my @items = eval '$mixi->get_banner()'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not @items) { - $error = "[error] バナーが見つかりませんでした。\n"; - } - if ($error) { - $mixi->log("バナーの解析に失敗しました。\n", $error); - $mixi->dumper_log($mixi->response); - exit 8; + $mixi->{'__test_record'} = {} unless (ref($mixi->{'__test_record'}) eq 'HASH'); + if (@_ == 0) { + return sort { $a cmp $b } (keys(%{$mixi->{'__test_record'}})); + } elsif (@_ == 1) { + my $key = shift; + return $mixi->{'__test_record'}->{$key}; } else { - $mixi->dumper_log([@items]); + my %args = @_; + map { $mixi->{'__test_record'}->{$_} = $args{$_} } keys(%args); + return 1; } } -sub test_get_tool_bar { +sub test_link { my $mixi = shift; - my $error = ''; - $mixi->log("ツールバーの解析をします。\n"); - my @items = eval '$mixi->get_tool_bar()'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not @items) { - $error = "[error] ツールバー項目が見つかりませんでした。\n"; - } - if ($error) { - $mixi->log("ツールバーの解析に失敗しました。\n", $error); - $mixi->dumper_log($mixi->response); - exit 8; + $mixi->{'__test_link'} = {} unless (ref($mixi->{'__test_link'}) eq 'HASH'); + if (@_ == 0) { + return sort { $a cmp $b } (keys(%{$mixi->{'__test_link'}})); + } elsif (@_ == 1) { + my $key = shift; + return $mixi->{'__test_link'}->{$key}; } else { - $mixi->dumper_log([@items]); - } -} - -sub test_get_mainly_categories { - my $mixi = shift; - my %categories = ( - 'calendar' => 'カレンダー', - 'calendar_term' => 'カレンダーの期間', - 'information' => '管理者からのお知らせ', - 'list_bookmark' => 'お気に入り', - 'list_comment' => '最近のコメント', - 'list_community' => 'コミュニティ一覧', - 'list_diary' => '日記', - 'list_diary_capacity' => '日記容量', - 'list_diary_monthly_menu' => '日記月別ページ', - 'list_friend' => '友人・知人一覧', - 'list_message' => '受信メッセージ', - 'list_outbox' => '送信メッセージ', - 'new_album' => 'マイミクシィ最新アルバム', - 'new_bbs' => 'コミュニティ最新書き込み', - 'new_comment' => '日記コメント記入履歴', - 'new_diary' => '新着日記検索', - 'new_friend_diary' => 'マイミクシィ最新日記', - 'new_review' => 'マイミクシィ最新レビュー', - 'self_id' => '自分のID', - 'show_log' => 'あしあと', - 'show_log_count' => 'あしあと数', - ); - foreach my $category (sort(keys(%categories))) { - $mixi->log($categories{$category} . "の取得と解析をします。\n"); - my @opt = ($category eq 'new_diary') ? ('keyword' => 'Mixi') : (); - my @items = eval "\$mixi->get_${category}(\@opt)"; - my $error = ($@) ? $@ : ($mixi->response->is_error) ? $mixi->response->status_line : undef; - if (defined $error) { - $mixi->log("${category}の取得と解析に失敗しました。\n", "[error] $error\n"); - $mixi->dumper_log($mixi->response); - exit 8; - } else { - if (@items) { - $mixi->dumper_log([@items]); - $mixi->{'__test_record'}->{$category} = $items[0]; - } else { - $mixi->log("[warn] レコードが見つかりませんでした。\n"); - $mixi->dumper_log($mixi->response); + my $key = shift; + foreach my $item (grep { ref($_) eq 'HASH' } @_) { + foreach (values(%{$item})) { + foreach my $value (ref($_) eq 'HASH' ? values(%{$_}) : $_) { + next if (ref($value) ne '' or $value =~ /\s/); + next if ($value !~ /^https?:\/\/(?:[^\/]*].)?mixi.jp\/(?:[^\?]*\/)?([^\/\?]+).*$/); + next if ($mixi->{'__test_link'}->{$1}); + $mixi->{'__test_link'}->{$1} = $value; + } } } + return 1; } } -sub test_get_mainly_categories_pagelinks { - my $mixi = shift; - my %categories = ( - 'calendar' => 'カレンダー', - 'list_community' => 'コミュニティ一覧', - 'list_diary' => '日記', - 'list_friend' => '友人・知人一覧', - 'new_bbs' => 'コミュニティ最新書き込み', - 'new_diary' => '新着日記検索', - 'new_friend_diary' => 'マイミクシィ最新日記', - ); - foreach my $category (sort(keys(%categories))) { - my @opt = ($category eq 'new_diary') ? ('keyword' => 'Mixi') : (); - my $error = ''; - $mixi->log($categories{$category} . "の次のページへのリンクの解析をします。\n"); - my $next = eval "\$mixi->get_${category}_next(\@opt)"; - if ($@) { - $error = "[error] $@\n"; - } elsif ($mixi->response->is_error) { - $error = "[error] " . $mixi->response->status_line ."\n"; - } elsif (not $next) { - $mixi->log("[warn] 次のページが見つかりませんでした。\n"); - $mixi->dumper_log($mixi->response); - } else { - $mixi->dumper_log($next); - } - if ($error) { - $mixi->log($error); - $mixi->dumper_log($mixi->response); - exit 8; - } - $mixi->log($categories{$category} . "の前のページへのリンクの解析をします。\n"); - if (not $next) { - $mixi->log("[info] 次のページがなかったため、スキップされました。\n"); - next; - } - my $previous = eval "\$mixi->get_${category}_previous(\$next->{'link'})"; - if ($@) { - $error = "[error] $@\n"; - } elsif ($mixi->response->is_error) { - $error = "[error] " . $mixi->response->status_line ."\n"; - } elsif (not $previous) { - $mixi->log("[warn] 前のページが見つかりませんでした。\n"); - $mixi->dumper_log($mixi->response); - } else { - $mixi->dumper_log($previous); - } - if ($error) { - $mixi->log($error); - $mixi->dumper_log($mixi->response); - exit 8; - } - } -} - -sub test_get_details { +sub test_scenario { my $mixi = shift; - my %methods = ( - 'get_view_diary' => ['list_diary', '日記'], - 'get_view_message' => ['list_message', 'メッセージ'], - 'get_view_message_form' => ['list_message', 'メッセージ返信・削除フォーム'], - 'get_show_show_friend_outline' => ['list_friend', 'プロフィール(概要)'], - 'get_show_show_friend_profile' => ['list_friend', 'プロフィール(詳細)'], + my @tests = ( + # 引数不要のもの + 'main_menu' => {'label' => 'メインメニュー'}, + 'banner' => {'label' => 'バナー'}, + 'tool_bar' => {'label' => 'ツールバー'}, + 'information' => {'label' => '管理者からのお知らせ'}, + 'home_new_album' => {'label' => 'ホームのマイミクシィ最新アルバム'}, + 'home_new_bbs' => {'label' => 'ホームのコミュニティ最新書き込み'}, + 'home_new_comment' => {'label' => 'ホームの日記コメント記入履歴'}, + 'home_new_friend_diary' => {'label' => 'ホームのマイミクシィ最新日記'}, + 'home_new_review' => {'label' => 'ホームのマイミクシィ最新レビュー'}, + 'list_bookmark' => {'label' => 'お気に入り'}, + 'list_comment' => {'label' => '最近のコメント'}, + 'list_community' => {'label' => 'コミュニティ一覧'}, + 'list_community_next' => {'label' => 'コミュニティ一覧(次)'}, + 'list_community_previous' => {'label' => 'コミュニティ一覧(前)', 'url' => sub { return $_[0]->test_record('list_community_next')}}, + 'list_diary' => {'label' => '日記'}, + 'list_diary_capacity' => {'label' => '日記容量'}, + 'list_diary_next' => {'label' => '日記(次)'}, + 'list_diary_previous' => {'label' => '日記(前)', 'url' => sub { return $_[0]->test_record('list_diary_next')}}, + 'list_diary_monthly_menu' => {'label' => '日記月別ページ'}, + 'list_friend' => {'label' => '友人・知人一覧'}, + 'list_friend_next' => {'label' => '友人・知人一覧(次)'}, + 'list_friend_previous' => {'label' => '友人・知人一覧(前)', 'url' => sub { return $_[0]->test_record('list_friend_next')}}, + 'list_message' => {'label' => '受信メッセージ'}, + 'list_outbox' => {'label' => '送信メッセージ'}, + 'list_request' => {'label' => '承認待ちの友人'}, + 'new_album' => {'label' => 'マイミクシィ最新アルバム'}, + 'new_bbs' => {'label' => 'コミュニティ最新書き込み'}, + 'new_bbs_next' => {'label' => 'コミュニティ最新書き込み(次)'}, + 'new_bbs_previous' => {'label' => 'コミュニティ最新書き込み(前)', 'url' => sub { return $_[0]->test_record('new_bbs_next')}}, + 'new_comment' => {'label' => '日記コメント記入履歴'}, + 'new_friend_diary' => {'label' => 'マイミクシィ最新日記'}, + 'new_friend_diary_next' => {'label' => 'マイミクシィ最新日記(次)'}, + 'new_friend_diary_previous' => {'label' => 'マイミクシィ最新日記(前)', 'url' => sub { return $_[0]->test_record('new_friend_diary_next')}}, + 'ajax_new_diary' => {'label' => 'マイミクシィの最新日記(Ajax版)', 'url' => sub { return $_[0]->test_link('ajax_new_diary.pl') }}, + 'new_review' => {'label' => 'マイミクシィ最新レビュー'}, + 'release_info' => {'label' => 'リリースインフォメーション'}, + 'self_id' => {'label' => '自分のID'}, + 'search_diary' => {'label' => '新着日記検索', 'arg' => ['keyword' => 'Mixi']}, + 'search_diary_next' => {'label' => '新着日記検索(次)', 'arg' => ['keyword' => 'Mixi']}, + 'search_diary_previous' => {'label' => '新着日記検索(前)', 'url' => sub { return $_[0]->test_record('search_diary_next')}}, + 'show_calendar' => {'label' => 'カレンダー'}, + 'show_calendar_term' => {'label' => 'カレンダーの期間'}, + 'show_calendar_next' => {'label' => 'カレンダー(次)'}, + 'show_calendar_previous' => {'label' => 'カレンダー(前)', 'url' => sub { return $_[0]->test_record('show_calendar_next')}}, + 'show_intro' => {'label' => 'マイミクシィからの紹介文'}, + 'show_log' => {'label' => 'あしあと'}, + 'show_log_count' => {'label' => 'あしあと数'}, + # コンテンツ + 'view_album' => {'label' => 'フォトアルバム', 'url' => sub { return $_[0]->test_record('new_album')}}, + 'view_album_photo' => {'label' => 'フォトアルバムの写真', 'url' => sub { $_ = $_[0]->test_record('new_album'); return ref($_) eq 'HASH' ? $_->{'link'} : undef }}, + 'view_album_comment' => {'label' => 'フォトアルバムのコメント', 'url' => sub { $_ = $_[0]->test_record('new_album'); return ref($_) eq 'HASH' ? $_->{'link'} . '&mode=comment' : undef }}, + 'view_diary' => {'label' => '日記(詳細)', 'url' => sub { return $_[0]->test_record('list_diary')}}, + 'view_event' => {'label' => 'イベント', 'url' => sub { return $_[0]->test_link('view_event.pl')}}, + 'view_message' => {'label' => 'メッセージ(詳細)', 'url' => sub { return $_[0]->test_record('list_message')}}, + # コミュニティ関連 + 'community_id' => {'label' => 'コミュニティID', 'url' => sub { return $_[0]->test_record('list_community')}}, + 'list_bbs' => {'label' => 'トピック一覧', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, + 'list_bbs_next' => {'label' => 'トピック一覧(次)', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, + 'list_bbs_previous' => {'label' => 'トピック一覧(前)', 'url' => sub { return $_[0]->test_record('list_bbs_next')}}, + 'list_member' => {'label' => 'メンバー一覧', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, + 'list_member_next' => {'label' => 'メンバー一覧(次)', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, + 'list_member_previous' => {'label' => 'メンバー一覧(前)', 'url' => sub { return $_[0]->test_record('list_member_next')}}, + 'view_bbs' => {'label' => 'トピック', 'url' => sub { return $_[0]->test_record('list_bbs')}}, +# 'view_community' => {'label' => 'コミュニティ', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, ); - foreach my $method (sort(keys(%methods))) { - my ($category, $label) = @{$methods{$method}}; - my $item = $mixi->{'__test_record'}->{$category}; - unless ($item) { - $mixi->log("[info] ${label}は対象レコードがないためスキップされました。\n"); - next; + while (@tests >= 2) { + my ($test, $opt) = splice(@tests, 0, 2); + my $method = "get_$test"; + my $label = $opt->{'label'}; + my $url = defined($opt->{'url'}) ? $opt->{'url'} : ''; + if (defined($url) and ref($url) eq 'CODE') { + $url = &{$url}($mixi); + unless ($url) { + $mixi->log("$labelをスキップします。\n", "[warn] 参照レコードなし\n"); + next; + } } - my $link = $item->{'link'}; + $url = $url->{'link'} if (defined($url) and ref($url) eq 'HASH'); + my @arg = (defined($opt->{'arg'}) and ref($opt->{'arg'})) eq 'ARRAY' ? @{$opt->{'arg'}} : (); + @arg = map { ref($_) eq 'CODE' ? &{$_}($mixi) : $_ } @arg; + unshift(@arg, $url) if (defined($url) and ref($url) eq '' and length($url)); $mixi->log("$labelの取得と解析をします。\n"); - my @items = eval "\$mixi->$method(\$link)"; + $mixi->log(qq([info] ターゲットURLは"$url"です。\n)); + my @items = eval { $mixi->$method(@arg); }; my $error = ($@) ? $@ : ($mixi->response->is_error) ? $mixi->response->status_line : undef; if (defined $error) { $mixi->log("$labelの取得と解析に失敗しました。\n", "[error] $error\n"); @@ -2265,8 +2901,11 @@ } else { if (@items) { $mixi->dumper_log([@items]); + $mixi->test_link($test => @items); + $mixi->test_record($test => $items[0]); + $mixi->test_record($test => {'link' => 'http://mixi.jp/view_album.pl?id=150828'}) if ($test eq 'new_album'); } else { - $mixi->log("[info] レコードが見つかりませんでした。\n"); + $mixi->log("[warn] レコードが見つかりませんでした。\n"); $mixi->dumper_log($mixi->response); } } @@ -2339,7 +2978,7 @@ require WWW::RobotRules; @ISA = qw(WWW::RobotRules::InCore); -$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/); sub allowed { return 1; From higefuku @ users.sourceforge.jp Thu Oct 20 01:13:09 2005 From: higefuku @ users.sourceforge.jp (Yoshihisa Fukuhara) Date: Thu, 20 Oct 2005 01:13:09 +0900 Subject: [Affelio-cvs 587] CVS update: affelio/apps/album Message-ID: <20051019161309.D02DA2AC044@users.sourceforge.jp> Index: affelio/apps/album/AF_app.cfg diff -u affelio/apps/album/AF_app.cfg:1.5 affelio/apps/album/AF_app.cfg:1.6 --- affelio/apps/album/AF_app.cfg:1.5 Thu Aug 25 00:31:44 2005 +++ affelio/apps/album/AF_app.cfg Thu Oct 20 01:13:09 2005 @@ -4,10 +4,10 @@ [application] app_name=album app_version=1.3 -app_desc=??????? +app_desc=??????????? app_author=Affelio project guest_index=index.cgi owner_index=owner.cgi action_types=add_image, write_comment -action_types_desc=????,????????+action_types_desc=?糸??脂?,?潟??潟??吾?莨若? From slash5234 @ users.sourceforge.jp Mon Oct 24 17:51:03 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:51:03 +0900 Subject: [Affelio-cvs 588] CVS update: affelio/config Message-ID: <20051024085103.0DE142AC06E@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:49 +0900 Subject: [Affelio-cvs 589] CVS update: affelio Message-ID: <20051024085249.453392AC06E@users.sourceforge.jp> Index: affelio/admin.cgi diff -u affelio/admin.cgi:1.28 affelio/admin.cgi:1.29 --- affelio/admin.cgi:1.28 Mon Jul 4 01:16:31 2005 +++ affelio/admin.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: admin.cgi,v 1.28 2005/07/03 16:16:31 slash5234 Exp $ +# $Id: admin.cgi,v 1.29 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -43,7 +43,7 @@ ############################################################################ debug_print("admin.cgi: start."); -my $cfg_dir = "."; +my $cfg_dir = "./config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/incoming.cgi diff -u affelio/incoming.cgi:1.7 affelio/incoming.cgi:1.8 --- affelio/incoming.cgi:1.7 Sun Jul 3 22:42:05 2005 +++ affelio/incoming.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: incoming.cgi,v 1.7 2005/07/03 13:42:05 slash5234 Exp $ +# $Id: incoming.cgi,v 1.8 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -44,7 +44,7 @@ ############################################################################ #Load Affelio, CGI ############################################################################ -my $cfg_dir = "."; +my $cfg_dir = "./config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/index.cgi diff -u affelio/index.cgi:1.13 affelio/index.cgi:1.14 --- affelio/index.cgi:1.13 Sun Jul 3 22:20:06 2005 +++ affelio/index.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: index.cgi,v 1.13 2005/07/03 13:20:06 slash5234 Exp $ +# $Id: index.cgi,v 1.14 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -44,7 +44,7 @@ #Load Affelio ############################################################################ my $wi = new Affelio::misc::WebInput(); -my $cfg_dir = "./"; +my $cfg_dir = "./config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/outgoing.cgi diff -u affelio/outgoing.cgi:1.6 affelio/outgoing.cgi:1.7 --- affelio/outgoing.cgi:1.6 Fri Jul 1 17:19:41 2005 +++ affelio/outgoing.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: outgoing.cgi,v 1.6 2005/07/01 08:19:41 slash5234 Exp $ +# $Id: outgoing.cgi,v 1.7 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -44,7 +44,7 @@ ############################################################################ #Load Affelio ############################################################################ -my $cfg_dir = "."; +my $cfg_dir = "./config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/setup.cgi diff -u affelio/setup.cgi:1.13 affelio/setup.cgi:1.14 --- affelio/setup.cgi:1.13 Tue Jul 12 03:01:42 2005 +++ affelio/setup.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: setup.cgi,v 1.13 2005/07/11 18:01:42 slash5234 Exp $ +# $Id: setup.cgi,v 1.14 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -239,15 +239,8 @@ sub check_100{ my $err_msg=""; - if(! -e "affelio.cfg"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err1"); - }else{ - if(! -r "affelio.cfg"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err2"); - } - if(! -w "affelio.cfg"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err3"); - } + if(! -w "config"){ + $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "config"); } if(! -w "userdata"){ $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "userdata"); @@ -325,7 +318,7 @@ return $err_msg; } - open(OUT, "> affelio.cfg"); + open(OUT, "> $g_fsroot/config/affelio.cfg"); print OUT "[site_config]\n"; print OUT "fs_root=$g_fsroot\n"; print OUT "web_root=$g_webroot\n"; @@ -336,7 +329,8 @@ print OUT "sendmail=$sendmail_path\n"; close OUT; - chmod 0444, 'affelio.cfg'; + chmod 0444, "$g_fsroot/config/affelio.cfg"; + chmod 0700, "$g_fsroot/config"; return(""); } @@ -499,7 +493,7 @@ ########################################################## #Load Affelio ########################################################## - my $cfg_dir = "."; + my $cfg_dir = "./config/"; my $af; my $dbh; try{ @@ -549,7 +543,7 @@ or error($cgi, "Check400-15: Cannot prepare SQL statement: $@"); try{ - open(FIN, "$cfg_dir/defaults/AFuser_CORE_prof_attr.csv") + open(FIN, "defaults/AFuser_CORE_prof_attr.csv") or error($cgi, "Check400-16: Cannot open default prof attr.: $@"); while(my $line=){ From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:49 +0900 Subject: [Affelio-cvs 590] CVS update: affelio/bin Message-ID: <20051024085249.6A3D52AC071@users.sourceforge.jp> Index: affelio/bin/get_content.cgi diff -u affelio/bin/get_content.cgi:1.21 affelio/bin/get_content.cgi:1.22 --- affelio/bin/get_content.cgi:1.21 Sun Jul 3 04:16:51 2005 +++ affelio/bin/get_content.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: get_content.cgi,v 1.21 2005/07/02 19:16:51 slash5234 Exp $ +# $Id: get_content.cgi,v 1.22 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -46,7 +46,7 @@ #Load Affelio and CGI ############################################################################ my $q = new CGI; -my $cfg_dir = ".."; +my $cfg_dir = "../config/"; my $af = new Affelio(ConfigDir => $cfg_dir); debug_print("get_content.cgi: AF loaded."); my $wi = new Affelio::misc::WebInput(); Index: affelio/bin/loginexec.cgi diff -u affelio/bin/loginexec.cgi:1.5 affelio/bin/loginexec.cgi:1.6 --- affelio/bin/loginexec.cgi:1.5 Fri Jul 1 17:19:41 2005 +++ affelio/bin/loginexec.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: loginexec.cgi,v 1.5 2005/07/01 08:19:41 slash5234 Exp $ +# $Id: loginexec.cgi,v 1.6 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -43,7 +43,7 @@ ############################################################################ #Load Affelio ############################################################################ -my $cfg_dir = ".."; +my $cfg_dir = "../config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/bin/logoutexec.cgi diff -u affelio/bin/logoutexec.cgi:1.4 affelio/bin/logoutexec.cgi:1.5 --- affelio/bin/logoutexec.cgi:1.4 Fri Jul 1 17:19:41 2005 +++ affelio/bin/logoutexec.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: logoutexec.cgi,v 1.4 2005/07/01 08:19:41 slash5234 Exp $ +# $Id: logoutexec.cgi,v 1.5 2005/10/24 08:52:49 slash5234 Exp $ use strict; @@ -41,7 +41,7 @@ ############################################################################ #Load Affelio ############################################################################ -my $cfg_dir = ".."; +my $cfg_dir = "../config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/bin/recv_mail_ack.cgi diff -u affelio/bin/recv_mail_ack.cgi:1.7 affelio/bin/recv_mail_ack.cgi:1.8 --- affelio/bin/recv_mail_ack.cgi:1.7 Fri Jul 1 17:19:41 2005 +++ affelio/bin/recv_mail_ack.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: recv_mail_ack.cgi,v 1.7 2005/07/01 08:19:41 slash5234 Exp $ +# $Id: recv_mail_ack.cgi,v 1.8 2005/10/24 08:52:49 slash5234 Exp $ use strict; use lib("../extlib"); @@ -45,7 +45,7 @@ ############################################################################ #Load Affelio -my $cfg_dir = ".."; +my $cfg_dir = "../config/"; my $af; try{ $af = new Affelio(ConfigDir => $cfg_dir); Index: affelio/bin/send_handshake.cgi diff -u affelio/bin/send_handshake.cgi:1.4 affelio/bin/send_handshake.cgi:1.5 --- affelio/bin/send_handshake.cgi:1.4 Fri Jul 1 10:49:01 2005 +++ affelio/bin/send_handshake.cgi Mon Oct 24 17:52:49 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: send_handshake.cgi,v 1.4 2005/07/01 01:49:01 slash5234 Exp $ +# $Id: send_handshake.cgi,v 1.5 2005/10/24 08:52:49 slash5234 Exp $ use strict; use lib("../extlib"); @@ -42,7 +42,7 @@ ############################################################################ #Load Affelio -my $cfg_dir = ".."; +my $cfg_dir = "../config/"; my $af = new Affelio(ConfigDir => $cfg_dir); ############################################################################ From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:49 +0900 Subject: [Affelio-cvs 591] CVS update: affelio/config Message-ID: <20051024085249.88A9C2AC06E@users.sourceforge.jp> Index: affelio/config/.htaccess diff -u /dev/null affelio/config/.htaccess:1.1 --- /dev/null Mon Oct 24 17:52:49 2005 +++ affelio/config/.htaccess Mon Oct 24 17:52:49 2005 @@ -0,0 +1,8 @@ +AuthUserFile /dev/null +AuthGroupFile /dev/null +AuthType Basic + + +order deny,allow +deny from all + From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:49 +0900 Subject: [Affelio-cvs 592] CVS update: affelio/lib Message-ID: <20051024085249.AA6E62AC071@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.18 affelio/lib/Affelio.pm:1.19 --- affelio/lib/Affelio.pm:1.18 Fri Jul 1 17:19:42 2005 +++ affelio/lib/Affelio.pm Mon Oct 24 17:52:49 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.18 2005/07/01 08:19:42 slash5234 Exp $ +# $Id: Affelio.pm,v 1.19 2005/10/24 08:52:49 slash5234 Exp $ package Affelio; { @@ -58,6 +58,8 @@ #cfg_path Configuration file's path #cfg_dir Configuration file's directory + my $top_dir = $param{ConfigDir} . "/../"; + ################################### #Mode ################################### @@ -111,6 +113,7 @@ ################################### my $self = {cfg_path => $cfg_path, cfg_dir => $cfg_dir, + top_dir => $top_dir, lh => $lh, db => $db, pm => $pm, @@ -478,12 +481,12 @@ #Determine userdata/..../ directory my $dir; eval{ - opendir(DIR, "$self->{cfg_dir}/userdata"); + opendir(DIR, "$self->{top_dir}/userdata"); while (defined($dir = readdir(DIR))) { if(($dir ne '.') && ($dir ne '..') && ($dir ne 'default') && ($dir ne 'CVS')){ $self->{site__user_dir} = - $wi->PTN_dirname("$self->{cfg_dir}/userdata/$dir"); + $wi->PTN_dirname("$self->{top_dir}/userdata/$dir"); } } }; @@ -503,7 +506,7 @@ $self->{site__password} = $Config2->{auth}->{password}; #Determine session/..../ directory - $self->{site__session_dir} = $wi->PTN_dirname("$self->{cfg_dir}/session"); + $self->{site__session_dir} = $wi->PTN_dirname("$self->{top_dir}/session"); debug_print("Affelio::read_site_config: session_dir = [$self->{site__session_dir}]"); debug_print("Affelio::read_site_config: end."); } Index: affelio/lib/AffelioApp.pm diff -u affelio/lib/AffelioApp.pm:1.11 affelio/lib/AffelioApp.pm:1.12 --- affelio/lib/AffelioApp.pm:1.11 Wed Jul 6 08:18:21 2005 +++ affelio/lib/AffelioApp.pm Mon Oct 24 17:52:49 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: AffelioApp.pm,v 1.11 2005/07/05 23:18:21 slash5234 Exp $ +# $Id: AffelioApp.pm,v 1.12 2005/10/24 08:52:49 slash5234 Exp $ package AffelioApp; { @@ -62,7 +62,7 @@ ############################ #Load Affelio ############################ - my $af = new Affelio(ConfigDir => "$app__fs_root/../../", + my $af = new Affelio(ConfigDir => "$app__fs_root/../../config/", Caller => $install_name); ############################ From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:49 +0900 Subject: [Affelio-cvs 593] CVS update: affelio/lib/Affelio/Managing Message-ID: <20051024085249.C960F2AC072@users.sourceforge.jp> Index: affelio/lib/Affelio/Managing/ApplicationManager.pm diff -u affelio/lib/Affelio/Managing/ApplicationManager.pm:1.7 affelio/lib/Affelio/Managing/ApplicationManager.pm:1.8 --- affelio/lib/Affelio/Managing/ApplicationManager.pm:1.7 Fri Jul 1 11:00:08 2005 +++ affelio/lib/Affelio/Managing/ApplicationManager.pm Mon Oct 24 17:52:49 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ApplicationManager.pm,v 1.7 2005/07/01 02:00:08 slash5234 Exp $ +# $Id: ApplicationManager.pm,v 1.8 2005/10/24 08:52:49 slash5234 Exp $ package Affelio::Managing::ApplicationManager; { @@ -291,7 +291,7 @@ my $af = $self->{af}; my $app_dir; - opendir(DIR, "$af->{cfg_dir}/apps"); + opendir(DIR, "$af->{top_dir}/apps"); while (defined($app_dir = readdir(DIR))) { if( ($app_dir ne '.') && ($app_dir ne '..') @@ -308,7 +308,7 @@ ################################## #Open a config file ################################## - my $cfg = new Config::IniFiles( -file => "$af->{cfg_dir}/apps/$app_dir/AF_app.cfg" ); + my $cfg = new Config::IniFiles( -file => "$af->{top_dir}/apps/$app_dir/AF_app.cfg" ); if(!$cfg){ next; } my %this_app=(); From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:49 +0900 Subject: [Affelio-cvs 594] CVS update: affelio/lib/Affelio/SNS Message-ID: <20051024085249.EB37B2AC06E@users.sourceforge.jp> Index: affelio/lib/Affelio/SNS/Handshaker_s.pm diff -u affelio/lib/Affelio/SNS/Handshaker_s.pm:1.20 affelio/lib/Affelio/SNS/Handshaker_s.pm:1.21 --- affelio/lib/Affelio/SNS/Handshaker_s.pm:1.20 Sun Jul 3 20:42:51 2005 +++ affelio/lib/Affelio/SNS/Handshaker_s.pm Mon Oct 24 17:52:49 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Handshaker_s.pm,v 1.20 2005/07/03 11:42:51 slash5234 Exp $ +# $Id: Handshaker_s.pm,v 1.21 2005/10/24 08:52:49 slash5234 Exp $ use strict; use lib("../../../extlib/"); @@ -41,7 +41,7 @@ package Affelio::SNS::Handshaker_s::Util; { sub af_new { - my $cfg_dir = $Affelio::SNS::Handshaker_s::AF_DIR; + my $cfg_dir = $Affelio::SNS::Handshaker_s::AF_DIR . "config/"; Affelio::misc::Debug::debug_print("Starting AF($cfg_dir)..."); my $af = Affelio->new( ConfigDir => $cfg_dir ) or die "Cannot start Affelio"; From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:50 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:50 +0900 Subject: [Affelio-cvs 595] CVS update: affelio/lib/Affelio/misc/L10N Message-ID: <20051024085250.1ED212AC071@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/L10N/en_us.pm diff -u affelio/lib/Affelio/misc/L10N/en_us.pm:1.17 affelio/lib/Affelio/misc/L10N/en_us.pm:1.18 --- affelio/lib/Affelio/misc/L10N/en_us.pm:1.17 Fri Jul 8 07:23:31 2005 +++ affelio/lib/Affelio/misc/L10N/en_us.pm Mon Oct 24 17:52:49 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: en_us.pm,v 1.17 2005/07/07 22:23:31 shimaron Exp $ +# $Id: en_us.pm,v 1.18 2005/10/24 08:52:49 slash5234 Exp $ package Affelio::misc::L10N::en_us; { @@ -54,7 +54,7 @@ # '_SETUP_title_100' => 'Configuration File', - '_SETUP_msg_100' => 'On your web server, create a file named "affeio.cfg" with writable file permission (example: 666) in the same directory as "stup.cgi"

Also, set permission writable (example: 700 or 777) for the following directories.

  • userdata/
  • session/
  • skins/
  • templates_dyn/
      ', + '_SETUP_msg_100' => 'On your web server, set permission writable (example: 700 or 777) for the following directories.
      • config/
      • userdata/
      • session/
      • skins/
      • templates_dyn/
          ', '_SETUP_check_100_err1' => '
        • "affelio.cfg" not found.
          On your web server, create a file named "affeio.cfg" with writable file permission (example: 666) in the same directory as "stup.cgi"', '_SETUP_check_100_err2' => '
        • "affelio.cfg" is not readable.
          Set permission of "affelio.cfg" redable (example: 666).', Index: affelio/lib/Affelio/misc/L10N/ja.pm diff -u affelio/lib/Affelio/misc/L10N/ja.pm:1.24 affelio/lib/Affelio/misc/L10N/ja.pm:1.25 --- affelio/lib/Affelio/misc/L10N/ja.pm:1.24 Mon Jul 4 10:46:17 2005 +++ affelio/lib/Affelio/misc/L10N/ja.pm Mon Oct 24 17:52:49 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ja.pm,v 1.24 2005/07/04 01:46:17 slash5234 Exp $ +# $Id: ja.pm,v 1.25 2005/10/24 08:52:49 slash5234 Exp $ package Affelio::misc::L10N::ja; { @@ -60,7 +60,7 @@ # '_SETUP_title_100' => '荐??????ゃ??????, - '_SETUP_msg_100' => 'Web?泣????筝????etup.cgi???????c?????????ffelio.cfg?????????????ゃ????茯???吾????????若?????с?荐??(666???)?т?????????????

          ?障???札筝????????????????????????????昭?水??????若?????с? (777, 700???) ??┃絎???????????

          • userdata/
          • session/
          • skins/
          • templates_dyn/
          ', + '_SETUP_msg_100' => '篁ヤ???????????c????????≪?????吾?莨若????????若?????с? (777, 700???) ??┃絎???????????
          • config/
          • userdata/
          • session/
          • skins/
          • templates_dyn/
          ', '_SETUP_check_100_err1' => '
        • affelio.cfg???????????BR>setup.cgi???????c??????????affelio.cfg?????????腥冴??<????????炊???????ermission?т?????????????', '_SETUP_check_100_err2' => '
        • CGI???affelio.cfg???絎鴻?茯??莨若??障????
          茯???吾????????若?????с???┃絎???????????', '_SETUP_check_100_err3' => '
        • CGI???affelio.cfg?御???昭????????BR>茯???吾????????若?????с???┃絎???????????', From slash5234 @ users.sourceforge.jp Mon Oct 24 17:52:50 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 17:52:50 +0900 Subject: [Affelio-cvs 596] CVS update: affelio/userdata Message-ID: <20051024085250.3CD642AC06E@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Mon Oct 24 20:37:26 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 20:37:26 +0900 Subject: [Affelio-cvs 593] CVS update: affelio Message-ID: <20051024113726.CA4E82AC013@users.sourceforge.jp> Index: affelio/setup.cgi diff -u affelio/setup.cgi:1.14 affelio/setup.cgi:1.15 --- affelio/setup.cgi:1.14 Mon Oct 24 17:52:49 2005 +++ affelio/setup.cgi Mon Oct 24 20:37:26 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: setup.cgi,v 1.14 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: setup.cgi,v 1.15 2005/10/24 11:37:26 slash5234 Exp $ use strict; @@ -34,6 +34,7 @@ use Affelio::misc::CGIError; use Affelio::misc::MyCrypt; use Affelio::misc::L10N; +use Affelio::misc::InitAffelio; use Affelio::misc::Debug qw(debug_print); ############################################################################ @@ -271,12 +272,7 @@ } #make userdata/xxxxx session/yyyy directories - srand(time ^ ($$ + ($$ << 15))); - #userdata - my $dir1 = Affelio::misc::MyCrypt::generate_password(); - mkdir("userdata/$dir1", 0777); - my $dir2 = Affelio::misc::MyCrypt::generate_password(); - mkdir("session/$dir2", 0777); + Affelio::misc::InitAffelio::create_userdir("./"); return(""); } @@ -318,20 +314,14 @@ return $err_msg; } - open(OUT, "> $g_fsroot/config/affelio.cfg"); - print OUT "[site_config]\n"; - print OUT "fs_root=$g_fsroot\n"; - print OUT "web_root=$g_webroot\n"; - print OUT "char_set =$g_locale\n"; - print OUT "template =default\n"; - print OUT "\n"; - print OUT "[command]\n"; - print OUT "sendmail=$sendmail_path\n"; - close OUT; + Affelio::misc::InitAffelio::create_af_cfg("$g_fsroot/config/affelio.cfg", + $g_fsroot, + $g_webroot, + $g_locale, + "default", + $sendmail_path); - chmod 0444, "$g_fsroot/config/affelio.cfg"; chmod 0700, "$g_fsroot/config"; - return(""); } @@ -370,49 +360,30 @@ } } - my $userdata_dir=""; - my $dir; - try{ - opendir(DIR, "./userdata"); - }catch Error with{ - my $e = shift; - error $cgi, "Error in check350: $e"; - }; - while (defined($dir = readdir(DIR))) { - if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS')){ - $userdata_dir = "./userdata/$dir"; - } - } - try{ - closedir(DIR); + #determine userdata/xxx/ directory + my $userdata_dir = ""; + try{ + $userdata_dir = Affelio::misc::InitAffelio::get_userdir("./userdata"); }catch Error with{ my $e = shift; error $cgi, "Error in check350: $e"; }; - #Generate login.cfg file + debug_print("check_350: userdata dir = [$userdata_dir]"); + + #Generate db.cfg file try{ - open(OUT, "> $userdata_dir/db.cfg"); + Affelio::misc::InitAffelio::create_db_cfg("$userdata_dir/db.cfg", + $db_type, + $db_dbname, + $db_username, + $db_password, + $db_hostname, + $db_port); }catch Error with{ my $e = shift; error $cgi, "Error in check350: $e"; }; - print OUT "[db]\n"; - print OUT "type=$db_type\n"; - print OUT "dbname=$db_dbname\n"; - print OUT "username=$db_username\n"; - print OUT "password=$db_password\n"; - print OUT "hostname=$db_hostname\n"; - print OUT "port=$db_port\n"; - print OUT "[appdb]\n"; - print OUT "type=$db_type\n"; - print OUT "dbname=$db_dbname\n"; - print OUT "username=$db_username\n"; - print OUT "password=$db_password\n"; - print OUT "hostname=$db_hostname\n"; - print OUT "port=$db_port\n"; - close OUT; return(""); } @@ -447,313 +418,70 @@ ########################################################## #Determine userdata/..../ directory ########################################################## - my $userdata_dir=""; - my $dir; - try{ - opendir(DIR, "./userdata") - or error($cgi, "Check400-2: cannot open userdata: $@"); - while (defined($dir = readdir(DIR))) { - if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS')){ - $userdata_dir = "./userdata/$dir"; - } - } - closedir(DIR) - or error($cgi, "Check400-3: cannot close userdata: $@"); + #determine userdata/xxx/ directory + my $userdata_dir = ""; + try{ + $userdata_dir = Affelio::misc::InitAffelio::get_userdir("./userdata"); }catch Error with{ my $e = shift; - error($cgi, "Check400-4: $e"); + error $cgi, "Error in check400-2: $e"; }; ########################################################## - #Copy files + #Create login.cfg ########################################################## try{ - #Copy default face JPEG file - system("cp -f defaults/profile_face.jpg $userdata_dir/profile_face.jpg"); - system("chmod 666 $userdata_dir/profile_face.jpg"); - - #Copy default preference file - system("cp -f defaults/preference.cfg $userdata_dir/preference.cfg"); - - #Generate login.cfg file - open(OUT, "> $userdata_dir/login.cfg") - or error($cgi, "Check400-8: cannot open login.cfg for W: $@"); - print OUT "[auth]\n"; - print OUT "username=$g_username\n"; - print OUT "password=$g_crypted_password\n"; - close OUT - or error($cgi, "Check400-9: cannot close login.cfg: $@"); - + Affelio::misc::InitAffelio::create_login_cfg("$userdata_dir/login.cfg", + $g_username, + $g_crypted_password); }catch Error with{ my $e = shift; - error($cgi, "Check400-10: $e"); + error $cgi, "Error in check400-8: $e"; }; ########################################################## - #Load Affelio + #Copy default files to user directory ########################################################## - my $cfg_dir = "./config/"; - my $af; - my $dbh; try{ - $af = new Affelio(ConfigDir => $cfg_dir, - Mode => "init"); - $dbh = $af->{db}; + Affelio::misc::InitAffelio::copy_def_files(".", + $userdata_dir, + $g_locale); }catch Error with{ my $e = shift; - error($cgi, "Check400-11: Cannot load Affelio: $e"); + error($cgi, "Error in copying default files: $e"); }; ########################################################## - #Database initialization + #DB initialization ########################################################## - - ################################ - #profile DB - ################################ - my $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-12: Cannot create prof table: $@"); - } - - $af->{user__nickname} = $g_nickname; - $af->{user__email1} = $g_email; try{ - $af->{pm}->save_profile(); + Affelio::misc::InitAffelio::init_db(".", + $g_nickname, + $g_email, + $g_lh); }catch Error with{ my $e = shift; - error($cgi, "Check400-13: Cannot save_profile: $@"); + error($cgi, "Error in init_db: $e"); }; - debug_print("saved profile"); - - ################################ - #profile attribute DB - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-14: Cannot create attr table: $@"); - } - - my $sth = $dbh->prepare(q{insert into AFuser_CORE_prof_attr(aid, name, type) values (?,?,?)}) - or error($cgi, "Check400-15: Cannot prepare SQL statement: $@"); - try{ - open(FIN, "defaults/AFuser_CORE_prof_attr.csv") - or error($cgi, "Check400-16: Cannot open default prof attr.: $@"); - - while(my $line=){ - chomp($line); - my ($aid, $name, $type) = split(',', $line); - #print "$aid - $name - $type\n"; - - $sth->execute($aid, $name, $type) - or error($cgi, "Check400-17: Cannot execute SQL: $@"); - } - close(FIN); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-18: $e"; - }; - - ################################ - #friends DB - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-19: cannot create friends table: $@"); - } - - ################################ - #erasedfriends DB - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-20: cannot create erased friends table: $@"); - } - - ################################ - #friendsfriends DB - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-21: cannot create F2 table: $@"); - } - - ################################ - #group DB - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-22: cannot create group table: $@"); - } - - ################################ - #Permission DB - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-23: cannot create permission table: $@"); - } - - ################################ - #tmp_recvd_hs - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-24: cannot create tmp_recvd table: $@"); - } - - ################################ - #tmp_sent_hs - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-25: cannot create tmp_sent table: $@"); - } - - ################################ - #message - ################################ - $create_tbl_cmd = <do($create_tbl_cmd)){ - error($cgi, "Check400-26: cannot create message table: $@"); - } - - try{ - $dbh->disconnect; - }catch Error with{ - my $e = shift; - error $cgi, "Check400-28: db disconnect : $e"; - }; - - ########################################################## - #Setting Initial Values ... ########################################################## - try{ - undef($af); - $af = new Affelio(ConfigDir => $cfg_dir); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-29: Affelio load error : $e"; - }; - - ################################ - #Set permission to F1 - ################################ - # n names b i intro email url im - my @flag_array = (1,1,1,1, 1,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); - try{ - $af->{perm}->add_permission("f", "f1", \@flag_array); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-30: $e"; - }; - - ################################ - #Set permission to F2 - ################################ - # n names b i intro email url im - my @flag_array = (1,0,0,0, 0,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); - try{ - $af->{perm}->add_permission("f", "f2", \@flag_array); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-31: $e"; - }; - - ################################ - #Set permission to PB - ################################ - # n names b i intro email url im - my @flag_array = (1,0,0,0, 0,0, 1,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,0,0, 0); - try{ - $af->{perm}->add_permission("f", "pb", \@flag_array); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-32: $e"; - }; - - ################################ - #Make a new group "dear_friend" - ################################ - my $gid; - try{ - $gid = $af->{gm}->add_group($g_lh->maketext("_SETUP_group_dear_friend")); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-33: $e"; - }; - - ##################################### - #Set permission to group "dear_friend" - ##################################### - # n names b i intro email url im - my @flag_array = (1,1,1,1, 1,1, 1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1,1,1, 1); - try{ - $af->{perm}->add_permission("g", $gid, \@flag_array); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-34: $e"; - }; - - ########################################################## - #Others... - ########################################################## - - ################################ - #Copy default template files - ################################ - try{ - system("cp -fr defaults/af_templates/$g_locale ./$af->{site__user_dir}/af_templates"); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-35: $e"; - }; - - ################################ #Rebuild templates_dyn - ################################ + ########################################################## use Affelio::App::Admin::EditTemplates qw(rebuild); + my $af; try{ + $af = new Affelio(ConfigDir => "./config/"); Affelio::App::Admin::EditTemplates::rebuild($af); }catch Error with{ my $e = shift; error $cgi, "Check400-36: Template rebuild error: $e"; }; - ################################ - #Finally, "chmod" - ################################ + ########################################################## + #Check and set data directory permission + ########################################################## try{ - system("chmod -R 777 ./$af->{site__user_dir}"); + Affelio::misc::InitAffelio::set_datadir_perm("."); }catch Error with{ my $e = shift; error $cgi, "Check400-37: $e"; From slash5234 @ users.sourceforge.jp Mon Oct 24 20:37:26 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 20:37:26 +0900 Subject: [Affelio-cvs 594] CVS update: affelio/lib Message-ID: <20051024113726.EFE002AC020@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.19 affelio/lib/Affelio.pm:1.20 --- affelio/lib/Affelio.pm:1.19 Mon Oct 24 17:52:49 2005 +++ affelio/lib/Affelio.pm Mon Oct 24 20:37:26 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.19 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: Affelio.pm,v 1.20 2005/10/24 11:37:26 slash5234 Exp $ package Affelio; { @@ -457,8 +457,6 @@ throw Affelio::exception::SystemException("affelio.cfg not found"); } - #print "$self->{cfg_path}\n"; - my $rootproperty = $Config->{_}->{rootproperty}; $self->{site__fs_root} = $Config->{site_config}->{fs_root}; $self->{site__web_root} = $Config->{site_config}->{web_root}; @@ -484,7 +482,8 @@ opendir(DIR, "$self->{top_dir}/userdata"); while (defined($dir = readdir(DIR))) { if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS')){ + && ($dir ne 'default') && ($dir ne 'CVS') + && ($dir ne 'index.html')){ $self->{site__user_dir} = $wi->PTN_dirname("$self->{top_dir}/userdata/$dir"); } From slash5234 @ users.sourceforge.jp Mon Oct 24 20:37:27 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 20:37:27 +0900 Subject: [Affelio-cvs 595] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024113727.18DB62AC013@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u /dev/null affelio/lib/Affelio/misc/InitAffelio.pm:1.1 --- /dev/null Mon Oct 24 20:37:27 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Mon Oct 24 20:37:26 2005 @@ -0,0 +1,414 @@ +# Copyright (C) 2005 FishGrove Inc. +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# 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. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# $Id: InitAffelio.pm,v 1.1 2005/10/24 11:37:26 slash5234 Exp $ + +package Affelio::misc::InitAffelio; +{ + use strict; + use Exporter; + @Affelio::misc::InitAffelio::ISA = "Exporter"; + @Affelio::misc::InitAffelio::EXPORT = qw (create_userdir get_userdir create_af_cfg create_db_cfg create_login_cfg copy_def_files init_db set_datadir_perm); + + use lib("../../../extlib/"); + use Error qw(:try); + use lib("."); + use lib("../../../lib/"); + use Affelio; + use Affelio::misc::CGIError; + use Affelio::misc::Debug; + use Affelio::exception::Exception; + use Affelio::exception::DBException; + use Affelio::exception::IOException; + + ##################################################################### + sub create_userdir{ + my $topdir = shift; + + srand(time ^ ($$ + ($$ << 15))); + #userdata + my $dir1 = Affelio::misc::MyCrypt::generate_password(); + mkdir("$topdir/userdata/$dir1", 0777); + my $dir2 = Affelio::misc::MyCrypt::generate_password(); + mkdir("$topdir/session/$dir2", 0777); + } + + ##################################################################### + sub get_userdir{ + my $userdata_dir = shift; + + my $dir; + my $ret; + try{ + opendir(DIR, $userdata_dir); + + while (defined($dir = readdir(DIR))) { + if(($dir ne '.') && ($dir ne '..') + && ($dir ne 'default') && ($dir ne 'CVS') + && ($dir ne 'index.html')){ + $ret = "$userdata_dir/$dir"; + } + } + }catch Error with{ + my $e=shift; + throw($e); + }; + return($ret); + } + + ##################################################################### + sub create_af_cfg{ + my $affelio_cfg_path = shift; + my $fs_root = shift; + my $web_root = shift; + my $char_set = shift; + my $template = shift; + my $sendmail_path = shift; + + eval{ + open(OUT, "> $affelio_cfg_path"); + print OUT "[site_config]\n"; + print OUT "fs_root=$fs_root\n"; + print OUT "web_root=$web_root\n"; + print OUT "char_set =$char_set\n"; + print OUT "template =$template\n"; + print OUT "\n"; + print OUT "[command]\n"; + print OUT "sendmail=$sendmail_path\n"; + close OUT; + + chmod 0444, "$affelio_cfg_path"; + }; + + + } + + ##################################################################### + sub create_db_cfg{ + my $db_cfg_path = shift; + my $db_type = shift; + my $db_dbname=shift; + my $db_username = shift; + my $db_password = shift; + my $db_hostname = shift; + my $db_port = shift; + + eval{ + open(OUT, "> $db_cfg_path"); + print OUT "[db]\n"; + print OUT "type=$db_type\n"; + print OUT "dbname=$db_dbname\n"; + print OUT "username=$db_username\n"; + print OUT "password=$db_password\n"; + print OUT "hostname=$db_hostname\n"; + print OUT "port=$db_port\n"; + print OUT "[appdb]\n"; + print OUT "type=$db_type\n"; + print OUT "dbname=$db_dbname\n"; + print OUT "username=$db_username\n"; + print OUT "password=$db_password\n"; + print OUT "hostname=$db_hostname\n"; + print OUT "port=$db_port\n"; + close OUT; + }; + } + + ##################################################################### + sub create_login_cfg{ + my $login_cfg_path = shift; + my $username = shift; + my $crypted_password = shift; + + eval{ + open(OUT, "> $login_cfg_path"); + print OUT "[auth]\n"; + print OUT "username=$username\n"; + print OUT "password=$crypted_password\n"; + close OUT; + }; + } + + ##################################################################### + sub copy_def_files{ + my $top_dir=shift; + my $user_dir=shift; + my $locale = shift; + + #Copy default face JPEG file + system("cp -f $top_dir/defaults/profile_face.jpg $user_dir/profile_face.jpg"); + system("chmod 666 $user_dir/profile_face.jpg"); + + #Copy default preference file + system("cp -f $top_dir/defaults/preference.cfg $user_dir/preference.cfg"); + + system("cp -fr $top_dir/defaults/af_templates/$locale $user_dir/af_templates"); + } + + ##################################################################### + sub init_db{ + my $top_dir = shift; + my $g_nickname = shift; + my $g_email =shift; + my $g_lh=shift; + + debug_print("init_db: [$top_dir] [$g_nickname] [$g_email]"); + + ################################################################ + #Stage 0: load Affelio (init mode) + ################################################################ + my $cfg_dir = "$top_dir/config/"; + my $af; + my $dbh; + try{ + $af = new Affelio(ConfigDir => $cfg_dir, + Mode => "init"); + $dbh = $af->{db}; + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("Could not load Affelio (init): $e"); + }; + + ################################################################ + #Stage 1: DB creation + ################################################################ + + ################################ + #profile DB + ################################ + my $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating prof: $@"); + } + + $af->{user__nickname} = $g_nickname; + $af->{user__email1} = $g_email; + try{ + $af->{pm}->save_profile(); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("Cannot save_profile: $@"); + }; + debug_print("saved profile"); + + ################################ + #profile attribute DB + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating attr: $@"); + } + + my $sth = ""; + eval{ + $sth = $dbh->prepare(q{insert into AFuser_CORE_prof_attr(aid, name, type) values (?,?,?)}); + }; + if($@){ + throw Affelio::exception::DBException("SQL prepare: $@"); + } + + try{ + open(FIN, "$top_dir/defaults/AFuser_CORE_prof_attr.csv"); + + while(my $line=){ + chomp($line); + my ($aid, $name, $type) = split(',', $line); + #print "$aid - $name - $type\n"; + + $sth->execute($aid, $name, $type); + } + close(FIN); + }catch Error with{ + my $e = shift; + throw Affelio::exception::IOException("prof_attr: $@"); + }; + + ################################ + #friends DB + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating friends tbl: $@"); + } + + ################################ + #erasedfriends DB + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating erased friends tbl: $@"); + } + + ################################ + #friendsfriends DB + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating F2 tbl: $@"); + } + + ################################ + #group DB + ################################ + $create_tbl_cmd = "CREATE TABLE AFuser_CORE_group(gid INTEGER, group_name TEXT, members TEXT, option_pid INTEGER)"; + if(!$dbh->do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating grp tbl: $@"); + } + + ################################ + #Permission DB + ################################ + $create_tbl_cmd = "CREATE TABLE AFuser_CORE_permission(pid INTEGER, type TEXT, target_id TEXT, "; + + for(my $i=0; $i<=63; $i++){ + $create_tbl_cmd .= " attr$i INT,"; + } + chop($create_tbl_cmd); + $create_tbl_cmd .= ")"; + debug_print("setup: create [$create_tbl_cmd]"); + if(!$dbh->do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating perm tbl: $@"); + } + + ################################ + #tmp_recvd_hs + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating tmp_recved tbl: $@"); + } + + ################################ + #tmp_sent_hs + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating tmp_send tbl: $@"); + } + + ################################ + #message + ################################ + $create_tbl_cmd = <do($create_tbl_cmd)){ + throw Affelio::exception::DBException("creating msg tbl: $@"); + } + + try{ + $dbh->disconnect; + }catch Error with{ + my $e = shift; + throw Affelio::exception::DBException("DB disconnecting: $@"); + }; + + ################################################################ + #Stage 2: Reload Affelio + ################################################################ + try{ + undef($af); + $af = new Affelio(ConfigDir => $cfg_dir); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("Couldnot load Affelio: $e"); + }; + + ################################ + #Set permission to F1 + ################################ + # n names b i intro email url im + my @flag_array = (1,1,1,1, 1,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); + try{ + $af->{perm}->add_permission("f", "f1", \@flag_array); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("adding F1 perm: $@"); + }; + + ################################ + #Set permission to F2 + ################################ + # n names b i intro email url im + my @flag_array = (1,0,0,0, 0,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); + try{ + $af->{perm}->add_permission("f", "f2", \@flag_array); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("adding F2 perm: $@"); + }; + + ################################ + #Set permission to PB + ################################ + # n names b i intro email url im + my @flag_array = (1,0,0,0, 0,0, 1,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,0,0, 0); + try{ + $af->{perm}->add_permission("f", "pb", \@flag_array); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("adding PB perm: $@"); + }; + + ################################ + #Make a new group "dear_friend" + ################################ + my $gid; + try{ + $gid = $af->{gm}->add_group($g_lh->maketext("_SETUP_group_dear_friend")); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("adding dear Grp: $@"); + }; + + ##################################### + #Set permission to group "dear_friend" + ##################################### + # n names b i intro email url im + my @flag_array = (1,1,1,1, 1,1, 1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1,1,1, 1); + try{ + $af->{perm}->add_permission("g", $gid, \@flag_array); + }catch Error with{ + my $e = shift; + throw Affelio::exception::Exception("adding perm to Grp: $@"); + }; + } + + ##################################################################### + sub set_datadir_perm{ + my $top_dir = shift; + my $userdir = get_userdir("$top_dir/userdata"); + + #hmmmmmm.... + system("chmod -R 777 $userdir"); + } + + +} +1; From slash5234 @ users.sourceforge.jp Mon Oct 24 20:37:27 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 20:37:27 +0900 Subject: [Affelio-cvs 596] CVS update: affelio/lib/Affelio/misc/L10N Message-ID: <20051024113727.3A4452AC063@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/L10N/ja.pm diff -u affelio/lib/Affelio/misc/L10N/ja.pm:1.25 affelio/lib/Affelio/misc/L10N/ja.pm:1.26 --- affelio/lib/Affelio/misc/L10N/ja.pm:1.25 Mon Oct 24 17:52:49 2005 +++ affelio/lib/Affelio/misc/L10N/ja.pm Mon Oct 24 20:37:27 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ja.pm,v 1.25 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: ja.pm,v 1.26 2005/10/24 11:37:27 slash5234 Exp $ package Affelio::misc::L10N::ja; { @@ -60,7 +60,7 @@ # '_SETUP_title_100' => '荐??????ゃ??????, - '_SETUP_msg_100' => '篁ヤ???????????c????????≪?????吾?莨若????????若?????с? (777, 700???) ??┃絎???????????
          • config/
          • userdata/
          • session/
          • skins/
          • templates_dyn/
          ', + '_SETUP_msg_100' => '篁ヤ???????????c????????≪???????????激??潟? 777 ??700 ?????GI?????昭??? ??┃絎???????????
          • config/
          • userdata/
          • session/
          • skins/
          • templates_dyn/
          ', '_SETUP_check_100_err1' => '
        • affelio.cfg???????????BR>setup.cgi???????c??????????affelio.cfg?????????腥冴??<????????炊???????ermission?т?????????????', '_SETUP_check_100_err2' => '
        • CGI???affelio.cfg???絎鴻?茯??莨若??障????
          茯???吾????????若?????с???┃絎???????????', '_SETUP_check_100_err3' => '
        • CGI???affelio.cfg?御???昭????????BR>茯???吾????????若?????с???┃絎???????????', From slash5234 @ users.sourceforge.jp Mon Oct 24 21:50:34 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 21:50:34 +0900 Subject: [Affelio-cvs 597] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024125034.939F12AC036@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.1 affelio/lib/Affelio/misc/InitAffelio.pm:1.2 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.1 Mon Oct 24 20:37:26 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Mon Oct 24 21:50:34 2005 @@ -1,3 +1,5 @@ +#!/usr/bin/perl + # Copyright (C) 2005 FishGrove Inc. # # This program is free software; you can redistribute it and/or @@ -14,22 +16,25 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.1 2005/10/24 11:37:26 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.2 2005/10/24 12:50:34 slash5234 Exp $ package Affelio::misc::InitAffelio; { use strict; use Exporter; @Affelio::misc::InitAffelio::ISA = "Exporter"; - @Affelio::misc::InitAffelio::EXPORT = qw (create_userdir get_userdir create_af_cfg create_db_cfg create_login_cfg copy_def_files init_db set_datadir_perm); + @Affelio::misc::InitAffelio::EXPORT = qw (create_userdir get_userdir create_af_cfg create_db_cfg create_login_cfg copy_def_files init_db set_datadir_perm setup_affelio); use lib("../../../extlib/"); + use Cwd; + use DBI; use Error qw(:try); use lib("."); use lib("../../../lib/"); use Affelio; use Affelio::misc::CGIError; use Affelio::misc::Debug; + use Affelio::App::Admin::EditTemplates; use Affelio::exception::Exception; use Affelio::exception::DBException; use Affelio::exception::IOException; @@ -410,5 +415,67 @@ } + ##################################################################### + sub setup_affelio{ + my $root_dir = shift; + my $root_url = shift; + my $locale = shift; + my $lh = shift; + my $template = shift; + my $sendmail_path = shift; + # + my $db_type = shift; + my $db_dbname = shift; + my $db_username = shift; + my $db_password = shift; + my $db_hostname = shift; + my $db_port = shift; + # + my $username = shift; + my $password = shift; + my $nickname =shift; + my $email =shift; + + create_userdir($root_dir); + + create_af_cfg("$root_dir/config/affelio.cfg", + $root_dir, + $root_url, + $locale, + $template, + $sendmail_path); + + chmod 0700, "$root_dir/config"; + + my $user_dir = ""; + $user_dir = get_userdir("$root_dir /userdata"); + + create_db_cfg("$user_dir/db.cfg", + $db_type, + $db_dbname, + $db_username, + $db_password, + $db_hostname, + $db_port); + + + my @salts = ( "A".."Z", "a".."z", "0".."9", ".", "/" ); + my $salt = $salts[int(rand(64))] . $salts[int(rand(64))]; + my $crypted_password = crypt($password, $salt); + create_login_cfg("$user_dir/login.cfg", + $username, + $crypted_password); + + copy_def_files($root_dir , $user_dir, $locale); + + init_db($root_dir , $nickname, $email, $lh); + + my $af; + $af = new Affelio(ConfigDir => "$root_dir /config/"); + Affelio::App::Admin::EditTemplates::rebuild($af); + + set_datadir_perm($root_dir ); + } + } 1; From slash5234 @ users.sourceforge.jp Mon Oct 24 21:51:56 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 21:51:56 +0900 Subject: [Affelio-cvs 598] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024125156.374BA2AC036@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.2 affelio/lib/Affelio/misc/InitAffelio.pm:1.3 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.2 Mon Oct 24 21:50:34 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Mon Oct 24 21:51:56 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.2 2005/10/24 12:50:34 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.3 2005/10/24 12:51:56 slash5234 Exp $ package Affelio::misc::InitAffelio; { @@ -34,6 +34,7 @@ use Affelio; use Affelio::misc::CGIError; use Affelio::misc::Debug; + use Affelio::misc::MyCrypt; use Affelio::App::Admin::EditTemplates; use Affelio::exception::Exception; use Affelio::exception::DBException; From slash5234 @ users.sourceforge.jp Mon Oct 24 22:11:23 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 22:11:23 +0900 Subject: [Affelio-cvs 599] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024131123.B0A632AC015@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.3 affelio/lib/Affelio/misc/InitAffelio.pm:1.4 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.3 Mon Oct 24 21:51:56 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Mon Oct 24 22:11:23 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.3 2005/10/24 12:51:56 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.4 2005/10/24 13:11:23 slash5234 Exp $ package Affelio::misc::InitAffelio; { @@ -417,6 +417,9 @@ ##################################################################### + #setup_affelio + # all-in-one function to setup affelio + ##################################################################### sub setup_affelio{ my $root_dir = shift; my $root_url = shift; @@ -437,20 +440,48 @@ my $nickname =shift; my $email =shift; + debug_print("InitAffelio:setup start."); + debug_print("\t$root_dir "); + debug_print("\t$root_url "); + debug_print("\t$locale "); + debug_print("\t$lh "); + debug_print("\t$template "); + debug_print("\t$sendmail_path "); + debug_print("\t$db_type "); + debug_print("\t$db_dbname "); + debug_print("\t$db_username "); + debug_print("\t$db_password "); + debug_print("\t$db_hostname "); + debug_print("\t$db_port "); + debug_print("\t$username "); + debug_print("\t$password "); + debug_print("\t$nickname "); + debug_print("\t$email "); + + ################################ + #(1)Create user dir create_userdir($root_dir); + debug_print("InitAffelio:setup (1) create dir done."); + ################################ + #(2)Create af_cfg create_af_cfg("$root_dir/config/affelio.cfg", $root_dir, $root_url, $locale, $template, $sendmail_path); - chmod 0700, "$root_dir/config"; + debug_print("InitAffelio:setup (2) create affelio.cfg done."); + ################################ + #(3)Get userdata dir my $user_dir = ""; - $user_dir = get_userdir("$root_dir /userdata"); + $user_dir = get_userdir("$root_dir/userdata"); + debug_print("InitAffelio:setup (3) user dir = [$user_dir]"); + ################################ + #(4)create db.cfg create_db_cfg("$user_dir/db.cfg", $db_type, $db_dbname, @@ -458,24 +489,41 @@ $db_password, $db_hostname, $db_port); + debug_print("InitAffelio:setup (4) create db.cfg done"); - + ################################ + #(5)create login.cfg my @salts = ( "A".."Z", "a".."z", "0".."9", ".", "/" ); my $salt = $salts[int(rand(64))] . $salts[int(rand(64))]; my $crypted_password = crypt($password, $salt); create_login_cfg("$user_dir/login.cfg", $username, $crypted_password); + debug_print("InitAffelio:setup (5) create login.cfg [$crypted_password] done."); + ################################ + #(6)Copy default files copy_def_files($root_dir , $user_dir, $locale); + debug_print("InitAffelio:setup (6) copy default files. done."); + ################################ + #(7)initialize DB init_db($root_dir , $nickname, $email, $lh); + debug_print("InitAffelio:setup (7) Init DB done."); + ################################ + #(8)Rebuild template my $af; - $af = new Affelio(ConfigDir => "$root_dir /config/"); + $af = new Affelio(ConfigDir => "$root_dir/config/"); Affelio::App::Admin::EditTemplates::rebuild($af); + debug_print("InitAffelio:setup (8) Rebuild template done."); + ################################ + #(9)Set permission set_datadir_perm($root_dir ); + debug_print("InitAffelio:setup (9) Set permission done."); + + debug_print("InitAffelio:setup ****ALL DONE****"); } } From slash5234 @ users.sourceforge.jp Mon Oct 24 22:11:40 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Mon, 24 Oct 2005 22:11:40 +0900 Subject: [Affelio-cvs 600] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024131140.0E5B32AC015@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/WebInput.pm diff -u affelio/lib/Affelio/misc/WebInput.pm:1.6 affelio/lib/Affelio/misc/WebInput.pm:1.7 --- affelio/lib/Affelio/misc/WebInput.pm:1.6 Fri Jul 1 11:00:10 2005 +++ affelio/lib/Affelio/misc/WebInput.pm Mon Oct 24 22:11:39 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: WebInput.pm,v 1.6 2005/07/01 02:00:10 slash5234 Exp $ +# $Id: WebInput.pm,v 1.7 2005/10/24 13:11:39 slash5234 Exp $ use strict; package Affelio::misc::WebInput; @@ -53,6 +53,23 @@ } ###################################################################### + sub PTN_email{ + my $self = shift; + my $in = shift; + + $in =~ /([A-Za-z0-9\.\+\@\_]*)/; + return ($1); + } + + ###################################################################### + sub PTN_password{ + my $self = shift; + my $in = shift; + + return ($in); + } + + ###################################################################### sub PTN_num{ my $self = shift; my $in = shift; From slash5234 @ users.sourceforge.jp Tue Oct 25 00:07:52 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 00:07:52 +0900 Subject: [Affelio-cvs 601] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024150752.0D60B2AC010@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.4 affelio/lib/Affelio/misc/InitAffelio.pm:1.5 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.4 Mon Oct 24 22:11:23 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Tue Oct 25 00:07:51 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.4 2005/10/24 13:11:23 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.5 2005/10/24 15:07:51 slash5234 Exp $ package Affelio::misc::InitAffelio; { @@ -387,7 +387,7 @@ ################################ my $gid; try{ - $gid = $af->{gm}->add_group($g_lh->maketext("_SETUP_group_dear_friend")); + $gid = $af->{gm}->add_group($af->{lh}->maketext("_SETUP_group_dear_friend")); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("adding dear Grp: $@"); Index: affelio/lib/Affelio/misc/WebInput.pm diff -u affelio/lib/Affelio/misc/WebInput.pm:1.7 affelio/lib/Affelio/misc/WebInput.pm:1.8 --- affelio/lib/Affelio/misc/WebInput.pm:1.7 Mon Oct 24 22:11:39 2005 +++ affelio/lib/Affelio/misc/WebInput.pm Tue Oct 25 00:07:51 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: WebInput.pm,v 1.7 2005/10/24 13:11:39 slash5234 Exp $ +# $Id: WebInput.pm,v 1.8 2005/10/24 15:07:51 slash5234 Exp $ use strict; package Affelio::misc::WebInput; @@ -57,7 +57,7 @@ my $self = shift; my $in = shift; - $in =~ /([A-Za-z0-9\.\+\@\_]*)/; + $in =~ /([A-Za-z0-9\.\+\_\-\@]*)/; return ($1); } From slash5234 @ users.sourceforge.jp Tue Oct 25 01:04:30 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 01:04:30 +0900 Subject: [Affelio-cvs 602] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024160430.243022AC010@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.5 affelio/lib/Affelio/misc/InitAffelio.pm:1.6 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.5 Tue Oct 25 00:07:51 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Tue Oct 25 01:04:30 2005 @@ -1,5 +1,3 @@ -#!/usr/bin/perl - # Copyright (C) 2005 FishGrove Inc. # # This program is free software; you can redistribute it and/or @@ -16,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.5 2005/10/24 15:07:51 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.6 2005/10/24 16:04:30 slash5234 Exp $ package Affelio::misc::InitAffelio; { From slash5234 @ users.sourceforge.jp Tue Oct 25 01:50:10 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 01:50:10 +0900 Subject: [Affelio-cvs 603] CVS update: affelio/lib/Affelio/misc Message-ID: <20051024165010.197D92AC030@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.6 affelio/lib/Affelio/misc/InitAffelio.pm:1.7 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.6 Tue Oct 25 01:04:30 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Tue Oct 25 01:50:09 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.6 2005/10/24 16:04:30 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.7 2005/10/24 16:50:09 slash5234 Exp $ package Affelio::misc::InitAffelio; { @@ -81,6 +81,7 @@ my $char_set = shift; my $template = shift; my $sendmail_path = shift; + my $additional_cfg = shift; eval{ open(OUT, "> $affelio_cfg_path"); @@ -92,6 +93,12 @@ print OUT "\n"; print OUT "[command]\n"; print OUT "sendmail=$sendmail_path\n"; + + if($additional_cfg){ + print OUT "[affelio_farm]\n"; + print OUT "$additional_cfg\n"; + } + close OUT; chmod 0444, "$affelio_cfg_path"; @@ -424,6 +431,7 @@ my $locale = shift; my $lh = shift; my $template = shift; + my $additional_cfg = shift; my $sendmail_path = shift; # my $db_type = shift; @@ -444,6 +452,7 @@ debug_print("\t$locale "); debug_print("\t$lh "); debug_print("\t$template "); + debug_print("\t$additional_cfg"); debug_print("\t$sendmail_path "); debug_print("\t$db_type "); debug_print("\t$db_dbname "); @@ -468,7 +477,8 @@ $root_url, $locale, $template, - $sendmail_path); + $sendmail_path, + $additional_cfg); chmod 0700, "$root_dir/config"; debug_print("InitAffelio:setup (2) create affelio.cfg done."); From slash5234 @ users.sourceforge.jp Tue Oct 25 02:38:26 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 02:38:26 +0900 Subject: [Affelio-cvs 604] CVS update: affelio/lib/Affelio/Backplane Message-ID: <20051024173826.44BA12AC010@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 02:38:39 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 02:38:39 +0900 Subject: [Affelio-cvs 605] CVS update: affelio/lib/Affelio/Backplane/FarmConnecter Message-ID: <20051024173839.7443C2AC010@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 02:39:17 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 02:39:17 +0900 Subject: [Affelio-cvs 606] CVS update: affelio/lib/Affelio/Backplane Message-ID: <20051024173917.0F90E2AC010@users.sourceforge.jp> Index: affelio/lib/Affelio/Backplane/FarmConnecter.pm diff -u /dev/null affelio/lib/Affelio/Backplane/FarmConnecter.pm:1.1 --- /dev/null Tue Oct 25 02:39:17 2005 +++ affelio/lib/Affelio/Backplane/FarmConnecter.pm Tue Oct 25 02:39:16 2005 @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +# Copyright (C) 2005 FishGrove Inc. +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# 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. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# $Id: FarmConnecter.pm,v 1.1 2005/10/24 17:39:16 slash5234 Exp $ + +package Affelio::Backplane::FarmConnecter; +{ + use strict; + use lib("../../../extlib"); + use lib("../../../lib"); + + + +} +1; From slash5234 @ users.sourceforge.jp Tue Oct 25 02:39:17 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 02:39:17 +0900 Subject: [Affelio-cvs 607] CVS update: affelio/lib/Affelio/Backplane/FarmConnecter Message-ID: <20051024173917.2BF452AC030@users.sourceforge.jp> Index: affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm diff -u /dev/null affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:1.1 --- /dev/null Tue Oct 25 02:39:17 2005 +++ affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm Tue Oct 25 02:39:17 2005 @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +# Copyright (C) 2005 FishGrove Inc. +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# 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. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# $Id: SimpleFileConnecter.pm,v 1.1 2005/10/24 17:39:17 slash5234 Exp $ + +package Affelio::Backplane::FarmConnecter::SimpleFileConnecter; +{ + use strict; + use lib("../../../../extlib"); + use lib("../../../../lib"); + use Affelio::misc::Debug; + + use vars qw(@ISA); + @ISA = qw(Affelio::Backplane::FarmConnecter); + + sub new{ + debug_print("SimpleFileConn: start."); + + my $class = shift; + my %param = @_; + + my $file_path = $param{path}; + debug_print("SimpleFileConn: path = [$file_path]"); + my %config = (); + + + open(IN, $file_path); + my $line=""; + while($line=){ + chop($line); + if($line =~ /AF_CTRL_/){ + $line = ~/([A-Za-z0-9\-\_]*)\s*=\s*(.*)/; + $config{$1} =$2; + debug_print("SimpleFileConn: [$1] = [$2]"); + } + } + close(IN); + + my $self = {file_path => $file_path, + config => %config}; + bless $self, $class; + return($self); + } + + sub get_val{ + my $self =shift; + my $arg = shift; + + return($self->{config}->{$arg}); + } + +} +1; From slash5234 @ users.sourceforge.jp Tue Oct 25 02:39:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 02:39:54 +0900 Subject: [Affelio-cvs 608] CVS update: affelio/lib Message-ID: <20051024173954.ED2092AC010@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.20 affelio/lib/Affelio.pm:1.21 --- affelio/lib/Affelio.pm:1.20 Mon Oct 24 20:37:26 2005 +++ affelio/lib/Affelio.pm Tue Oct 25 02:39:54 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.20 2005/10/24 11:37:26 slash5234 Exp $ +# $Id: Affelio.pm,v 1.21 2005/10/24 17:39:54 slash5234 Exp $ package Affelio; { @@ -107,6 +107,7 @@ my $perm = ""; my $am = ""; my $alm = ""; + my $farm_con = ""; ################################### #Blessing @@ -124,7 +125,8 @@ alm => $alm, mode => $mode, guest_owner_switch => $guest_owner_switch, - caller => $caller + caller => $caller, + farm_con => $farm_con }; bless $self, $class; @@ -439,6 +441,43 @@ } + ###################################################################### + #get_farm_connecter{ + # + ###################################################################### + sub get_farm_connecter{ + my $self = shift; + if( !(self->{farm_con}) ){ + my $Config = Config::Tiny->new(); + + $Config = Config::Tiny->read($self->{cfg_path}); + if($@ || !$Config){ + throw Affelio::exception::SystemException("affelio.cfg not found"); + } + + $self->{farm__connecter} = $Config->{affelio_farm}->{farm_connecter}; + if(($self->{farm__connecter} eq "" ) + || !($self->{farm__connecter}) ){ + return(""); + } + + my ($con_type, $con_arg) = split(':', $self->{farm__connecter}); + my $con_class = "Affelio::Backbone::FarmConnecter::" . $con_type; + + eval "use $con_class"; + if($@){ + throw Affelio::exception::SystemException("Could not load [$con_class]."); + } + + eval "$self->{farm_con} = new $con_class()"; + if($@){ + throw Affelio::exception::SystemException("Could not instantiate [$con_class]."); + } + + } + + return($self->{farm_con}); + } ###################################################################### #read_site_config From slash5234 @ users.sourceforge.jp Tue Oct 25 03:41:21 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 03:41:21 +0900 Subject: [Affelio-cvs 609] CVS update: affelio Message-ID: <20051024184121.6D99D2AC010@users.sourceforge.jp> Index: affelio/setup.cgi diff -u affelio/setup.cgi:1.15 affelio/setup.cgi:1.16 --- affelio/setup.cgi:1.15 Mon Oct 24 20:37:26 2005 +++ affelio/setup.cgi Tue Oct 25 03:41:21 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: setup.cgi,v 1.15 2005/10/24 11:37:26 slash5234 Exp $ +# $Id: setup.cgi,v 1.16 2005/10/24 18:41:21 slash5234 Exp $ use strict; @@ -320,7 +320,6 @@ $g_locale, "default", $sendmail_path); - chmod 0700, "$g_fsroot/config"; return(""); } From slash5234 @ users.sourceforge.jp Tue Oct 25 03:41:21 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 03:41:21 +0900 Subject: [Affelio-cvs 610] CVS update: affelio/lib Message-ID: <20051024184121.8D1AD2AC01D@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.21 affelio/lib/Affelio.pm:1.22 --- affelio/lib/Affelio.pm:1.21 Tue Oct 25 02:39:54 2005 +++ affelio/lib/Affelio.pm Tue Oct 25 03:41:21 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.21 2005/10/24 17:39:54 slash5234 Exp $ +# $Id: Affelio.pm,v 1.22 2005/10/24 18:41:21 slash5234 Exp $ package Affelio; { @@ -447,7 +447,7 @@ ###################################################################### sub get_farm_connecter{ my $self = shift; - if( !(self->{farm_con}) ){ + if( !($self->{farm_con}) ){ my $Config = Config::Tiny->new(); $Config = Config::Tiny->read($self->{cfg_path}); @@ -455,24 +455,29 @@ throw Affelio::exception::SystemException("affelio.cfg not found"); } - $self->{farm__connecter} = $Config->{affelio_farm}->{farm_connecter}; - if(($self->{farm__connecter} eq "" ) - || !($self->{farm__connecter}) ){ + $self->{farm__connecter_path} = $Config->{affelio_farm}->{farm_connecter}; + if(($self->{farm__connecter_path} eq "" ) + || !($self->{farm__connecter_path}) ){ return(""); } + debug_print("Affelio::get_farm_con: [$self->{farm__connecter_path}]"); - my ($con_type, $con_arg) = split(':', $self->{farm__connecter}); - my $con_class = "Affelio::Backbone::FarmConnecter::" . $con_type; + my ($con_type, $con_arg) = split(':', $self->{farm__connecter_path}); + my $con_class = "Affelio::Backplane::FarmConnecter::" . $con_type; + debug_print("Affelio::get_farm_con: [$con_class]"); + debug_print("Affelio::get_farm_con: [$con_arg]"); eval "use $con_class"; if($@){ - throw Affelio::exception::SystemException("Could not load [$con_class]."); + debug_print("Affelio::get_farm_con: con=[$self->{farm_con}]1"); } - eval "$self->{farm_con} = new $con_class()"; + $self->{farm_con} = $con_class->new(path => $con_arg); if($@){ + debug_print("$@"); throw Affelio::exception::SystemException("Could not instantiate [$con_class]."); } + debug_print("Affelio::get_farm_con: con=[$self->{farm_con}]"); } From slash5234 @ users.sourceforge.jp Tue Oct 25 03:41:21 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 03:41:21 +0900 Subject: [Affelio-cvs 611] CVS update: affelio/lib/Affelio/App/Admin Message-ID: <20051024184121.AC3302AC010@users.sourceforge.jp> Index: affelio/lib/Affelio/App/Admin/EditSkins.pm diff -u affelio/lib/Affelio/App/Admin/EditSkins.pm:1.5 affelio/lib/Affelio/App/Admin/EditSkins.pm:1.6 --- affelio/lib/Affelio/App/Admin/EditSkins.pm:1.5 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/EditSkins.pm Tue Oct 25 03:41:21 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: EditSkins.pm,v 1.5 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: EditSkins.pm,v 1.6 2005/10/24 18:41:21 slash5234 Exp $ package Affelio::App::Admin::EditSkins; { @@ -72,6 +72,18 @@ debug_print("EditSkins:upload: start."); + ############################### + #Enabling/disabling upload + ############################### + my $farm_con; + $farm_con = $af->get_farm_connecter(); + if($farm_con){ + if($farm_con->get_val("can_upload_skin") ne "yes"){ + return(); + } + } + + my $filename = $cgi->param('uploadingfile'); my $filetype = $cgi->uploadInfo($filename)->{'Content-Type'}; my $basename = ""; #basename($filename,""); @@ -207,6 +219,18 @@ } $output_ref->{"skin_list"} = \@skin_list; + ############################### + #Enabling/disabling upload + ############################### + my $farm_con; + $farm_con = $af->get_farm_connecter(); + if($farm_con){ + if($farm_con->get_val("can_upload_skin") eq "yes"){ + $output_ref->{'upload_disabler'} = ""; + }else{ + $output_ref->{'upload_disabler'} = "disabled"; + } + } ############################### #Selected skin's CSS file From slash5234 @ users.sourceforge.jp Tue Oct 25 03:41:21 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 03:41:21 +0900 Subject: [Affelio-cvs 612] CVS update: affelio/lib/Affelio/Backplane/FarmConnecter Message-ID: <20051024184121.C870F2AC01F@users.sourceforge.jp> Index: affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm diff -u affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:1.1 affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:1.2 --- affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:1.1 Tue Oct 25 02:39:17 2005 +++ affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm Tue Oct 25 03:41:21 2005 @@ -16,14 +16,16 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: SimpleFileConnecter.pm,v 1.1 2005/10/24 17:39:17 slash5234 Exp $ +# $Id: SimpleFileConnecter.pm,v 1.2 2005/10/24 18:41:21 slash5234 Exp $ package Affelio::Backplane::FarmConnecter::SimpleFileConnecter; { use strict; use lib("../../../../extlib"); + use Error qw(:try); use lib("../../../../lib"); use Affelio::misc::Debug; + use Affelio::exception::IOException; use vars qw(@ISA); @ISA = qw(Affelio::Backplane::FarmConnecter); @@ -38,22 +40,26 @@ debug_print("SimpleFileConn: path = [$file_path]"); my %config = (); + my $self = {file_path => $file_path, + config => \%config}; + bless $self, $class; - open(IN, $file_path); my $line=""; - while($line=){ - chop($line); - if($line =~ /AF_CTRL_/){ - $line = ~/([A-Za-z0-9\-\_]*)\s*=\s*(.*)/; - $config{$1} =$2; - debug_print("SimpleFileConn: [$1] = [$2]"); + try{ + open(IN, $file_path); + while($line = ){ + chop($line); + if($line =~ /^AF_CTRL_([A-Za-z0-9\-\_]*)\s*\=\s*(.*)/){ + $config{$1} =$2; + debug_print("SimpleFileConn: [$1] = [$2]"); + } } - } - close(IN); + close(IN); + }catch Error with{ + my $e=shift; + debug_print("SimpleFileConn: $e"); + }; - my $self = {file_path => $file_path, - config => %config}; - bless $self, $class; return($self); } @@ -61,6 +67,7 @@ my $self =shift; my $arg = shift; + debug_print("SimpleFileConn::get_val $arg = $self->{config}->{$arg}"); return($self->{config}->{$arg}); } From slash5234 @ users.sourceforge.jp Tue Oct 25 03:41:21 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 03:41:21 +0900 Subject: [Affelio-cvs 613] CVS update: affelio/templates/default/owner_side Message-ID: <20051024184121.E4E272AC01D@users.sourceforge.jp> Index: affelio/templates/default/owner_side/admin_edit_skins.tmpl diff -u affelio/templates/default/owner_side/admin_edit_skins.tmpl:1.9 affelio/templates/default/owner_side/admin_edit_skins.tmpl:1.10 --- affelio/templates/default/owner_side/admin_edit_skins.tmpl:1.9 Thu Jun 30 20:37:50 2005 +++ affelio/templates/default/owner_side/admin_edit_skins.tmpl Tue Oct 25 03:41:21 2005 @@ -73,11 +73,11 @@
- +> -"> +" >
From slash5234 @ users.sourceforge.jp Tue Oct 25 04:14:42 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:14:42 +0900 Subject: [Affelio-cvs 614] CVS update: affelio_farm Message-ID: <20051024191442.23F732AC010@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:42 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:42 +0900 Subject: [Affelio-cvs 615] CVS update: affelio_farm/admin/skelton/affelio/apps Message-ID: <20051024192042.9FB6C2AC01F@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:42 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:42 +0900 Subject: [Affelio-cvs 616] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi Message-ID: <20051024192042.CC8D92AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/AF_app.cfg diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/AF_app.cfg:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/AF_app.cfg:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/AF_app.cfg:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/AF_app.cfg Tue Oct 25 04:20:42 2005 @@ -1,13 +0,0 @@ -[this_installation] -title=腱??Mixi??? - -[application] -app_name=Mixi -app_version=0.4 -app_desc=Affelio Mixi?蚊?????с? -app_author=Affelio project -guest_index=index.cgi -owner_index=admin.cgi -action_types=setting -action_types_desc=Mixi?ョ?荐?? - Index: affelio_farm/admin/skelton/affelio/apps/Mixi/README diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/README:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/README:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/README:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/README Tue Oct 25 04:20:42 2005 @@ -1,15 +0,0 @@ -Affelio-Mixi Gateway - -Install - 1. Put this "Mixi" directory under "apps" directory in your Affelio. - - -Configuration - 1. Go to "Mixi" application tab. - 2. Go to "Owner" tab. - 3. Input your Mixi registration. - - That's it! :) - - - Index: affelio_farm/admin/skelton/affelio/apps/Mixi/admin.cgi diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/admin.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/admin.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/admin.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/admin.cgi Tue Oct 25 04:20:42 2005 @@ -1,82 +0,0 @@ -#!/usr/bin/perl - -use lib("../../extlib"); #general -use HTML::Template; -use CGI; -use Cwd; -use Jcode; -# -use lib("../../lib"); #Affelio -use AffelioApp; -use Affelio::misc::CGIError; -# -use lib("./extlib/"); #WWW:Mixi -use WWW::Mixi; -use HTTP::Cookies; -use HTTP::Request::Common; -# -use lib("./lib/"); -use AffelioApp::SNSGateway; - -use strict; - -########################################################################### -#init -########################################################################### -my $cgi = new CGI(); - -#AffelioApp?????? -my $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); -$afap->set_owner_mode(); -my $in_username = $cgi->param("username"); -my $in_password = $cgi->param("password"); - -########################################################################### -#Output -########################################################################### -#Content-type?????-print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; - -#HTML Header Part?????-print $afap->get_HTML_header("Affelio Mixi Gateway"); - -# 茯??莨若??≪??祉?罔??????с???????絎壕;腓?-unless ($afap->check_access("setting") - && - $afap->check_access("DF_read")){ - print "?????????????若??????┤???????障???; - - #HTML Footer Part?????- print $afap->get_HTML_footer(); - - exit(1); -} - -########################################################################### -#Save input data into config_file -########################################################################### -if(($in_username ne "") && ($in_password ne "")){ - write_config($afap, $in_username, $in_password); -} - -########################################################################### -#Read configuration file -########################################################################### -my $userinfo = read_config($afap); - -my $tmpl = HTML::Template->new(filename => "./templates/admin.tmpl", - die_on_bad_params => 0); - -$tmpl->param(install_title => $afap->get_app_info("install_title")); -$tmpl->param(username => $userinfo->{username}); -$tmpl->param(password => $userinfo->{password}); -$tmpl->param(accesscontrol_url => $afap->get_URL("access_control")); - -print $tmpl->output; - -#HTML Footer Part?????-print $afap->get_HTML_footer(); - -exit(1); Index: affelio_farm/admin/skelton/affelio/apps/Mixi/index.cgi diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/index.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/index.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/index.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/index.cgi Tue Oct 25 04:20:42 2005 @@ -1,176 +0,0 @@ -#!/usr/bin/perl - -use lib("./extlib/"); #WWW:Mixi -use WWW::Mixi; - -use lib("../../extlib"); #general -use HTML::Template; -use CGI; -use Cwd; -use Jcode; -# -use lib("../../lib"); #Affelio -use AffelioApp; -use Affelio::misc::CGIError; -# -use lib("./extlib/"); #WWW:Mixi -use WWW::Mixi; -use HTTP::Cookies; -use HTTP::Request::Common; -# -use lib("./lib/"); -use AffelioApp::SNSGateway; - -########################################################################### -#init -########################################################################### -my $cgi = new CGI(); - -#AffelioApp?????? -my $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -my $page = $cgi->url_param("page"); - -########################################################################### -#Output -########################################################################### -#Content-type?????-print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; - -#HTML Header Part?????-print $afap->get_HTML_header("Affelio Mixi Gateway"); - -# 茯??莨若??≪??祉?罔??????с???????絎壕;腓?-unless ($afap->check_access("DF_access")) { - print "?????????????若?????粋昭?炊┤???????障???; - - #HTML Footer Part?????- print $afap->get_HTML_footer(); - - exit(1); -} - -########################################################################### -#Read configuration file -########################################################################### -my $userinfo = read_config($afap); - -my $visitor_type = $afap->get_visitor_info("type"); - - -########################################################################### -#Retrieve Mixi HTML -########################################################################### -my $err_mesg=""; - -if(($userinfo->{username} eq "") || ($userinfo->{password} eq "")){ - err_exit("Mixi????倶??宴??脂????????障????"); -} - -my $mixi = WWW::Mixi->new($userinfo->{username}, $userinfo->{password}); -if($@){ - err_exit($@); -} - -#Login -my $response = $mixi->login; -if(!($response->is_success)){ - err_exit("Could not login to Mixi!"); -} - -#Get HTML -my $url = 'list_friend.pl'; -if($page){ - $url .= '?page=' . $page; -} - -$response = $mixi->get($url); -if(!($response->is_success)){ - err_exit("Could not get list_friend.pl"); -} -#print "
" . $response->content . "
"; - -#Parse -my @friends = $mixi->parse_list_friend( $response ); - -my $myid = $mixi->parse_self_id( $mixi->get("list_review.pl") ); -my $my_home_url = "http://mixi.jp/show_friend.pl?id=" . $myid; -if($myid == 0){ - $my_home_url = "http://mixi.jp/"; -} - -########################################################################### -#Processing -########################################################################### -$num_friends = @friends; - -for(my $i=0; $i < $num_friends; $i++){ - $friends[$i]->{subject} = - Jcode->new( $friends[$i]->{subject} )->utf8; - - if($visitor_type eq "self"){ - $friends[$i]->{visitor_type} = "self"; - }else{ - $friends[$i]->{visitor_type} = ""; - } -} - - - - -my $next_message=""; -my $next_link=""; -my $next = $mixi->parse_list_friend_next( $response ); -if($next){ - $next_message = Jcode->new( $next->{subject} )->utf8; - $next->{link} =~ /(.*)page=([0-9]+)/; - $next_link = "./index.cgi?page=$2"; -} - -my $prev_message=""; -my $prev_link=""; -my $prev = $mixi->parse_list_friend_previous( $response ); -if($prev){ - $prev_message = Jcode->new( $prev->{subject} )->utf8; - $prev->{link} =~ /(.*)page=([0-9]+)/; - $prev_link = "./index.cgi?page=$2"; -} - - -my $tmpl = HTML::Template->new(filename => "./templates/index.tmpl", - die_on_bad_params => 0); - -$tmpl->param(install_title => $afap->get_app_info("install_title")); -$tmpl->param(my_home_url => $my_home_url); -$tmpl->param(my_nickname => $afap->get_owner_info("nickname")); -$tmpl->param(friends => \@friends); -$tmpl->param(next_link => $next_link); -$tmpl->param(next_message => $next_message); -$tmpl->param(prev_link => $prev_link); -$tmpl->param(prev_message => $prev_message); - -print $tmpl->output; - -#HTML Footer Part?????-print $afap->get_HTML_footer(); - -exit(1); - - -sub err_exit{ - my $err_mesg = shift; - - my $tmpl = HTML::Template->new(filename => "./templates/error.tmpl", - die_on_bad_params => 0); - $tmpl->param(install_title => $afap->get_app_info("install_title")); - $tmpl->param(my_home_url => $my_home_url); - $tmpl->param(err_mesg => $err_mesg); - - print $tmpl->output; - - #HTML Footer Part?????- print $afap->get_HTML_footer(); - exit(1); -} Index: affelio_farm/admin/skelton/affelio/apps/Mixi/style.css diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/style.css:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/style.css:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/style.css Tue Oct 25 04:20:42 2005 @@ -1,23 +0,0 @@ -.mixi_friend_field{ - width: 95px; - height: 120px; - vertical-align: top; - text-align: center; - float: left; -} -.mixi_friend_name{ - width: 100px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.mixi_config{ - padding: 30px 10px 30px 20px; - font-size: small; -} - -.mixi_footer{ - font-size: x-small; - text-align: left; -} From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:42 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:42 +0900 Subject: [Affelio-cvs 617] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class Message-ID: <20051024192042.ECF542AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor.pm Tue Oct 25 04:20:42 2005 @@ -1,612 +0,0 @@ -package Class::Accessor; -require 5.00502; -use strict; -$Class::Accessor::VERSION = '0.19'; - -=head1 NAME - - Class::Accessor - Automated accessor generation - -=head1 SYNOPSIS - - package Foo; - - use base qw(Class::Accessor); - Foo->mk_accessors(qw(this that whatever)); - - # Meanwhile, in a nearby piece of code! - # Class::Accessor provides new(). - my $foo = Foo->new; - - my $whatever = $foo->whatever; # gets $foo->{whatever} - $foo->this('likmi'); # sets $foo->{this} = 'likmi' - - # Similar to @values = @{$foo}{qw(that whatever)} - @values = $foo->get(qw(that whatever)); - - # sets $foo->{that} = 'crazy thing' - $foo->set('that', 'crazy thing'); - - -=head1 DESCRIPTION - -This module automagically generates accessor/mutators for your class. - -Most of the time, writing accessors is an exercise in cutting and -pasting. You usually wind up with a series of methods like this: - - # accessor for $obj->{foo} - sub foo { - my $self = shift; - - if(@_ == 1) { - $self->{foo} = shift; - } - elsif(@_ > 1) { - $self->{foo} = [@_]; - } - - return $self->{foo}; - } - - - # accessor for $obj->{bar} - sub bar { - my $self = shift; - - if(@_ == 1) { - $self->{bar} = shift; - } - elsif(@_ > 1) { - $self->{bar} = [@_]; - } - - return $self->{bar}; - } - - # etc... - -One for each piece of data in your object. While some will be unique, -doing value checks and special storage tricks, most will simply be -exercises in repetition. Not only is it Bad Style to have a bunch of -repetitious code, but its also simply not Lazy, which is the real -tragedy. - -If you make your module a subclass of Class::Accessor and declare your -accessor fields with mk_accessors() then you'll find yourself with a -set of automatically generated accessors which can even be -customized! - -The basic set up is very simple: - - package My::Class; - use base qw(Class::Accessor); - My::Class->mk_accessors( qw(foo bar car) ); - -Done. My::Class now has simple foo(), bar() and car() accessors -defined. - -=head2 What Makes This Different? - -What makes this module special compared to all the other method -generating modules (L<"SEE ALSO">)? By overriding the get() and set() -methods you can alter the behavior of the accessors class-wide. Also, -the accessors are implemented as closures which should cost a bit less -memory than most other solutions which generate a new method for each -accessor. - - -=head1 METHODS - -=head2 new - - my $obj = Class->new; - my $obj = $other_obj->new; - - my $obj = Class->new(\%fields); - my $obj = $other_obj->new(\%fields); - -Class::Accessor provides a basic constructor. It generates a -hash-based object and can be called as either a class method or an -object method. - -It takes an optional %fields hash which is used to initialize the -object (handy if you use read-only accessors). The fields of the hash -correspond to the names of your accessors, so... - - package Foo; - use base qw(Class::Accessor); - Foo->mk_accessors('foo'); - - my $obj = Class->new({ foo => 42 }); - print $obj->foo; # 42 - -however %fields can contain anything, new() will shove them all into -your object. Don't like it? Override it. - -=cut - -sub new { - my($proto, $fields) = @_; - my($class) = ref $proto || $proto; - - $fields = {} unless defined $fields; - - # make a copy of $fields. - bless {%$fields}, $class; -} - -=head2 mk_accessors - - Class->mk_accessors(@fields); - -This creates accessor/mutator methods for each named field given in - @ fields. Foreach field in @fields it will generate two accessors. -One called "field()" and the other called "_field_accessor()". For -example: - - # Generates foo(), _foo_accessor(), bar() and _bar_accessor(). - Class->mk_accessors(qw(foo bar)); - -See L -for details. - -=cut - -sub mk_accessors { - my($self, @fields) = @_; - - $self->_mk_accessors('make_accessor', @fields); -} - - -{ - no strict 'refs'; - - sub _mk_accessors { - my($self, $maker, @fields) = @_; - my $class = ref $self || $self; - - # So we don't have to do lots of lookups inside the loop. - $maker = $self->can($maker) unless ref $maker; - - foreach my $field (@fields) { - if( $field eq 'DESTROY' ) { - require Carp; - &Carp::carp("Having a data accessor named DESTROY in ". - "'$class' is unwise."); - } - - my $accessor = $self->$maker($field); - my $alias = "_${field}_accessor"; - - *{$class."\:\:$field"} = $accessor - unless defined &{$class."\:\:$field"}; - - *{$class."\:\:$alias"} = $accessor - unless defined &{$class."\:\:$alias"}; - } - } -} - -=head2 mk_ro_accessors - - Class->mk_ro_accessors(@read_only_fields); - -Same as mk_accessors() except it will generate read-only accessors -(ie. true accessors). If you attempt to set a value with these -accessors it will throw an exception. It only uses get() and not -set(). - - package Foo; - use base qw(Class::Accessor); - Class->mk_ro_accessors(qw(foo bar)); - - # Let's assume we have an object $foo of class Foo... - print $foo->foo; # ok, prints whatever the value of $foo->{foo} is - $foo->foo(42); # BOOM! Naughty you. - - -=cut - -sub mk_ro_accessors { - my($self, @fields) = @_; - - $self->_mk_accessors('make_ro_accessor', @fields); -} - -=head2 mk_wo_accessors - - Class->mk_wo_accessors(@write_only_fields); - -Same as mk_accessors() except it will generate write-only accessors -(ie. mutators). If you attempt to read a value with these accessors -it will throw an exception. It only uses set() and not get(). - -B I'm not entirely sure why this is useful, but I'm sure someone -will need it. If you've found a use, let me know. Right now its here -for orthoginality and because its easy to implement. - - package Foo; - use base qw(Class::Accessor); - Class->mk_wo_accessors(qw(foo bar)); - - # Let's assume we have an object $foo of class Foo... - $foo->foo(42); # OK. Sets $self->{foo} = 42 - print $foo->foo; # BOOM! Can't read from this accessor. - -=cut - -sub mk_wo_accessors { - my($self, @fields) = @_; - - $self->_mk_accessors('make_wo_accessor', @fields); -} - -=head1 DETAILS - -An accessor generated by Class::Accessor looks something like -this: - - # Your foo may vary. - sub foo { - my($self) = shift; - if(@_) { # set - return $self->set('foo', @_); - } - else { - return $self->get('foo'); - } - } - -Very simple. All it does is determine if you're wanting to set a -value or get a value and calls the appropriate method. -Class::Accessor provides default get() and set() methods which -your class can override. They're detailed later. - -=head2 Modifying the behavior of the accessor - -Rather than actually modifying the accessor itself, it is much more -sensible to simply override the two key methods which the accessor -calls. Namely set() and get(). - -If you -really- want to, you can override make_accessor(). - -=head2 set - - $obj->set($key, $value); - $obj->set($key, @values); - -set() defines how generally one stores data in the object. - -override this method to change how data is stored by your accessors. - -=cut - -sub set { - my($self, $key) = splice(@_, 0, 2); - - if(@_ == 1) { - $self->{$key} = $_[0]; - } - elsif(@_ > 1) { - $self->{$key} = [@_]; - } - else { - require Carp; - &Carp::confess("Wrong number of arguments received"); - } -} - -=head2 get - - $value = $obj->get($key); - @values = $obj->get(@keys); - -get() defines how data is retreived from your objects. - -override this method to change how it is retreived. - -=cut - -sub get { - my $self = shift; - - if(@_ == 1) { - return $self->{$_[0]}; - } - elsif( @_ > 1 ) { - return @{$self}{@_}; - } - else { - require Carp; - &Carp::confess("Wrong number of arguments received."); - } -} - -=head2 make_accessor - - $accessor = Class->make_accessor($field); - -Generates a subroutine reference which acts as an accessor for the given -$field. It calls get() and set(). - -If you wish to change the behavior of your accessors, try overriding -get() and set() before you start mucking with make_accessor(). - -=cut - -sub make_accessor { - my ($class, $field) = @_; - - # Build a closure around $field. - return sub { - my $self = shift; - - if(@_) { - return $self->set($field, @_); - } - else { - return $self->get($field); - } - }; -} - -=head2 make_ro_accessor - - $read_only_accessor = Class->make_ro_accessor($field); - -Generates a subroutine refrence which acts as a read-only accessor for -the given $field. It only calls get(). - -Override get() to change the behavior of your accessors. - -=cut - -sub make_ro_accessor { - my($class, $field) = @_; - - return sub { - my $self = shift; - - if(@_) { - my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot alter the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->get($field); - } - }; -} - -=head2 make_wo_accessor - - $read_only_accessor = Class->make_wo_accessor($field); - -Generates a subroutine refrence which acts as a write-only accessor -(mutator) for the given $field. It only calls set(). - -Override set() to change the behavior of your accessors. - -=cut - -sub make_wo_accessor { - my($class, $field) = @_; - - return sub { - my $self = shift; - - unless (@_) { - my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot access the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->set($field, @_); - } - }; -} - -=head1 EFFICIENCY - -Class::Accessor does not employ an autoloader, thus it is much faster -than you'd think. Its generated methods incur no special penalty over -ones you'd write yourself. - -Here are Schwern's results of benchmarking Class::Accessor, -Class::Accessor::Fast, a hand-written accessor, and direct hash access. - - Benchmark: timing 500000 iterations of By Hand - get, By Hand - set, - C::A - get, C::A - set, C::A::Fast - get, C::A::Fast - set, - Direct - get, Direct - set... - - By Hand - get: 4 wallclock secs ( 5.09 usr + 0.00 sys = 5.09 CPU) - @ 98231.83/s (n=500000) - By Hand - set: 5 wallclock secs ( 6.06 usr + 0.00 sys = 6.06 CPU) - @ 82508.25/s (n=500000) - C::A - get: 9 wallclock secs ( 9.83 usr + 0.01 sys = 9.84 CPU) - @ 50813.01/s (n=500000) - C::A - set: 11 wallclock secs ( 9.95 usr + 0.00 sys = 9.95 CPU) - @ 50251.26/s (n=500000) - C::A::Fast - get: 6 wallclock secs ( 4.88 usr + 0.00 sys = 4.88 CPU) - @ 102459.02/s (n=500000) - C::A::Fast - set: 6 wallclock secs ( 5.83 usr + 0.00 sys = 5.83 CPU) - @ 85763.29/s (n=500000) - Direct - get: 0 wallclock secs ( 0.89 usr + 0.00 sys = 0.89 CPU) - @ 561797.75/s (n=500000) - Direct - set: 2 wallclock secs ( 0.87 usr + 0.00 sys = 0.87 CPU) - @ 574712.64/s (n=500000) - -So Class::Accessor::Fast is just as fast as one you'd write yourself -while Class::Accessor is twice as slow, a price paid for flexibility. -Direct hash access is about six times faster, but provides no -encapsulation and no flexibility. - -Of course, its not as simple as saying "Class::Accessor is twice as -slow as one you write yourself". These are benchmarks for the -simplest possible accessor, if your accessors do any sort of -complicated work (such as talking to a database or writing to a file) -the time spent doing that work will quickly swamp the time spend just -calling the accessor. In that case, Class::Accessor and the ones you -write will tend to be just as fast. - - -=head1 EXAMPLES - -Here's an example of generating an accessor for every public field of -your class. - - package Altoids; - - use base qw(Class::Accessor Class::Fields); - use fields qw(curiously strong mints); - Altoids->mk_accessors( Altoids->show_fields('Public') ); - - sub new { - my $proto = shift; - my $class = ref $proto || $proto; - return fields::new($class); - } - - my Altoids $tin = Altoids->new; - - $tin->curiously('Curiouser and curiouser'); - print $tin->{curiously}; # prints 'Curiouser and curiouser' - - - # Subclassing works, too. - package Mint::Snuff; - use base qw(Altoids); - - my Mint::Snuff $pouch = Mint::Snuff->new; - $pouch->strong('Fuck you up strong!'); - print $pouch->{strong}; # prints 'Fuck you up strong!' - - -Here's a simple example of altering the behavior of your accessors. - - package Foo; - use base qw(Class::Accessor); - Foo->mk_accessor(qw(this that up down)); - - sub get { - my $self = shift; - - # Note every time someone gets some data. - print STDERR "Getting @_\n"; - - $self->SUPER::get(@_); - } - - sub set { - my ($self, $key) = splice(@_, 0, 2); - - # Note every time someone sets some data. - print STDERR "Setting $key to @_\n"; - - $self->SUPER::set($key, @_); - } - - -=head1 CAVEATS AND TRICKS - -Class::Accessor has to do some internal wackiness to get its -job done quickly and efficiently. Because of this, there's a few -tricks and traps one must know about. - -Hey, nothing's perfect. - -=head2 Don't make a field called DESTROY - -This is bad. Since DESTROY is a magical method it would be bad for us -to define an accessor using that name. Class::Accessor will -carp if you try to use it with a field named "DESTROY". - -=head2 Overriding autogenerated accessors - -You may want to override the autogenerated accessor with your own, yet -have your custom accessor call the default one. For instance, maybe -you want to have an accessor which checks its input. Normally, one -would expect this to work: - - package Foo; - use base qw(Class::Accessor); - Foo->mk_accessors(qw(email this that whatever)); - - # Only accept addresses which look valid. - sub email { - my($self) = shift; - my($email) = @_; - - if( @_ ) { # Setting - require Email::Valid; - unless( Email::Valid->address($email) ) { - carp("$email doesn't look like a valid address."); - return; - } - } - - return $self->SUPER::email(@_); - } - -There's a subtle problem in the last example, and its in this line: - - return $self->SUPER::email(@_); - -If we look at how Foo was defined, it called mk_accessors() which -stuck email() right into Foo's namespace. There *is* no -SUPER::email() to delegate to! Two ways around this... first is to -make a "pure" base class for Foo. This pure class will generate the -accessors and provide the necessary super class for Foo to use: - - package Pure::Organic::Foo; - use base qw(Class::Accessor); - Pure::Organic::Foo->mk_accessors(qw(email this that whatever)); - - package Foo; - use base qw(Pure::Organic::Foo); - -And now Foo::email() can override the generated -Pure::Organic::Foo::email() and use it as SUPER::email(). - -This is probably the most obvious solution to everyone but me. -Instead, what first made sense to me was for mk_accessors() to define -an alias of email(), _email_accessor(). Using this solution, -Foo::email() would be written with: - - return $self->_email_accessor(@_); - -instead of the expected SUPER::email(). - - -=head1 CURRENT AUTHOR - -Marty Pauley - -=head1 ORIGINAL AUTHOR - -Michael G Schwern - -=head1 THANKS - -Liz, for performance tweaks. - -Tels, for his big feature request/bug report. - - -=head1 SEE ALSO - -L - -These are some modules which do similar things in different ways -L, L, L, -L, L - -L for an example of this module in use. - -=cut - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 618] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash Message-ID: <20051024192043.333922AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case.pm Tue Oct 25 04:20:43 2005 @@ -1,198 +0,0 @@ - -package Hash::Case; - -use Tie::Hash; - @ ISA = 'Tie::StdHash'; - -use strict; -use Carp; - -our $VERSION = 1.003; - -=head1 NAME - -Hash::Case - base class for hashes with key-casing requirements - -=head1 CLASS HIERARCHY - - Hash::Case - is a Tie::StdHash - is a Tie::Hash - -=head1 SYNOPSIS - - use Hash::Case::Lower; - tie my(%lchash), 'Hash::Case::Lower'; - $lchash{StraNGeKeY} = 3; - print keys %lchash; # strangekey - -=head1 DESCRIPTION - -Hash::Case is the base class for various classes which tie special -treatment for the casing of keys. Be aware of the differences in -implementation: C and C are tied native hashes: -these hashes have no need for hidden fields or other assisting -data structured. A case C hash will actually create -three hashes. - -The following strategies are implemented: - -=over 4 - -=item * Hash::Case::Lower (native hash) - -Keys are always considered lower case. The internals of this -module translate any incoming key to lower case before it is used. - -=item * Hash::Case::Upper (native hash) - -Like the ::Lower, but then all keys are always translated into -upper case. This module can be of use for some databases, which -do translate everything to capitals as well. To avoid confusion, -you may want to have you own internal Perl hash do this as well. - -=item * Hash::Case::Preserve - -The actual casing is ignored, but not forgotten. - -=back - -=head1 METHODS - -=over 4 - -=cut - -#------------------------------------------- - -=item tie HASH, TIE, [VALUES,] OPTIONS - -Tie the HASH with the TIE package which extends L. The OPTIONS -differ per implementation: read the manual page for the package you actually -use. The VALUES is a reference to an array containing key-value pairs, -or a reference to a hash: they fill the initial hash. - -Examples: - - my %x; - tie %x, 'Hash::Case::Lower'; - $x{Upper} = 3; - print keys %x; # 'upper' - - my @y = (ABC => 3, DeF => 4); - tie %x, 'Hash::Case::Lower', \@y; - print keys %x; # 'abc' 'def' - - my %z = (ABC => 3, DeF => 4); - tie %x, 'Hash::Case::Lower', \%z; - -=cut - -sub TIEHASH(@) -{ my $class = shift; - my $to = @_ % 2 ? shift : undef; - my %opts = (@_, add => $to); - (bless {}, $class)->init( \%opts ); -} - -# Used for case-insensitive hashes which do not need more than -# one hash. -sub native_init($) -{ my ($self, $args) = @_; - my $add = delete $args->{add}; - - if(!$add) { ; } - elsif(ref $add eq 'ARRAY') { $self->addPairs(@$add) } - elsif(ref $add eq 'HASH') { $self->addHashData($add) } - else { croak "Cannot initialize the native hash this way." } - - $self; -} - -# Used for case-insensitive hashes which are implemented around -# an existing hash. -sub wrapper_init($) -{ my ($self, $args) = @_; - my $add = delete $args->{add}; - - if(!$add) { ; } - elsif(ref $add eq 'ARRAY') { $self->addPairs(@$add) } - elsif(ref $add eq 'HASH') { $self->setHash($add) } - else { croak "Cannot initialize a wrapping hash this way." } - - $self; -} - -#------------------------------------------- - -=item addPairs PAIRS - -Specify an even length list of alternating key and value to be stored in -the hash. - -=cut - -sub addPairs(@) -{ my $self = shift; - $self->STORE(shift, shift) while @_; - $self; -} - -#------------------------------------------- - -=item addHashData HASH - -Add the data of a hash (passed as reference) to the created tied hash. The -existing values in the hash remain, the keys are adapted to the needs of the -the casing. - -=cut - -sub addHashData($) -{ my ($self, $data) = @_; - while(my ($k, $v) = each %$data) { $self->STORE($k, $v) } - $self; -} - -#------------------------------------------- - -=item setHash HASH - -The functionality differs for native and wrapper hashes. For native -hashes, this is the same as first clearing the hash, and then a call -to addHashData. Wrapper hashes will use the hash you specify here -to store the data, and re-create the mapping hash. - -=cut - -sub setHash($) -{ my ($self, $hash) = @_; # the native implementation is the default. - %$self = %$hash; - $self; -} - -#------------------------------------------- - -=head1 SEE ALSO - -L -L -L - -=head1 AUTHOR - -Mark Overmeer (F). -All rights reserved. This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 VERSION - -This code is beta, version 1.003 - -Copyright (c) 2002-2003 Mark Overmeer. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 619] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor Message-ID: <20051024192043.1663C2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor/Fast.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor/Fast.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor/Fast.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor/Fast.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Class/Accessor/Fast.pm Tue Oct 25 04:20:43 2005 @@ -1,94 +0,0 @@ -package Class::Accessor::Fast; -use base 'Class::Accessor'; -use strict; -$Class::Accessor::Fast::VERSION = '0.19'; - -=head1 NAME - -Class::Accessor::Fast - Faster, but less expandable, accessors - -=head1 SYNOPSIS - - package Foo; - use base qw(Class::Accessor::Fast); - - # The rest as Class::Accessor except no set() or get(). - -=head1 DESCRIPTION - -This is a somewhat faster, but less expandable, version of -Class::Accessor. Class::Accessor's generated accessors require two -method calls to accompish their task (one for the accessor, another -for get() or set()). Class::Accessor::Fast eliminates calling -set()/get() and does the access itself, resulting in a somewhat faster -accessor. - -The downside is that you can't easily alter the behavior of your -accessors, nor can your subclasses. Of course, should you need this -later, you can always swap out Class::Accessor::Fast for -Class::Accessor. - -=cut - -sub make_accessor { - my($class, $field) = @_; - - return sub { - my $self = shift; - return $self->{$field} unless @_; - $self->{$field} = (@_ == 1 ? $_[0] : [@_]); - }; -} - - -sub make_ro_accessor { - my($class, $field) = @_; - - return sub { - return $_[0]->{$field} unless @_ > 1; - my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot alter the value of '$field' on ". - "objects of class '$class'"); - }; -} - - -sub make_wo_accessor { - my($class, $field) = @_; - - return sub { - my $self = shift; - - unless (@_) { - my $caller = caller; - require Carp; - Carp::croak("'$caller' cannot access the value of '$field' on ". - "objects of class '$class'"); - } - else { - return $self->{$field} = (@_ == 1 ? $_[0] : [@_]); - } - }; -} - - -=head1 EFFICIENCY - -L for an efficiency comparison. - -=head1 CURRENT AUTHOR - -Marty Pauley - -=head1 ORIGINAL AUTHOR - -Michael G Schwern - -=head1 SEE ALSO - -L - -=cut - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 621] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/icons Message-ID: <20051024192043.D496C2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/icons/normal.jpg Index: affelio_farm/admin/skelton/affelio/apps/Mixi/icons/over.jpg Index: affelio_farm/admin/skelton/affelio/apps/Mixi/icons/template.jpg From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 622] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/images Message-ID: <20051024192043.F235A2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/images/Affelio-mixi.png Index: affelio_farm/admin/skelton/affelio/apps/Mixi/images/mixi.png From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 623] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/lib/AffelioApp Message-ID: <20051024192044.1AC162AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/lib/AffelioApp/SNSGateway.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/lib/AffelioApp/SNSGateway.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/lib/AffelioApp/SNSGateway.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/lib/AffelioApp/SNSGateway.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/lib/AffelioApp/SNSGateway.pm Tue Oct 25 04:20:44 2005 @@ -1,47 +0,0 @@ -#!/usr/bin/perl -use strict; - -package AffelioApp::SNSGateway; -{ - use Exporter; - @AffelioApp::SNSGateway::ISA = "Exporter"; - @AffelioApp::SNSGateway::EXPORT = qw (read_config write_config); - - sub write_config{ - my $afap =shift; - my $u =shift; - my $p =shift; - - my $cfg = Config::Tiny->new(); - - $cfg->{user}->{username} = $u; - $cfg->{user}->{password} = $p; - - my $filename = $afap->get_userdata_dir() . "/config.ini"; - $cfg->write($filename); - - return(); - } - - sub read_config{ - my $afap =shift; - my $username=""; - my $password=""; - - my $filename = $afap->get_userdata_dir() . "/config.ini"; - - my $cfg = Config::Tiny->new(); - $cfg = Config::Tiny->read($filename); - - if($cfg){ - $username = $cfg->{user}->{username}; - $password = $cfg->{user}->{password}; - } - - return({username => $username, - password => $password} - ); - } - -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 625] CVS update: affelio_farm/admin/skelton/affelio/apps/album Message-ID: <20051024192044.648FF2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/AF_app.cfg diff -u affelio_farm/admin/skelton/affelio/apps/album/AF_app.cfg:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/AF_app.cfg:removed --- affelio_farm/admin/skelton/affelio/apps/album/AF_app.cfg:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/AF_app.cfg Tue Oct 25 04:20:44 2005 @@ -1,13 +0,0 @@ -[this_installation] -title=Album - -[application] -app_name=album -app_version=1.3 -app_desc=???????????-app_author=Affelio project -guest_index=index.cgi -owner_index=owner.cgi -action_types=add_image, write_comment -action_types_desc=?糸??脂?,?潟??潟??吾?莨若? - Index: affelio_farm/admin/skelton/affelio/apps/album/Album.pm diff -u affelio_farm/admin/skelton/affelio/apps/album/Album.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/Album.pm:removed --- affelio_farm/admin/skelton/affelio/apps/album/Album.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/Album.pm Tue Oct 25 04:20:44 2005 @@ -1,480 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -package Album; - -use strict; -use DBI; -use Jcode; -use HTML::Template; -use Config::Tiny; -use Album::L10N; - -############################################## -# Constructor -############################################## -sub new { - my ($proto, $afap) = @_; - unless ($afap) { die("Album::new: Error: missing username\n"); } - - my $self = {}; - $self->{afap} = $afap; - $self->{tmpfile}= $afap->get_userdata_dir()."/.sqltmp"; - $self->{album_tb}= "album_$afap->{install_name}_entries"; - $self->{image_tb}= "album_$afap->{install_name}_images"; - $self->{comment_tb}= "album_$afap->{install_name}_comments"; - $self->{dbh} = undef; - #initialize - - ########################### - #Locale init - ########################### - $self->{lh} = Album::L10N->get_handle(($afap->get_site_info("locale"), - $afap->get_site_info("locale"))); - ########################### - - unless(-f $self->{tmpfile}) { - open(TMP,"> $self->{tmpfile}"); - close(TMP); - $self->{dbh} = $afap->get_userdata_dbh(); - #Album table - my $query; - $query="id INTEGER".get_query_primarykey($self)." - title TEXT, - contents TEXT, - timestamp INTEGER, - update_time INTEGER, - user TEXT, - afid TEXT, - pswd TEXT, - ord INTEGER"; - - $self->{dbh}->do("CREATE TABLE $self->{album_tb} ($query)"); - - #Comment table - $query="pkey INTEGER".get_query_primarykey($self)." - id INTEGER, - user TEXT, - afid TEXT, - comment TEXT, - pswd TEXT, - timestamp INTEGER"; - - $self->{dbh}->do("CREATE TABLE $self->{comment_tb} ($query)"); - - - - # Image table - $query="pkey INTEGER".get_query_primarykey($self)." - id INTEGER, - image TEXT, - title TEXT, - user TEXT, - afid TEXT, - comment TEXT, - pswd TEXT, - timestamp INTEGER"; - - $self->{dbh}->do("CREATE TABLE $self->{image_tb} ($query)"); - - } - else { - $self->{dbh} = $afap->get_userdata_dbh(); - } - - bless $self, $proto; - return $self; -} - -############################################## -# destructor -############################################## - -sub DESTROY { - my $self = shift; - $self->{dbh}->disconnect; -} - - -############################################## -# addAlbum -############################################## - -sub addAlbum { - my ($self, $title, $contents, $user, $afid, $time) = @_; - unless ($time) { $time = time; } - - my $id = $self->getColumn("SELECT MAX(id) FROM $self->{album_tb}"); - $title = $self->validate($title); - $user = $self->validate($user); - $contents = $self->validate($contents); - - $self->{dbh}->do("INSERT INTO $self->{album_tb} (title, contents, timestamp, update_time, user, afid, pswd, ord) VALUES ($title, $contents, $time, $time, $user, '$afid', '', '')"); - $id = $self->getColumn("SELECT MAX(id) FROM $self->{album_tb}"); - - my $data_dir=$self->{afap}->get_userdata_dir()."/"; - $data_dir.= $id; - if (!-d $data_dir){ - mkdir $data_dir, 0777; - } - $data_dir.= "/thumbnail"; - if (!-d $data_dir){ - mkdir $data_dir, 0777; - } -} - -############################################## -# addImage -############################################## - -sub addImage { - my ($self, $id, $title, $user, $afid, $comment, $image) = @_; - my $time = time; - - $title = $self->validate($title); - $comment = $self->validate($comment); - $image = $self->validate($image); - $user = $self->validate($user); - - my @same = $self->getall("SELECT id FROM $self->{image_tb} WHERE id = $id AND image = $image"); - if($#same > 0) { - $self->{dbh}->do("UPDATE $self->{image_tb} SET title = $title, comment=$comment, user=$user, afid='$afid', time=$time WHERE id = $id AND image=$image"); - }else{ - $self->{dbh}->do("INSERT INTO $self->{image_tb} (id, image, title, user, afid, comment, pswd, timestamp) VALUES ($id, $image, $title, $user, '$afid', $comment, '', $time)"); - } -} - - - -############################################## -# updateEntry -############################################## - -sub updateEntry { - my ($self, $id, $title, $contents) = @_; - $title = $self->validate($title); - $contents = $self->validate($contents); - my $time = time; - $self->{dbh}->do("UPDATE $self->{album_tb} SET title = $title, contents = $contents, update_time=$time WHERE id = $id"); -} - -############################################## -# updateImage -############################################## - -sub updateImage { - my ($self, $id, $title, $comment, $image) = @_; - $title = $self->validate($title); - $comment = $self->validate($comment); - $image = $self->validate($image); - my $time = time; - $self->{dbh}->do("UPDATE $self->{image_tb} SET title = $title, comment = $comment WHERE id = $id AND image=$image"); -} - -############################################## -# updateTimestamp -############################################## - -sub updateTimestamp { - my ($self, $id) = @_; - my $time = time; - $self->{dbh}->do("UPDATE $self->{album_tb} SET update_time=$time WHERE id = $id"); -} - - -############################################## -# removeAlbum -############################################## - -sub removeAlbum { - my ($self, $id) = @_; - my @ret = $self->getall("SELECT * FROM $self->{image_tb} WHERE id = $id"); - $self->{dbh}->do("DELETE FROM $self->{album_tb} WHERE id = $id"); - $self->{dbh}->do("DELETE FROM $self->{comment_tb} WHERE id = $id"); - $self->{dbh}->do("DELETE FROM $self->{image_tb} WHERE id = $id"); - my $data_dir=$self->{afap}->get_userdata_dir()."/".$id."/"; - my $thumb_dir=$data_dir."thumbnail/"; - foreach(@ret){ - unlink($thumb_dir.$_->{image}); - unlink($data_dir.$_->{image}); - } - if (-d $thumb_dir){ - rmdir $thumb_dir; - } - if (-d $data_dir){ - rmdir $data_dir; - } -} - -############################################## -# removeImage -############################################## - -sub removeImage { - my ($self, $id, @pkey) = @_; - my $data_dir=$self->{afap}->get_userdata_dir()."/".$id."/"; - my $thumb_dir=$data_dir."thumbnail/"; - my @ret; - foreach(@pkey){ - @ret = $self->getall("SELECT * FROM $self->{image_tb} WHERE id = $id AND pkey=$_"); - $self->{dbh}->do("DELETE FROM $self->{image_tb} WHERE id = $id AND pkey=$_"); - - unlink($data_dir.$ret[0]->{image}); - unlink($thumb_dir.$ret[0]->{image}); - } -} - -############################################## -# removeComment -############################################## - -sub removeComment { - my ($self, $id, @pkey) = @_; - foreach(@pkey){ - $self->{dbh}->do("DELETE FROM $self->{comment_tb} WHERE id = $id AND pkey=$_"); - } -} - - -############################################## -# getEntry -############################################## - -sub getEntry { - my ($self, $id) = @_; - my @ret = $self->getall("SELECT * FROM $self->{album_tb} WHERE id = $id"); - return $ret[0]; -} - -############################################## -# getImage -############################################## - -sub getImage { - my ($self, $id, $pkey) = @_; - my @ret = $self->getall("SELECT * FROM $self->{image_tb} WHERE id = $id AND pkey=$pkey"); - return $ret[0]; -} -sub getAllImage { - my ($self, $id) = @_; - return $self->getall("SELECT * FROM $self->{image_tb} WHERE id = $id"); -} - -sub checkImagefile { - my ($self, $id, $image) = @_; - my @ret = $self->getall("SELECT * FROM $self->{image_tb} WHERE id = $id AND image='$image'"); - return $ret[0]; -} - -############################################## -# getNewestEntries -############################################## - -sub getNewestEntries { - my ($self, $num) = @_; - unless ($num) { $num = 5; } - return $self->getall("SELECT * FROM $self->{album_tb} ORDER BY update_time DESC LIMIT $num"); -} - -############################################## -# getNewestAlbumId -############################################## - -sub getNewestAlbumId { - my ($self) = @_; - my @ret = $self->getall("SELECT MAX(id) as id FROM $self->{album_tb}"); - return $ret[0]; -} - -############################################## -# getAllEntries -############################################## - -sub getAllEntries { - my ($self) = @_; - return $self->getall("SELECT * FROM $self->{album_tb} ORDER BY update_time DESC"); -} - - -############################################## -# addComment -############################################## - -sub addComment { - my ($self, $id, $user, $afid, $comment) = @_; - my $time = time; - $user = $self->validate($user); - $comment = $self->validate($comment); - - # - my @same = $self->getall("SELECT id FROM $self->{comment_tb} WHERE user = $user AND comment = $comment"); - if($#same >= 0) { return; } - - $self->{dbh}->do("INSERT INTO $self->{comment_tb} (id, user, afid, comment, pswd, timestamp) VALUES ($id, $user, '$afid', $comment, '', $time)"); -} - - -############################################## -# getComments -############################################## -sub getComments { - my ($self, $id) = @_; - return $self->getall("SELECT * FROM $self->{comment_tb} WHERE id = $id ORDER BY timestamp"); -} - -############################################## -# getCommentsNo -############################################## -sub getCommentsNo { - my ($self, $id) = @_; - return $self->getColumn("SELECT COUNT(*) FROM $self->{comment_tb} WHERE id = $id"); -} - -############################################## -# getColumn -############################################## -sub getColumn { - my ($self, $query) = @_; - my $sth = $self->{dbh}->prepare($query); - $sth->execute; - my $num; - $sth->bind_columns(undef, \$num); - $sth->fetch; - $sth->finish; - if($num) { - return $num; - } - else { - return 0; - } -} - -############################################## -# get all columns -############################################## -sub getall { - my ($self, $query) = @_; - - my $sth = $self->{dbh}->prepare($query); - $sth->execute; - - my @ret; - while(my $row = $sth->fetchrow_hashref) { - push @ret, $row; - } - $sth->finish; - - return @ret; -} - -############################################## -# validate -############################################## -sub validate { - my ($self, $str) = @_; - - $str =~ s/[\t\a]//g; - $str =~ s/&/&/g; - $str =~ s/'/"/g; - $str =~ s/"/"/g; - $str =~ s//>/g; - $str =~ s/\r\n/
/g; - $str =~ s/[\r\n]/
/g; - $str =~ s/(s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/
$1<\/a>/g; - $str = $self->{dbh}->quote($str); - return $str; -} - - -############################################################################ -# get primary key for DBs -############################################################################ -sub get_query_primarykey { - my ($self) = @_; - my $DBConfig = Config::Tiny->new(); - $DBConfig = Config::Tiny->read("$self->{afap}->{af}->{site__user_dir}/db.cfg"); - my $db_type = $DBConfig->{db}->{type}; - my $query; - - if ($db_type eq "sqlite"){ - $query = " PRIMARY KEY,"; - }elsif ($db_type eq "mysql"){ - $query = " AUTO_INCREMENT PRIMARY KEY,"; - } - return $query; -} - - -############################################################################ -#L10N added by slash -############################################################################ -sub translate_templateL10N{ - my $af=shift; - my $mesg = shift; - - my $tag_body =""; - my $text_value=""; - my $param_value=""; - - while( $mesg =~ /]+)>/ ){ - $tag_body = $1; - - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["'](\s*)param(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - $param_value=$7; - if($text_value eq ""){ - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - } - - my $sbst = $af->{lh}->maketext($text_value, $param_value); - -# debug_print("Album::translate tag_body = [$tag_body]\n"); -# debug_print("Album::translate \t text=[$text_value]\n"); -# debug_print("Album::translate \t param=[$param_value]\n"); -# debug_print("Album::translate \t sbst=[$sbst]\n"); - - $mesg =~ s/\Q\E/$sbst/g; - } - return($mesg); -} - -############################################################################ -#Show Error -############################################################################ -sub errorExit { - my ($self,$msg) = @_; - my $affelio_id = $self->{afap}->get_visitor_info("afid"); - my $visitor_type=$self->{afap}->get_visitor_info("type"); - - if($visitor_type eq ""){ - $visitor_type="pb"; - } - my $tmpl = HTML::Template->new(filename => "./templates/error.tmpl"); - $tmpl->param(V_TYPE => $visitor_type); - $tmpl->param(AF_ID => $affelio_id); - $tmpl->param(MSG => $msg); - - print $self->translate_templateL10N( $tmpl->output ); - print $self->{afap}->get_HTML_footer(); - exit; -} - -1; - - - Index: affelio_farm/admin/skelton/affelio/apps/album/album.cgi diff -u affelio_farm/admin/skelton/affelio/apps/album/album.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/album.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/album/album.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/album.cgi Tue Oct 25 04:20:44 2005 @@ -1,362 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -use strict; -use lib("../../extlib"); -use lib("../../lib"); -use HTML::Template; -use CGI; -use Cwd; -use File::Basename; -use AffelioApp; -use Album; - -############################################## -# Initialize AFAP & put header -############################################## -our $cgi = new CGI(); -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), cgi => $cgi); -our $album = new Album($afap); - -# put Content-type -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; -# put HTML Header -print $afap->get_HTML_header("Affelio Photo Album"); -# check access -unless ($afap->check_access("DF_access")) { - $album->errorExit(''); -} - -############################################## -# Image Viewer -############################################## -if ($cgi->param("mode") eq "image_view"){ - my $id = $afap->{cgi}->param("id"); - my $afid = $afap->get_visitor_info("afid"); - my $pkey=$afap->{cgi}->param("pkey"); - my $entry = $album->getEntry($id); - my $image_data = $album->getImage($id,$pkey); - my $tmpl = HTML::Template->new(filename => "./templates/image_view.tmpl"); - -#Content Owner can edit it - if($afap->check_access("add_image")){ - if($image_data->{afid} eq $afid || $afap->get_visitor_info("type") eq "self") { - $tmpl->param(EDIT_COMMENT => 1); - } - } - -# Album info - $tmpl->param( - TITLE => $entry->{title}, - ID => $id, - PKEY => $pkey, - ); - - my $user_uri=''; - if ($image_data->{user} eq ''){ - $user_uri="?????"; - }else{ - $user_uri=''.$image_data->{user}.""; - } - - $tmpl->param(IMAGE_OWNER => $user_uri); - if ($image_data->{title}){ - $tmpl->param(HAS_TITLE => '1'); - $tmpl->param(IMAGE_TITLE => $image_data->{title}); - } - if ($image_data->{comment}){ - $tmpl->param(HAS_COMMENT => '1'); - $tmpl->param(IMAGE_COMMENT => $image_data->{comment}); - } - if ($image_data->{image}){ - $tmpl->param(HAS_IMAGE => '1'); - $tmpl->param(IMAGE => $image_data->{image}); - } - -#show image - my @image_files; - my @image_row; - my @image_filelist=$album->getAllImage($id); - my $i=0; - my $max=$#image_filelist; - foreach(@image_filelist){ - if ($_->{pkey} eq $pkey){ - if ($i>0){ - $tmpl->param( - HAS_PREV => 1, - PREV_IMAGE=> $image_filelist[$i-1]->{pkey} - ); - } - if ($i<$max){ - $tmpl->param( - HAS_NEXT => 1, - NEXT_IMAGE=> $image_filelist[$i+1]->{pkey} - ); - } - } - $i++; - } - - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Edit a caption (Image Viewer) -############################################## -}elsif ($cgi->param("mode") eq "edit_caption"){ - my $id = $afap->{cgi}->param("id"); - my $afid = $afap->get_visitor_info("afid"); - my $pkey = $afap->{cgi}->param("pkey"); - my $image_data = $album->getImage($id,$pkey); - -# owner can edit it - if($afap->check_access("add_image")){ - unless($image_data->{afid} eq $afid || $afap->get_visitor_info("type") eq "self") { - $album->errorExit(''); - } - } - - my $tmpl = HTML::Template->new(filename => "./templates/edit_caption.tmpl"); - - $tmpl->param(ID => $id, PKEY => $pkey); - -# done edit - if($afap->{cgi}->param("edit")) { - $album->updateImage($id, $afap->{cgi}->param("title"), - $afap->{cgi}->param("comment"), - $image_data->{image}); - $tmpl->param(DONE => "1"); - } - -# edit comment - elsif ($afap->{cgi}->param("comment_edit")){ - $tmpl->param(EDIT => "1"); - my $entry = $album->getImage($id,$pkey); - $entry->{comment} =~ s/
/\n/g; - $tmpl->param( - TITLE => $entry->{title}, - COMMENT => $entry->{comment}, - PKEY => $entry->{pkey}, - ); - } - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Write a comment (Thumbnail Viewer) -############################################## -}elsif ($cgi->param("mode") eq "write_comment"){ - unless ($afap->check_access("write_comment")){ - $album->errorExit(''); - } - - my $comment = $afap->{cgi}->param('comment'); - my $tmpl = HTML::Template->new(filename => "./templates/write_comment.tmpl"); - my $id = $afap->{cgi}->param('id') or exit; - my $user = $afap->get_visitor_info("nickname"); - my $afid = $afap->get_visitor_info("afid"); - my $user_uri=""; - - if(!$user){ - $user = ""; - $user_uri = 'Guest'; - $afid=""; - } - else{ - $user_uri=''.$user.""; - } - -# confirm comment - if($afap->{cgi}->param('comment_confirm')) { - $tmpl->param(CONFIRM => "1", COMMENT => $comment, ID => $id, USER_NAME => $user_uri); - } - -# submit comment - elsif($afap->{cgi}->param('comment_commit')) { - $album->addComment($id, $user, $afid, $comment); - $album->updateTimestamp($id); - $tmpl->param(COMMIT => "1", ID => $id); - } - - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Default (Show Thumbnails) -############################################## -}else{ - my $id = $afap->{cgi}->param("id"); - my $entry = $album->getEntry($id); - my $edit = 0; - my $save_file=0; - - if($afap->check_access("add_image")) { - $edit = 1; - } - - my $tmpl = HTML::Template->new(filename => "./templates/album.tmpl"); - my $col_num=4; - - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($entry->{timestamp}); - my ($up_sec, $up_min, $up_hour, $up_mday, $up_mon, $up_year) = localtime($entry->{update_time}); - $mon+=1; - $year+=1900; - $up_mon+=1; - $up_year+=1900; - -# Album info - $tmpl->param( - YEAR => $year, - MONTH => $mon, - DAY => $mday, - UP_YEAR => $up_year, - UP_MONTH=> $up_mon, - UP_DAY => $up_mday, - TITLE => $entry->{title}, - CONTENTS=> $entry->{contents}, - ID => $id, - EDITABLE=> $edit, - ); - -# upload image - if ($afap->{cgi}->param("image_upload")){ - my $filehandle=$cgi->param("uploadingfile"); #Get file handle - if ($filehandle){ - fileparse_set_fstype("MSDOS"); #For IE user - my $basename = basename($filehandle,""); - if ($basename =~ /^[a-zA-Z0-9\.\-\_]{1,32}$/ ){ #Check Filename - my $fname=$afap->get_userdata_dir().'/'.$id.'/'.$basename; - my $thumb_fname=$afap->get_userdata_dir().'/'.$id.'/thumbnail/'.$basename; - my $chkFile = $album->checkImagefile($id,$basename); - if ($chkFile->{image} eq $basename){ - unless ($afap->{cgi}->param("rewrite")){ - $tmpl->param(EXIST_SAMEFILE => 1); - $tmpl->param(UPLOAD_IMAGE => $basename); - }else{#override(not yet) - $save_file=2; - } - }else{ - $save_file=1; - } - - if ($save_file){ - # Save file - open (OUT,">$fname") or die "Can't make serverside file!\n"; - while (my $bytesread = read($filehandle,my $buffer,1024)){ - print OUT $buffer; - } - close(OUT); - - (eval 'use Image::Magick; 1;' ) ? ( $tmpl->param(IMAGEMAGICK => 0) ) : ( $tmpl->param(IMAGEMAGICK =>1) ); - my $image = Image::Magick->new; - $image->Read( $fname ); - $image->Resize( geometry=>"100x100" ); - $image->Set( quality=>75 ); - $image->Write( $thumb_fname ); - - my $title = $afap->{cgi}->param("title"); - my $comment = $afap->{cgi}->param("comment"); - my $user = $afap->get_visitor_info("nickname"); - my $afid = $afap->get_visitor_info("afid"); - - if(!$user){ - $user = ''; - $afid = ''; - } - if ($save_file=1){ - $album->addImage($id, $title, $user, $afid, $comment, $basename); - }elsif($save_file=2){ - $album->updateImage($id, $title, $comment, $basename); - } - $album->updateTimestamp($id); - $tmpl->param(DONE_UPLOAD => 1); - $tmpl->param(UPLOAD_IMAGE => $basename); - } - }else{ - $tmpl->param(ERR_FILENAME => 1); - } - } - else{ - $tmpl->param(NO_FILENAME => 1); - } - } - -#Show thumbnail - my @image_files; - my @image_row; - my @image_filelist=$album->getAllImage($id); - if ($#image_filelist>=0){ - $tmpl->param(HAS_IMAGE => 1); - for (my $i=0; $i<($#image_filelist+1)%$col_num; $i++){ - push @image_filelist, - { - image => "", - pkey => "", - } - } - - for (my $i=0; $i<($#image_filelist+1)/$col_num; $i++){ - my $i_num=$i*$col_num; - for (my $j=0; $j<$col_num; $j++){ - push @image_files, - { - IMAGE => $image_filelist[$i_num+$j]->{image}, - ID2 => $id, - PKEY => $image_filelist[$i_num+$j]->{pkey}, - }; - } - push @image_row, - {IMG => [@image_files[$i_num..($i_num+($col_num-1))]]}; - - } - $tmpl->param(THUMBNAIL => \@image_row); - } - -# Show Comment - if($album->getCommentsNo($id) > 0) { - $tmpl->param(HAS_COMMENTS => 1); - my $user_uri; - my @comments_param; - my @comments = $album->getComments($id); - foreach(@comments) { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{timestamp}); - $mon += 1; - if ($_->{user} eq ''){ - $user_uri="Guest"; - }else{ - $user_uri=''.$_->{user}.""; - } - push @comments_param, - { - UNAME => $user_uri, - COMMENT_TIME => "$mon/$mday/$hour:$min", - COMMENT => $_->{comment} - }; - } - $tmpl->param(COMMENTS => \@comments_param); - } - - if($afap->check_access("write_comment")){ - $tmpl->param("comment_write" => "true"); - } - - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); -} - - Index: affelio_farm/admin/skelton/affelio/apps/album/index.cgi diff -u affelio_farm/admin/skelton/affelio/apps/album/index.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/index.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/album/index.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/index.cgi Tue Oct 25 04:20:44 2005 @@ -1,80 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -use strict; -use lib("../../extlib"); -use lib("../../lib"); -use HTML::Template; -use CGI; -use Cwd; -use AffelioApp; -use Album; - - -#Initialize AFAP -our $cgi = new CGI(); -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), cgi => $cgi); -our $album = new Album($afap); - -# put Content-type -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; -# put HTML Header -print $afap->get_HTML_header("Affelio Photo Album"); -# check access -unless ($afap->check_access("DF_access")) { - $album->errorExit(''); -} - -my $user = $afap->{cgi}->param("user"); - -my $tmpl; -############################################################### -# Owner can add album - my $edit = 0; - if ($afap->get_visitor_info("type") eq "self"){ - $edit = 1; - } - - $tmpl = HTML::Template->new(filename => "./templates/index.tmpl"); - my @entries_param; - my @entries; - my @images; - @entries = $album->getAllEntries; - $tmpl->param(install_title => $afap->get_app_info("install_title"), EDITABLE => $edit); - - foreach(@entries) { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{update_time}); - $mon+=1; - $year+=1900; - @images = $album->getAllImage($_->{id}); - - push @entries_param, - { - MONTH => $mon, - DAY => $mday, - #TIME => sprintf("%02d:%02d", $hour, $min), - TITLE => $_->{title}, - CONTENTS=> $_->{contents}, - COMMENT_NO => $album->getCommentsNo($_->{id}), - ID => $_->{id}, - IMAGE => $images[0]->{image}, - }; - } - $tmpl->param(ENTRIES => \@entries_param); - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); Index: affelio_farm/admin/skelton/affelio/apps/album/owner.cgi diff -u affelio_farm/admin/skelton/affelio/apps/album/owner.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/owner.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/album/owner.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/owner.cgi Tue Oct 25 04:20:44 2005 @@ -1,255 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -use strict; -use lib("../../extlib"); -use lib("../../lib"); -use HTML::Template; -use CGI; -use Cwd; -use AffelioApp; -use Album; - - -############################################## -#Initialize AFAP & put header -############################################## -our $cgi = new CGI(); -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), cgi => $cgi); -our $album = new Album($afap); - -# put Content-type -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; -# put HTML Header -print $afap->get_HTML_header("Affelio Photo Album"); -# check access -unless ($afap->get_visitor_info("type") eq "self"){ - $album->errorExit(''); -} - -############################################## -# Add new album -############################################## -if ($cgi->param("mode") eq "add_album"){ - my $tmpl = HTML::Template->new(filename => "./templates/owner/add_album.tmpl"); - my $title = $afap->{cgi}->param("title"); - my $contents = $afap->{cgi}->param("contents"); - my $user = $afap->get_visitor_info("nickname"); - my $afid = $afap->get_visitor_info("afid"); - - $tmpl->param(TITLE => $title, CONTENTS => $contents); - - if($afap->{cgi}->param("submit")) { - $tmpl->param(SUBMIT => "1"); - $album->addAlbum($title, $contents, $user, $afid); - my $ret = $album->getNewestAlbumId; - $tmpl->param(ID => $ret->{id}); - } -# Confirm information - elsif($afap->{cgi}->param("confirm")) { - $tmpl->param(CONFIRM => "1"); - } -# Edit infomation - else { - $tmpl->param(EDIT => "1"); - } - - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Delete the album -############################################## -}elsif ($cgi->param("mode") eq "delete_album"){ - my $tmpl = HTML::Template->new(filename => "./templates/owner/delete_album.tmpl"); - my $id = $afap->{cgi}->param("id"); - $tmpl->param(ID => $id); - -# done delete - if($afap->{cgi}->param("delete")) { - $album->removeAlbum($id); - $tmpl->param(DONE => "1", DONE_LABEL => ''); - } -# confirm - elsif($afap->{cgi}->param("delete_confirm")) { - $tmpl->param(DELETE_CONFIRM => "1"); - } - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Update album infomation (Title and caption) -############################################## -}elsif ($cgi->param("mode") eq "edit_album_caption"){ - my $tmpl = HTML::Template->new(filename => "./templates/owner/edit_album_caption.tmpl"); - my $id = $afap->{cgi}->param("id"); - $tmpl->param(ID => $id); -# done edit - if($afap->{cgi}->param("edit")) { - $album->updateEntry($id, $afap->{cgi}->param("title"), $afap->{cgi}->param("contents")); - $tmpl->param(DONE => "1", DONE_LABEL => ''); - } - -# comment edit - elsif ($afap->{cgi}->param("comment_edit")){ - $tmpl->param(EDIT => "1"); - my $entry = $album->getEntry($id); - $entry->{contents} =~ s/
/\n/g; - $tmpl->param( - TITLE => $entry->{title}, - CONTENTS => $entry->{contents}, - ); - } - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Manage Contents (Show thumbnail and comments) -############################################## -}elsif ($cgi->param("mode") eq "manage_album_content"){ - my $tmpl = HTML::Template->new(filename => "./templates/owner/manage_album.tmpl"); - my $id = $afap->{cgi}->param("id"); - $tmpl->param(ID => $id); -# image edit -# if ($afap->{cgi}->param("image_arrange")){ -# $tmpl->param(ARRANGE => "1"); - -# show thumbnails - my $col_num=4; - my @image_files; - my @image_row; - my @image_filelist=$album->getAllImage($id); - if ($#image_filelist>=0){ - $tmpl->param(HAS_IMAGE => 1); - for (my $i=0; $i<($#image_filelist+1)%$col_num; $i++){ - push @image_filelist, - { - image => "", - pkey => "", - } - } - - for (my $i=0; $i<($#image_filelist+1)/$col_num; $i++){ - my $i_num=$i*$col_num; - for (my $j=0; $j<$col_num; $j++){ - push @image_files, - { - IMAGE => $image_filelist[$i_num+$j]->{image}, - ID2 => $id, - PKEY=> $image_filelist[$i_num+$j]->{pkey} - }; - } - push @image_row, - {IMG => [@image_files[$i_num..($i_num+($col_num-1))]]}; - } - $tmpl->param(THUMBNAIL => \@image_row); - } - -# comment - if($album->getCommentsNo($id) > 0) { - $tmpl->param(HAS_COMMENTS => 1); - my @comments_param; - my @comments = $album->getComments($id); - foreach(@comments) { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{timestamp}); - $mon += 1; - push @comments_param, - { - UNAME => $_->{user}, - COMMENT_TIME => "$mon/$mday/$hour:$min", - COMMENT => $_->{comment}, - PKEY=> $_->{pkey} - }; - } - $tmpl->param(COMMENTS => \@comments_param); - } -# } - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Delete Comments -############################################## -}elsif ($cgi->param("mode") eq "delete_comment"){ - my $tmpl = HTML::Template->new(filename => "./templates/owner/delete_comment.tmpl"); - my $id = $afap->{cgi}->param("id"); - my @pkey = $afap->{cgi}->param("delete_comment"); -#Done - if($afap->{cgi}->param("delete")) { - $album->removeComment($id, @ pkey); - $tmpl->param(ID => "$id"); - $tmpl->param(DONE => "1"); - } - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Delete Images -############################################## -}elsif ($cgi->param("mode") eq "delete_image"){ - my $tmpl = HTML::Template->new(filename => "./templates/owner/delete_image.tmpl"); - my $id = $afap->{cgi}->param("id"); - my @pkey = $afap->{cgi}->param("delete_image"); -# Done - if($afap->{cgi}->param("delete")) { - $album->removeImage($id, @ pkey); - $tmpl->param(ID => "$id"); - $tmpl->param(DONE => "1"); - } - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); - -############################################## -# Default (Owner mode) -############################################## -}else{ - my $tmpl = HTML::Template->new(filename => "./templates/owner/owner.tmpl"); - $tmpl->param(access_control_URL => $afap->get_URL("access_control")); - - my @entries_param; - my $year = $afap->{cgi}->param("year"); - my $month = $afap->{cgi}->param("month"); - my $day = $afap->{cgi}->param("day"); - my @entries; - my @images; - @entries = $album->getAllEntries;; - - my $i = 0; - foreach(@entries) { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{update_time}); - $mon+=1; - $year+=1900; - @images = $album->getAllImage($_->{id}); - - push @entries_param, - { - MONTH => $mon, - DAY => $mday, - #TIME => sprintf("%02d:%02d", $hour, $min), - TITLE => $_->{title}, - CONTENTS=> $_->{contents}, - ID => $_->{id}, - IMAGE => $images[0]->{image}, - EDITABLE=> 1 - }; - } - $tmpl->param(ENTRIES => \@entries_param, EDITABLE => 1); - $tmpl->param(install_title => $afap->get_app_info("install_title")); - print $album->translate_templateL10N( $tmpl->output ); - print $afap->get_HTML_footer(); -} Index: affelio_farm/admin/skelton/affelio/apps/album/show_image.cgi diff -u affelio_farm/admin/skelton/affelio/apps/album/show_image.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/show_image.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/album/show_image.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/show_image.cgi Tue Oct 25 04:20:44 2005 @@ -1,60 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -use strict; -use lib("../../extlib"); -use lib("../../lib"); -use CGI; -use Cwd; -use AffelioApp; - -our $cgi = new CGI(); -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -# Check access -if ($afap->check_access("DF_access")) { - my $image = $afap->{cgi}->param('image'); - my $id = $afap->{cgi}->param('id'); - my $type = $afap->{cgi}->param('type'); - my $filepath; - if ($type eq "thumbnail") { - $filepath = $afap->get_userdata_dir()."/".$id."/thumbnail/".$image; - }elsif($type eq "large"){ - $filepath = $afap->get_userdata_dir()."/".$id."/".$image; - }else{ - $filepath = "./resource/emp.jpg"; - } - if ($image eq ""){ - $filepath = "./resource/emp.jpg"; - } - my $imgtype = 'jpeg'; - -# open image file - open(IMG, "$filepath") or die; - -# show image - binmode IMG; - binmode STDOUT; - print "Content-type: image/$imgtype\n\n"; - print while (); - -# close image - close(IMG); -} - exit(0); Index: affelio_farm/admin/skelton/affelio/apps/album/style.css diff -u affelio_farm/admin/skelton/affelio/apps/album/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/style.css:removed --- affelio_farm/admin/skelton/affelio/apps/album/style.css:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/style.css Tue Oct 25 04:20:44 2005 @@ -1,16 +0,0 @@ -.photo_table{ - width: auto; - margin: 0px; - padding 0px; - border-style: none; - background-color: #fff; -} -.photo_frame{ - width: 160px; - height: 160px; - background-image: url("./resource/photo_frame.gif"); - background-repeat: no-repeat; - background-position: center; - text-align: center; - text-valign: middle; -} \ No newline at end of file From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 624] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/templates Message-ID: <20051024192044.3B6112AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/templates/admin.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/templates/admin.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/templates/admin.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/templates/admin.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/templates/admin.tmpl Tue Oct 25 04:20:44 2005 @@ -1,34 +0,0 @@ -
- - -
- -
-
- -
-
-
-: 荐???????-
-
- -Mixi????我??宴??ャ?????????? - - - - - - - - - -
email: ">
password: ">
- - - -" target="_blank">??TMPL_VAR NAME="install_title">????≪??祉??潟?????若?荐??????<? - -
- -
Index: affelio_farm/admin/skelton/affelio/apps/Mixi/templates/error.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/templates/error.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/templates/error.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/templates/error.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/templates/error.tmpl Tue Oct 25 04:20:44 2005 @@ -1,22 +0,0 @@ -
- - -
- -
-
- -
-
-
- -
-
-
-
-
-
-
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/Mixi/templates/index.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/templates/index.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/templates/index.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/templates/index.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/templates/index.tmpl Tue Oct 25 04:20:44 2005 @@ -1,43 +0,0 @@ -
- - -
- -
-
- -
-
- -
- - - -
- - -"> - - -"> - -
- -
-
-Note: ?≪??潟????????????????????潟????Mixi????潟??????????????若???ixi篌??絨??????吾??????????荳??Mixi????潟??若???????????????-

-Note: Mixi???????若?????????ffelio??????篁ュ???????????剛賢??;腓冴?????????????Mixi????吟????????≪??祉???????Mixi???????????;腓冴?????ゃ??激?羲闆???ゃ????????с????篋??筝????? -

- - -
Index: affelio_farm/admin/skelton/affelio/apps/Mixi/templates/owner.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/templates/owner.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/templates/owner.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/templates/owner.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/templates/owner.tmpl Tue Oct 25 04:20:44 2005 @@ -1,43 +0,0 @@ -
- - - - - -

- -

- - - -

- -" target="_blank"> -
- -
- -
- -
- - - -
- - -"> - - -"> - - - - -
From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 626] CVS update: affelio_farm/admin/skelton/affelio/apps/album/Album Message-ID: <20051024192044.879132AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/Album/L10N.pm diff -u affelio_farm/admin/skelton/affelio/apps/album/Album/L10N.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/Album/L10N.pm:removed --- affelio_farm/admin/skelton/affelio/apps/album/Album/L10N.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/Album/L10N.pm Tue Oct 25 04:20:44 2005 @@ -1,29 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: L10N.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Album::L10N; -{ - use strict; - use lib("../../../extlib"); - use Locale::Maketext; - - @Album::L10N::ISA = qw(Locale::Maketext); - @Album::L10N::Lexicon = (_AUTO => 1, - ); -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 627] CVS update: affelio_farm/admin/skelton/affelio/apps/album/Album/L10N Message-ID: <20051024192044.A65002AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/en_us.pm diff -u affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/en_us.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/en_us.pm:removed --- affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/en_us.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/en_us.pm Tue Oct 25 04:20:44 2005 @@ -1,44 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: en_us.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Album::L10N::en_us; -{ - use strict; - use lib("../../../../extlib"); - use lib("../../"); - use Album::L10N; - # - use vars qw(@ISA %Lexicon); - - sub encoding { "UTF-8" } - - @ISA = qw(Album::L10N); - - %Lexicon = ( - ########################################################## - #System - ########################################################## - '_SYS_ENCODING_DUMMY' =>'', - '_SYS_attr_opened' =>'Yes', - '_SYS_attr_closed' =>'', - - ########################################################## - '_AUTO' => 1, - ); -} -1; Index: affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/ja.pm diff -u affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/ja.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/ja.pm:removed --- affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/ja.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/Album/L10N/ja.pm Tue Oct 25 04:20:44 2005 @@ -1,107 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ja.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Album::L10N::ja; -{ - use strict; - use lib("../../../../extlib"); - use lib("../../"); - use Album::L10N; - use Album::L10N::en_us; - # - use vars qw(@ISA %Lexicon); - - sub encoding { "UTF-8" } - - @ISA = qw(Album::L10N::en_us); - - %Lexicon = ( - ########################################################## - #Example - ########################################################## - '_example_ENCODING_DUMMY' =>'????祉??祉?', - '_example_check_200_err1' => '[_1] ??endmail????冴???????!', - ########################################################## - #Add pairs... - ########################################################## - #茵?????????潟??ャ??障?鐚??篏??筝??????渇???? - 'Comment' => '?潟??潟?', - 'Add new album' => '?≪??????申?????, - 'Edit caption' => '茯?????膩??', - 'Edit album information' => '?≪?????????隈??, - 'Edit picture infomation' => '?糸??????隈??, - 'Delete comments and images' => '?糸?????<???????', - 'Delete pictures' => '?糸??????, - 'Delete Comments' => '?潟??潟??????, - 'Delete selected pictures' => '??????????????????, - 'Delete selected comments' => '?????????????<???????', - 'No image' => '?糸?????蚊????????????, - 'Delete the album' => '?≪?????????, - 'Do you really delete this album?' => '???????ゃ??障????', - 'Edit the caption' => '?潟??潟???隈??, - 'release' => '?画?', - 'update' => '?贋?', - 'Please write your comment' => '?潟??潟?????吾???????, - 'Confirm' => '腆肴??脂?', - 'Submit' => '?脂?', - 'Yes' => '???', - 'No' => '?????, - 'Add new picture' => '?糸????????????, - 'Write a caption' => '?帥????????<?????吾?', - 'Title' => '?帥????', - 'Caption' => '?潟??潟?', - 'Return' => '?祉?', - 'Return to index' => '筝?Η?????, - 'Add new album with following information.' => '篁ヤ????絎鴻??≪??????申????障?', - 'New album was created.' => '?≪??????申????障???, - 'Please add your pictures.' => '罨<??≪????????????蚊?????????, - 'Continue' => '罨<?', - 'Upload' => '?≪?????若?', - ' was uploaded' => '?????????????障???, - ' is already exist.' => '????с?絖??????????, - 'If you want overwrite it, you have to delete it before.' => '筝?????????????????絖???<???????????????墾?≪?????若???????????', - 'Cannot create thumbnail. please install ImageMagick module.' => '?泣???????篏?????????????mageMagick?≪??ャ????綽???с???, - 'Select a picture.' => '????ゃ????????????????', - 'Please use English one byte characters.' => '????ゃ????????掩??с?蕁????????', - 'Your name' => '??┸??, - 'Thank you for your comment.' => '?潟??潟??????昭?帥??????, - 'Submit following comment' => '篁ヤ????絎鴻??潟??潟???????', - 'Your comment was updated.' => '???????眼??障????', - 'Access Control Panel' => '?≪??祉??九勝????????, - 'Access denied' => '?????????????若????????鴻???┤???????障???, - 'Error' => '?????, - 'mode' => '?≪???, - 'Current Login' => '?上?????違???, - 'Current mode' => '?上?????若?', - 'Login ID' => '????ゃ?ID', - 'Password' => '????????, - 'Login' => '????ゃ?', - 'Logout' => '????≪???, - 'The image was deleted.' => '?糸?????ゃ??障????', - 'The comment was deleted.' => '?潟??潟?????ゃ??障????', - 'The album was deleted.' => '?≪????????ゃ??障????', - 'Information was updated.' => '???????違??障????', - 'Update' => '?贋?', - 'Entry' => '?脂?', - - ########################################################## - '_AUTO' => 1, - ); -} -1; - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 628] CVS update: affelio_farm/admin/skelton/affelio/apps/album/common Message-ID: <20051024192044.C5DE02AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/common/footer.pl diff -u affelio_farm/admin/skelton/affelio/apps/album/common/footer.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/common/footer.pl:removed --- affelio_farm/admin/skelton/affelio/apps/album/common/footer.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/common/footer.pl Tue Oct 25 04:20:44 2005 @@ -1,22 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -########################################################################## -#HTML Footer -#print "\n\n\n\n"; -print $afap->get_HTML_footer(); - -1; Index: affelio_farm/admin/skelton/affelio/apps/album/common/header.pl diff -u affelio_farm/admin/skelton/affelio/apps/album/common/header.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/common/header.pl:removed --- affelio_farm/admin/skelton/affelio/apps/album/common/header.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/common/header.pl Tue Oct 25 04:20:44 2005 @@ -1,71 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -use strict; -use lib("../../extlib"); -use HTML::Template; -use CGI; -use Cwd; -# -use lib("../../lib"); -use AffelioApp; -# -use Album; - -our $cgi = new CGI(); - -#Initialize AFAP -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -if(our $mymode eq "owner"){ - $afap->set_owner_mode(); -} - -# put Content-type -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; - -# put HTML Header -print $afap->get_HTML_header("Affelio Photo Album"); -# check access -unless ($afap->check_access("DF_access")) { - &errorExit(''); -} - -our $album = new Album($afap); - -#Show Error -sub errorExit { - my $msg = shift; - my $affelio_id = AffelioApp::get_visitor_info("afid"); - my $visitor_type=AffelioApp::get_visitor_info("type"); - -if($visitor_type eq ""){ - $visitor_type="pb"; -} - my $tmpl = HTML::Template->new(filename => "./templates/error.tmpl"); - $tmpl->param(V_TYPE => $visitor_type); - $tmpl->param(AF_ID => $affelio_id); - $tmpl->param(MSG => $msg); - - print $afap->{af}->translate_templateL10N( $tmpl->output ); - require ("./common/footer.pl"); - exit; -} - -########################################################################## -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:44 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:44 +0900 Subject: [Affelio-cvs 629] CVS update: affelio_farm/admin/skelton/affelio/apps/album/data Message-ID: <20051024192044.E4DFB2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/data/.htaccess diff -u affelio_farm/admin/skelton/affelio/apps/album/data/.htaccess:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/data/.htaccess:removed --- affelio_farm/admin/skelton/affelio/apps/album/data/.htaccess:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/data/.htaccess Tue Oct 25 04:20:44 2005 @@ -1,8 +0,0 @@ -AuthUserFile /dev/null -AuthGroupFile /dev/null -AuthType Basic - - -order deny,allow -deny from all - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:45 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:45 +0900 Subject: [Affelio-cvs 630] CVS update: affelio_farm/admin/skelton/affelio/apps/album/icons Message-ID: <20051024192045.0F8262AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/icons/normal.jpg Index: affelio_farm/admin/skelton/affelio/apps/album/icons/over.jpg From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:45 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:45 +0900 Subject: [Affelio-cvs 631] CVS update: affelio_farm/admin/skelton/affelio/apps/album/resource Message-ID: <20051024192045.329E52AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/resource/emp.jpg Index: affelio_farm/admin/skelton/affelio/apps/album/resource/photo_frame.gif Index: affelio_farm/admin/skelton/affelio/apps/album/resource/xml.gif From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:45 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:45 +0900 Subject: [Affelio-cvs 632] CVS update: affelio_farm/admin/skelton/affelio/apps/album/templates/owner Message-ID: <20051024192045.7EDCA2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/add_album.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/add_album.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/add_album.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/add_album.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/add_album.tmpl Tue Oct 25 04:20:45 2005 @@ -1,69 +0,0 @@ - - -
- - -
-
-
-
- - - - - -
-
- - :
" />
:
-
" /> - -
-
-
-
- - - -
- - -
-
-
-
-
- - - - - " /> - " /> - -


- "> - "> -
-
-
-
-
- - - -
- - -
-
-
-
- "> -
- - -


" />
-
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_album.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_album.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_album.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_album.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_album.tmpl Tue Oct 25 04:20:45 2005 @@ -1,52 +0,0 @@ - - -
- - -
- -
-
- -
-
- - - -
-
-
- " /> - - "> -
-
- "> -
-
-
-
-
- - - -
- - -
- -
-
-
-
-
- - -
-

- " /> -
-
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_comment.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_comment.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_comment.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_comment.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_comment.tmpl Tue Oct 25 04:20:45 2005 @@ -1,22 +0,0 @@ - -
- - -
- -
-
- -
-
- - -
-

- - " /> - " /> -
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_image.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_image.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_image.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_image.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/delete_image.tmpl Tue Oct 25 04:20:45 2005 @@ -1,21 +0,0 @@ - -
- - -
- -
-
- -
-
- - -
-

- - " /> " /> -
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/edit_album_caption.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/edit_album_caption.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/edit_album_caption.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/edit_album_caption.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/edit_album_caption.tmpl Tue Oct 25 04:20:45 2005 @@ -1,48 +0,0 @@ - - -
- - -
- -
-
-
-
-
- - - - - - -
:
" />
:
" />
-
- " /> - -
-
-
- - - -
- - -
- -
-
-
-
-
- - -
-

- " /> -
-
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/manage_album.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/manage_album.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/manage_album.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/manage_album.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/manage_album.tmpl Tue Oct 25 04:20:45 2005 @@ -1,68 +0,0 @@ - -
- -
-
-
-
- -
- - - - - - - - - -
- - &pkey=">&image=&type=thumbnail" border="0"> -
- "> - -   -
-
-
- " /> - "> -
- -

-
-
-
-
-
- - - -
- -
- - - - - - - -
-
- -
-
- "> - - -

- () -

- " /> - "> -
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/owner/owner.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/owner/owner.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/owner/owner.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/owner/owner.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/owner/owner.tmpl Tue Oct 25 04:20:45 2005 @@ -1,72 +0,0 @@ -
- - -
-
- - -
- - - - - - - - - - -
- - " target="_blank"> - - - -
- -
- -

" />

-
-
-
- ">&image=&type=thumbnail" border="0"> - -
-
-
- -
- -
- / 
- - - -
-
- " /> - - " /> -
-
-
- " /> - - " /> -
-
-
- "> - - " /> - -
-
-
-
-
-
-
-
- From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:45 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:45 +0900 Subject: [Affelio-cvs 633] CVS update: affelio_farm/admin/skelton/affelio/apps/album/templates Message-ID: <20051024192045.571EC2AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/album/templates/album.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/album.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/album.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/album.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/album.tmpl Tue Oct 25 04:20:45 2005 @@ -1,160 +0,0 @@ - -
- - -
- -
-
-
- -
- - -
- -
-
-
- - -
- - -
-
- -
-
-
- - -
- - -
- -
-
-
- - -
- - -
- -
-
-
- -
- - - -
- - - //:  (// ) -
-
- -
- - - -

- - -
- - - - - - - - - -
- - &pkey=">&image=&type=thumbnail" border="0"> - -   - -
- -

-
-
-
-
-
-
- - - -
- - -
-
-
- -
- - -
- :
-
- :
- -
-
-

- - "> - "> -
-
-
-
-
- - - - - -
-
-
- -
-
- - -

()


-
-
-
-
- - - -
- - -
-
-
- -
-
-
- - " /> - " /> -
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/edit_caption.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/edit_caption.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/edit_caption.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/edit_caption.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/edit_caption.tmpl Tue Oct 25 04:20:45 2005 @@ -1,49 +0,0 @@ - - -
- - -
-
- -
-
- - - - - - -
:
" />
:
- - " /> - " /> - " /> -
-
-
-
- - - -
- - -
- -
-
-
-
- - "> - "> - - -
-

- " /> -
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/error.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/error.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/error.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/error.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/error.tmpl Tue Oct 25 04:20:45 2005 @@ -1,26 +0,0 @@ -
- - -
- - - ( ) - - login/logout -
-
- :
- : -
-
- : - : - "> -    - -
-
- -
-

-
Index: affelio_farm/admin/skelton/affelio/apps/album/templates/image_view.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/image_view.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/image_view.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/image_view.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/image_view.tmpl Tue Oct 25 04:20:45 2005 @@ -1,65 +0,0 @@ -
- - - - -
posted by
-
- -
- - -
- - -
-
-
- - - -
- &image=&type=large"> -
- - &pkey="><< - -   - - - "> - - - &pkey=">>> - -   - -
-
-
- -
- -
- - -
-
-
- - -
- - "> - "> - "> -
-
- - -
-
-
-
-
- Index: affelio_farm/admin/skelton/affelio/apps/album/templates/index.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/index.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/index.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/index.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/index.tmpl Tue Oct 25 04:20:45 2005 @@ -1,75 +0,0 @@ -
- - -
-
- -
- -
- - -
- - -
- -
- - - - - - - - -
- - ">&image=&type=thumbnail" border="0"> - -   - -
-
-
-
-
-
- - - - - - - - -
- ">&image=&type=thumbnail" border="0"> - -
-
- -
-
- -
- -
- ">() -    - /  -
-
-
- - -
-

-

" />

-
-
- -
- Index: affelio_farm/admin/skelton/affelio/apps/album/templates/write_comment.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/album/templates/write_comment.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/album/templates/write_comment.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/album/templates/write_comment.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/album/templates/write_comment.tmpl Tue Oct 25 04:20:45 2005 @@ -1,51 +0,0 @@ - - -
- - -
- -
-
-
-
-
- - - - - - -
:
:
- - " /> - " /> - " />
-
-
-
-
- - - -
- - -
- -
-
-
-
-
- - -
-

- " /> - " /> -
-
-
-
-
From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:45 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:45 +0900 Subject: [Affelio-cvs 634] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/Diary Message-ID: <20051024192045.EF1202AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N.pm diff -u affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N.pm:removed --- affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N.pm Tue Oct 25 04:20:45 2005 @@ -1,29 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: L10N.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Diary::L10N; -{ - use strict; - use lib("../../../extlib"); - use Locale::Maketext; - - @Diary::L10N::ISA = qw(Locale::Maketext); - @Diary::L10N::Lexicon = (_AUTO => 1, - ); -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:45 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:45 +0900 Subject: [Affelio-cvs 635] CVS update: affelio_farm/admin/skelton/affelio/apps/diary Message-ID: <20051024192045.B77F12AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/AF_app.cfg diff -u affelio_farm/admin/skelton/affelio/apps/diary/AF_app.cfg:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/AF_app.cfg:removed --- affelio_farm/admin/skelton/affelio/apps/diary/AF_app.cfg:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/AF_app.cfg Tue Oct 25 04:20:45 2005 @@ -1,13 +0,0 @@ -[this_installation] -title=腱???ヨ? - -[application] -app_name=diary -app_version=1.1 -app_desc=Affelio?ヨ? -app_author=Affelio project -guest_index=list_diary.cgi -owner_index=owner.cgi -action_types=write_diary, write_comment -action_types_desc=?ヨ??吾?莨若?, ?潟??潟??吾?莨若? - Index: affelio_farm/admin/skelton/affelio/apps/diary/CHANGES diff -u affelio_farm/admin/skelton/affelio/apps/diary/CHANGES:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/CHANGES:removed --- affelio_farm/admin/skelton/affelio/apps/diary/CHANGES:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/CHANGES Tue Oct 25 04:20:45 2005 @@ -1,4 +0,0 @@ -1.0.0 (July 12, 2005) - Change: Diary.pm - Allow to use anchor tag in diary - Add explanation for allowed tag Index: affelio_farm/admin/skelton/affelio/apps/diary/Diary.pm diff -u affelio_farm/admin/skelton/affelio/apps/diary/Diary.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/Diary.pm:removed --- affelio_farm/admin/skelton/affelio/apps/diary/Diary.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/Diary.pm Tue Oct 25 04:20:45 2005 @@ -1,973 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -package Diary; - -use strict; - -use lib '../../extlib'; -use lib '../../lib'; - -use lib '.'; -use Diary::L10N; - -use DBI; -use Jcode; -use LWP::UserAgent; -use HTTP::Request::Common qw(POST); -use AffelioApp; -use HTML::Template; - -############################################## -# Constructor for diary -############################################## - -sub new { - my ($proto, $afap) = @_; - unless ($afap) { die("Diary::new: Error: missing username\n"); } - - my $self = {}; - $self->{afap} = $afap; - $self->{uname} = $afap->{af}->{site__username}; - $self->{datadir} = $afap->get_userdata_dir(); - $self->{dbh} = $afap->get_userdata_dbh; - $self->{entry_table} = "diary_$afap->{install_name}_entries"; - $self->{comment_table} = "diary_$afap->{install_name}_comments"; - $self->{tb_table} = "diary_$afap->{install_name}_tb"; - $self->{max_entries} = 365; - $self->{recent_entries_no} = 10; - $self->{header_title} = 'Affelio Diary'; - $self->{header_show} = 0; - - ########################### - #Locale init - ########################### - $self->{lh} = Diary::L10N->get_handle(($afap->get_site_info("locale"),$afap->get_site_info("locale"))); - ########################### - - my $DBConfig = Config::Tiny->new(); - $DBConfig = Config::Tiny->read("$self->{afap}->{af}->{site__user_dir}/db.cfg"); - $self->{dbtype} = $DBConfig->{db}->{type}; - - my @rets; - if ($self->{dbtype} eq 'mysql') { - @rets = getall($self, "SHOW TABLES like '$self->{entry_table}'"); - } - else { # SQLite - @rets = getall($self, "SELECT * FROM sqlite_master WHERE type = 'table' AND name = '$self->{entry_table}'"); - } - - # entries - my $pkey_modifier = $self->{dbtype} eq 'mysql' ? " AUTO_INCREMENT PRIMARY KEY " : " PRIMARY KEY "; - create_table($self, $self->{entry_table}, - "CREATE TABLE $self->{entry_table} ( - id INTEGER $pkey_modifier , - title TEXT, - contents TEXT, - year INTEGER, - month INTEGER, - day INTEGER, - timestamp INTEGER - )"); - - # comments - create_table($self, $self->{comment_table}, - "CREATE TABLE $self->{comment_table} ( - id INTEGER, - user TEXT, - comment TEXT, - timestamp INTEGER - )"); - - # trackbacks - create_table($self, $self->{tb_table}, - "CREATE TABLE $self->{tb_table} ( - id INTEGER, - title TEXT, - url TEXT, - excerpt TEXT, - blog_name TEXT, - timestamp INTEGER - )"); - - bless $self, $proto; - return $self; -} - - -############################################## -# Destructor -############################################## - -sub DESTROY { - my $self = shift; - $self->{dbh}->disconnect; -} - - -############################################## -# addEntry -############################################## - -sub addEntry { - my $self = shift; - my $title = $self->escape(shift); - my $contents = $self->escape(shift); - my $time = shift; - - unless ($time) { $time = time; } - - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($time); - $year += 1900; $mon += 1; - - # prevent double submit - my @same = $self->getall("SELECT id FROM $self->{entry_table} WHERE title = '$title' AND contents = '$contents'"); - if($#same >= 0) { return; } - - # log rotation - if($self->getColumn("SELECT count(*) FROM $self->{entry_table}") >= $self->{max_entries}) { - my $erase = $self->getColumn("SELECT MIN(timestamp) FROM $self->{entry_table}"); - my $erase_id = $self->getColumn("SELECT id FROM $self->{entry_table} WHERE timestamp = '$erase'"); - $self->removeEntry($erase_id); - } - - $self->{dbh}->do("INSERT INTO $self->{entry_table} VALUES (NULL, '$title', '$contents', $year, $mon, $mday, $time)"); - - # send trackback ping by using urls in entry - my $id = $self->getColumn("SELECT MAX(id) FROM $self->{entry_table}"); -# $self->send_trackback_ping($id, $title, $contents); -} - - -############################################## -# updateEntry -############################################## - -sub updateEntry { - my $self = shift; - my $id = $self->escape(shift, 'int'); - my $title = $self->escape(shift); - my $contents = $self->escape(shift); - $self->{dbh}->do("UPDATE $self->{entry_table} SET title = '$title', contents = '$contents' WHERE id = $id"); -} - - -############################################## -# removeEntry -############################################## - -sub removeEntry { - my $self = shift; - my $id = $self->escape(shift, 'int'); - $self->{dbh}->do("DELETE FROM $self->{entry_table} WHERE id = $id"); - $self->{dbh}->do("DELETE FROM $self->{comment_table} WHERE id = $id"); - $self->{dbh}->do("DELETE FROM $self->{tb_table} WHERE id = $id"); - if (-f $self->{datadir}."$id.stor") { - unlink $self->{datadir}."$id.stor"; - } - $self->removeUploadedImage($id); -} - - -############################################## -# getEntry -############################################## - -sub getEntry { - my $self = shift; - my $id = $self->escape(shift, 'int'); - my @ret = $self->getall("SELECT * FROM $self->{entry_table} WHERE id = $id"); - return $ret[0]; -} - -############################################## -# existsEntry -############################################## - -sub existsEntry { - my $self = shift; - my $id = $self->escape(shift, 'int'); - return $self->getColumn("SELECT COUNT(*) FROM $self->{entry_table} WHERE id = $id") > 0; -} - -############################################## -# getEntries -############################################# - -sub getEntries { - my $self = shift; - my $year = $self->escape(shift, 'int'); - my $month = $self->escape(shift, 'int'); - my $day = $self->escape(shift, 'int'); - - my $query = "SELECT * FROM $self->{entry_table} WHERE year = $year AND month = $month"; - - if ($day) { - $query .= " AND day = $day"; - } - - $query .= " ORDER BY timestamp DESC"; - - return $self->getall($query); -} - - -############################################## -# getNewestEntries -############################################## - -sub getNewestEntries { - my ($self, $num) = @_; - unless ($num) { $num = 5; } - return $self->getall("SELECT * FROM $self->{entry_table} ORDER BY timestamp DESC LIMIT $num"); -} - - -############################################## -# addComment -############################################## - -sub addComment { - my $self = shift; - my $id = $self->escape(shift, 'int'); - my $user = shift; - my $comment = $self->escape_comment(shift); - my $time = time; - - my @same = $self->getall("SELECT id FROM $self->{comment_table} WHERE user = '$user' AND comment = '$comment'"); - if($#same >= 0) { return; } - - $self->{dbh}->do("INSERT INTO $self->{comment_table} VALUES ($id, '$user', '$comment', $time)"); -} - - -############################################## -# getComments -############################################## - -sub getComments { - my $self = shift; - my $id = $self->escape(shift, 'int'); - return $self->getall("SELECT * FROM $self->{comment_table} WHERE id = $id ORDER BY timestamp"); -} - -############################################## -# getVisitorInfo -############################################## - -sub getVisitorInfo { - my $self = shift; - my $id = $self->escape(shift, 'int'); - - my $uname = $self->getColumn("SELECT user FROM $self->{comment_table} WHERE id = $id"); - if ($uname) { - if ($uname =~ /([^<]*)
(.*)/) { - return ($1, $2); - } - else { - return ($uname); - } - } - return (""); -} - -############################################## -# getCommentsNo -############################################## - -sub getCommentsNo { - my $self = shift; - my $id = $self->escape(shift, 'int'); - return $self->getColumn("SELECT count(*) FROM $self->{comment_table} WHERE id = $id"); -} - -sub getColumn { - my ($self, $query) = @_; - my $sth = $self->{dbh}->prepare($query); - $sth->execute; - my $num; - $sth->bind_columns(undef, \$num); - $sth->fetch; - $sth->finish; - if($num) { - return $num; - } - else { - return 0; - } -} - -############################################## -# get_HTML_header -############################################## - -sub get_HTML_header { - my $self = shift; - - return "" if ($self->{header_show} == 1) ; - - # conetnt type - my $header = - "Content-type: text/html; charset=UTF-8\n". - "Pragma: no-cache\n\n"; - - # affelio header - $header .= $self->{afap}->get_HTML_header($self->{header_title}); - - my $tmpl = HTML::Template->new(filename => "./templates/menu.tmpl"); - - # calender - my $calender; - if($self->{afap}->{cgi}->param('year') and $self->{afap}->{cgi}->param('month')) { - $calender = $self->getCalender($self->{afap}->{cgi}->param('year'), $self->{afap}->{cgi}->param('month')); - } - elsif($self->{afap}->{cgi}->param('id')) { - my $id = - my @date = $self->getall("SELECT year, month FROM $self->{entry_table} WHERE id = ".$self->{afap}->{cgi}->param('id')); - $calender = $self->getCalender($date[0]->{year}, $date[0]->{month}); - } - else { - $calender = $self->getCalender; - } - - # archives - my @archives = $self->getall("SELECT DISTINCT year, month FROM $self->{entry_table} LIMIT 10"); - if ($#archives >= 0) { - shift @archives unless $archives[0]->{year}; - $tmpl->param(ARCHIVES => \@archives); - } - - # recent entries - my @entries = $self->getall("SELECT id, title FROM $self->{entry_table} ORDER BY timestamp DESC LIMIT 10"); - if ($#entries >= 0) { - $tmpl->param(RECENT_ENTRIES => \@entries); - } - - # recent comments - my @comments = $self->getall("SELECT $self->{comment_table}.id, title, user FROM $self->{entry_table}, $self->{comment_table} WHERE $self->{entry_table}.id = $self->{comment_table}.id ORDER BY $self->{comment_table}.timestamp DESC LIMIT 10"); - if ($#comments >= 0) { - $tmpl->param(RECENT_COMMENTS => \@comments); - } - - # recent trackbacks - my @trackbacks = $self->getall("SELECT id, blog_name, title FROM $self->{tb_table} ORDER BY timestamp DESC LIMIT 10"); - if ($#trackbacks >= 0) { - $tmpl->param(RECENT_TRACKBACKS => \@trackbacks); - } - - $tmpl->param(CALENDER => $self->translate_templateL10N($calender), ); - - if ($self->{afap}->check_access('write_diary')) { - $tmpl->param(EDITABLE => 1); - unless (eval { require XML::Parser; }) { - $tmpl->param(NO_PARSER => 1); - } - } - $header .= $tmpl->output; - - $self->{header_show} = 1; - - return $header; -} - - -############################################## -# get_HTML_footer -############################################## - -sub get_HTML_footer { - my $self = shift; - my $tmpl = HTML::Template->new(filename => "./templates/footer.tmpl"); - return $tmpl->output().$self->{afap}->get_HTML_footer; -} - -############################################## -# redirection -############################################## - -sub getRedirection { - my ($self, $file) = @_; - my $webroot = $self->{afap}->get_site_info('web_root'); - return - "Content-type: text/html; charset=UTF-8\n". - "Location: $webroot/apps/$self->{afap}->{install_name}/$file"."\n\n"; -} - -############################################## -# checkAccess -############################################## - -sub checkAccess { - my ($self, $page_name) = @_; - unless ($self->{afap}->check_access($page_name)) { - $self->accessErrorExit("You have no permittion on this page"); - } -} - -############################################## -# errorExit -############################################## - -sub errorExit { - my $self = shift; - my $msg = $self->escape(shift); - - my $tmpl = new HTML::Template(filename => './templates/error.tmpl'); - $tmpl->param(MESSAGE => $msg); - - unless ($self->{header_show}) { - print "Content-type: text/html; charset=UTF-8\n\n"; - print $self->translate_templateL10N($self->{afap}->get_HTML_header($self->{header_title})); - } - print $self->translate_templateL10N($tmpl->output); - print $self->translate_templateL10N($self->{afap}->get_HTML_footer); - exit; -} - -############################################## -# accessErrorExit -############################################## - -sub accessErrorExit { - my $self = shift; - my $msg = $self->escape(shift); - my $affelio_id = $self->{afap}->get_visitor_info("afid"); - my $visitor_type=$self->{afap}->get_visitor_info("type"); - - $visitor_type="pb" if ($visitor_type eq ""); - - my $tmpl = new HTML::Template(filename => "./templates/access_error.tmpl"); - $tmpl->param( - AFID => $affelio_id, - VIS_TYPE=> $visitor_type, - MESSAGE => $msg, - ); - - unless ($self->{header_show}) { - print "Content-type: text/html; charset=UTF-8\n\n"; - print $self->translate_templateL10N($self->{afap}->get_HTML_header($self->{header_title})); - } - print $self->translate_templateL10N($tmpl->output); - print $self->translate_templateL10N($self->{afap}->get_HTML_footer); - exit; -} - -############################################## -# getCalender -############################################## - -sub getCalender { - my $self = shift; - my $year = $self->escape(shift, 'int'); - my $mon = $self->escape(shift, 'int'); - - unless ($mon) { my $d; ($d, $d, $d, $d, $mon, $year) = localtime(time); $year += 1900; $mon += 1; } - my @weeks = $self->weekly_days($year, $mon); - - my $tmpl = HTML::Template->new(filename => "./templates/calender.tmpl"); - - my $last_mon = $mon - 1; - my $next_mon = $mon + 1; - my $lastyear = $year; - my $nextyear = $year; - if ($mon == 1) { - $last_mon = 12; - $lastyear = $year - 1; - } - elsif ($mon == 12) { - $next_mon = 1; - $nextyear = $year + 1; - } - - $tmpl->param( - YEAR => $year, MONTH => $mon, - LAST_MON => $last_mon, NEXT_MON => $next_mon, - LASTYEAR => $lastyear, NEXTYEAR => $nextyear, - ); - - my @days = $self->getall("SELECT day FROM $self->{entry_table} WHERE year = $year AND month = $mon"); - my @daytable = (0 .. 31); - $daytable[0] = ''; - foreach(@days) { - $daytable[$_->{day}] = "{day}\">$_->{day}"; - } - - my @weeks_param; - foreach(@weeks) { - if($_->[0] == '' and $_->[6] == '') { next; } - push @weeks_param, - { - SUN => $daytable[$_->[0]], - MON => $daytable[$_->[1]], - TUE => $daytable[$_->[2]], - WED => $daytable[$_->[3]], - THU => $daytable[$_->[4]], - FRI => $daytable[$_->[5]], - SAT => $daytable[$_->[6]], - }; - } - - $tmpl->param(WEEKS => \@weeks_param); - - return $tmpl->output; -} - - -############################################## -# addTrackback -############################################## - -sub addTrackback { - my $self = shift; - my $id = $self->escape(shift, 'int'); - my $title = $self->escape(shift); - my $url = $self->escape(shift); - my $excerpt = $self->escape(shift); - my $blog_name = $self->escape(shift); - my $timestamp = $self->escape(shift, 'int'); - $self->{dbh}->do("INSERT INTO $self->{tb_table} VALUES($id, '$title', '$url', '$excerpt', '$blog_name', $timestamp)"); -} - -############################################## -# getTrackbacks -############################################## - -sub getTrackbacks { - my $self = shift; - my $id = $self->escape(shift, 'int'); - my @ret = $self->getall("SELECT * FROM $self->{tb_table} WHERE id = $id"); - - foreach (@ret) { - $_->{excerpt} = Jcode::convert($_->{excerpt}, 'utf8'); - } - reset (@ret); - - return @ret; -} - -############################################## -# getTrackbacksNo -############################################## - -sub getTrackbacksNo { - my $self = shift; - my $id = $self->escape(shift, 'int'); - return $self->getColumn("SELECT COUNT(*) FROM $self->{tb_table} WHERE id = $id"); -} - -############################################## -# sendTrackbackPing -############################################## - -sub sendTrackbackPing { - my ($self, $url, $title, $contents, $id) = @_; - - $id = $self->getColumn("SELECT MAX(id) FROM $self->{entry_table}") unless ($id); - - my %form = ( - title => $title, - excerpt => "",#Jcode::convert($contents, 'utf8', 'auto'), - url => $self->{afap}->get_site_info('web_root')."/apps/$self->{afap}->{install_name}/show_diary.cgi?id=$id", - blog_name => $self->{afap}->get_owner_info('nickname')."'s Affelio Diary", - ); - my $req = POST($url, [%form]); - my $ua = new LWP::UserAgent; - my $res = $ua->request($req); - my $str = $res->as_string; - if ($str =~ /[^1]*1[^<]*<\/error>/) { - $self->errorExit('Failed to send trackback ping'); - } -} - -############################################## -# setRDFURL -############################################## - -sub setRDFURL { - my ($self, $url) = @_; - local (*OUT); - - open(OUT, "> $self->{datadir}url"); - print OUT $url; - close(OUT); -} - -############################################## -# getRDFURL -############################################## - -sub getRDFURL { - my $self = shift; - if (-f "$self->{datadir}url") { - local (*IN); - open (IN, "$self->{datadir}url"); - my $rssfile = ; - $rssfile =~ s/[\r\n]//g; - close(IN); - return $rssfile; - } - return undef; -} - -############################################## -# unsetRDF -############################################## - -sub unsetRDFURL { - my $self = shift; - unlink("$self->{datadir}url") if (-f "$self->{datadir}url"); -} - -############################################## -# getRSS -############################################## - -sub getRSS { - my ($self, $count) = @_; - unless ($count) { $count = 5; } - - my $tmpl = new HTML::Template(filename => './templates/rss.tmpl'); - - my @entries = $self->getNewestEntries($count); - my @item_list; - my @items; - my $web_root = $self->{afap}->get_site_info('web_root'); - my $uname = $self->{afap}->get_owner_info('nickname'); - - foreach (@entries) { - my $link = "$web_root/apps/$self->{afap}->{install_name}/show_diary.cgi?id=$_->{id}"; - push @item_list, { LINK => $link, }; - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{timestamp}); - push @items, { - TITLE => $_->{title}, - LINK => $link, - DESCRIPTION => $_->{contents}, - DATE => sprintf("%4d-%02d-%02dT%02d:%02d+09:00", $year, $mon, $mday, $hour, $min), - CREATOR => $uname, - TPING => $web_root."apps/$self->{afap}->{install_name}/tb.cgi/$_->{id}", - }; - } - - $tmpl->param( - LINK => $web_root, - NICKNAME => $uname, - ITEM_LIST => \@item_list, - ITEMS => \@items, - ); - - return $tmpl->output; -} - -############################################## -# getURLDescription -############################################## - -sub getURLDescription { - my $self = shift; - my $id = $self->escape(shift, 'int'); - - my ($entry) = $self->getall("SELECT * FROM $self->{entry_table} WHERE id = $id"); - my $tmpl = new HTML::Template(filename => "./templates/tpingrdf.tmpl"); - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($entry->{timestamp}); - $year += 1900; $mon += 1; - - $tmpl->param( - TITLE => $entry->{title}, - TURL => "$self->{afap}->{af}->{site__web_root}/apps/$self->{afap}->{install_name}/tb/tb.cgi/$id", - IDENT => "$self->{afap}->{af}->{site__web_root}/apps/$self->{afap}->{install_name}/show_diary.cgi?id=$id", - DESCRIPTION => $entry->{contents}, - CREATOR => $self->{afap}->{af}->{user__nickname}, - DATE => sprintf("%4d-%02d-%02dT%02d:%02d+09:00", $year, $mon, $mday, $hour, $min), - ); - - return $tmpl->output; -} - -############################################## -# saveUploadedImage -############################################## - -sub saveUploadedImage { - use File::Basename; - my ($self, $filename, $id) = @_; - - if ($filename !~ /^[a-zA-Z0-9\.\-\_]{1,32}$/) { - $self->errorExit("You can only use ascii character in your file name"); - } - - $id = $self->getColumn("SELECT MAX(id) FROM $self->{entry_table}") unless ($id); - - my $afap = $self->{afap}; - - my $file; - my $buf; - my $filesize = 0; - while (my $bytesread = read($filename, $buf, 1024)) { - $file .= $buf; - $self->errorExit('Uploaded file was too big') if (++$filesize >= 300); - } - - my $imgdir = "$self->{datadir}img/"; - unless (-d $imgdir) { - mkdir $imgdir; - } - my $basedir = $imgdir."$id/"; - unless (-d $basedir) { - mkdir $basedir; - } - - fileparse_set_fstype('MSDOS'); - my $distfile = $basedir.basename($filename); - - unless (basename($filename) =~ /^[a-zA-Z0-9\.\-\_]{1,28}\.(jpg|jpeg|png|gif|bmp)$/i) { - $self->errorExit('Uploaded file had invalid MIME type'); - } - - local (*OUT); - open(OUT, "> $distfile") or $self->errorExit('Failed to open file'); - binmode OUT; - print OUT $file; - close(OUT); -} - -############################################## -# removeUploadedImage -############################################## - -sub removeUploadedImage { - my ($self, $id) = @_; - - $id = $self->getColumn("SELECT MAX(id) FROM $self->{entry_table}") unless ($id); - - my $imgdir = "$self->{datadir}img/$id/"; - if (-d $imgdir) { - local (*DIR); - opendir(DIR, $imgdir); - while (my $file = readdir(DIR)) { - unlink ($imgdir.$file) if (-f $imgdir.$file); - } - closedir(DIR); - rmdir $imgdir; - } -} - -############################################## -# getUploadedImages -############################################## - -sub getUploadedImages { - my ($self, $id, $width, $height) = @_; - - $width = "&w=$width" if ($width); - $height = "&h=$height" if ($height); - - my $imgdir = "$self->{datadir}img/$id/"; - my $ret; - - local (*DIR); - opendir(DIR, $imgdir); - while (my $file = readdir(DIR)) { - if (-f $imgdir.$file) { - $ret .= "". - "". - "
"; - } - } - closedir(DIR); - - return $ret ? "

$ret

" : ""; -} - -############################################## -# Internal functions -############################################## - -sub create_table { - my ($self, $table_name, $sql) = @_; - - my @rets; - if ($self->{dbtype} eq 'mysql') { - @rets = getall($self, "SHOW TABLES like '$table_name'"); - } - else { # SQLite - @rets = getall($self, "SELECT * FROM sqlite_master WHERE type = 'table' AND name = '$table_name'"); - } - - if ($#rets < 0) { - $self->{dbh}->do($sql); - } -} - -sub send_trackback_ping { - my ($self, $id, $title, $contents) = @_; - my @urls = $contents =~ /(s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/g; - - foreach(@urls) { - my $url = $self->discover_tb($_); - if($url) { - my %form = ( - title => $title, - excerpt => $contents, - url => "$self->{afap}->{af}->{site__web_root}/apps/$self->{afap}->{install_name}/show_diary.cgi?id=$id", - blog_name => "$self->{afap}->{af}->{user__nickname}'s affelio diary", - ); - my $req = POST($url, [%form]); - my $ua = new LWP::UserAgent; - my $res = $ua->request($req); - my $str = $res->as_string; - } - } -} - -sub escape { - my ($self, $str, $type) = @_; - - if ($type eq 'int') { - return int($str); - } - else { - $str =~ s/[\t\a]//g; - $str =~ s/&/&/g; - $str =~ s/["']/"/g; - $str =~ s//>/g; - $str =~ s/<(\/?)(a|p|i|b|big|strong|small|em|u|blockquote)>/<$1$2>/ig; - $str =~ s/<a +href=(")?(s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+) *(")? *>//ig; - $str =~ s/""/"/g; - $str =~ s/(\r\n|\r|\n)/
/g; - - while ($str =~ /(<(a|p|i|b|big|strong|small|em|u|blockquote)\b(?:(?!<\/\2>).)*(?:<\2>|$))/sigx) { - $self->errorExit("Error: You may mistype a tag or forget to close it."); - } - } - - return $str; -} - -sub escape_comment { - my ($self, $str) = @_; - - $str =~ s/[\t\a]//g; - $str =~ s/&/&/g; - $str =~ s/['"]/"/g; - $str =~ s//>/g; - $str =~ s/(\r\n|\r|\n)/
/g; - - return $str; -} - -sub getall { - my ($self, $query) = @_; - - my $sth = $self->{dbh}->prepare($query); - $sth->execute; - - my @ret; - while(my $row = $sth->fetchrow_hashref) { - push @ret, $row; - } - $sth->finish; - - return @ret; -} - -sub weekly_days { - my ($self, $year, $mon) = @_; - my @weeks; - my @mday = (31,31,28,31,30,31,30,31,31,30,31,30,31); - if (($year % 4 == 0) and ($year % 100) or ($year % 400 == 0)) { $mday[2] = 29 }; - - my $lastday = $mday[$mon]; - @mday = (1 .. $mday[$mon]); - if($mon < 3){ $mon += 12; $year--; } - my $first_day = ($year+int($year/4)-int($year/100)+int($year/400)+int((13*$mon+8)/5)+1)% 7; - - my $day = 1; - for my $week (0 .. 7) { - my @days; - for(my $i = 0; $i < 7; $i++) { - push @days, - (($week == 0 and $i < $first_day) or ($day > $lastday)) ? - '' : $day++; - } - $weeks[$week] = \@days; - } - - return @weeks; -} - -# Refer to: http://lowlife.jp/yasusii/stories/8.html -sub discover_tb { - my ($self, $url) = @_; - my $ua = LWP::UserAgent->new; - $ua->agent('TrackBack/1.0'); - $ua->parse_head(0); - $ua->timeout(15); - my $req = HTTP::Request->new(GET => $url); - my $res = $ua->request($req); - return unless $res->is_success; - my $c = $res->content; - (my $url_no_anchor = $url) =~ s/#.*$//; - my $item; - while ($c =~ m!()!sg) { - my $rdf = $1; - my($perm_url) = $rdf =~ m!dc:identifier="([^"]+)"!; - next unless $perm_url eq $url || $perm_url eq $url_no_anchor; - if ($rdf =~ m!trackback:ping="([^"]+)"!) { - return $1; - } elsif ($rdf =~ m!about="([^"]+)"!) { - return $1; - } - } -} - -############################################################################ -#L10N added by slash -############################################################################ -sub translate_templateL10N{ - my $af=shift; - my $mesg = shift; - - my $tag_body =""; - my $text_value=""; - my $param_value=""; - - while( $mesg =~ /]+)>/ ){ - $tag_body = $1; - - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["'](\s*)param(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - $param_value=$7; - if($text_value eq ""){ - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - } - - my $sbst = $af->{lh}->maketext($text_value, $param_value); - -# debug_print("Diary::translate tag_body = [$tag_body]\n"); -# debug_print("Diary::translate \t text=[$text_value]\n"); -# debug_print("Diary::translate \t param=[$param_value]\n"); -# debug_print("Diary::translate \t sbst=[$sbst]\n"); - - $mesg =~ s/\Q\E/$sbst/g; - } - return($mesg); -} -############################################################################ - - -1; Index: affelio_farm/admin/skelton/affelio/apps/diary/edit_diary.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/edit_diary.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/edit_diary.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/edit_diary.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/edit_diary.cgi Tue Oct 25 04:20:45 2005 @@ -1,97 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; -use Error qw(:try); - -$diary->checkAccess('write_diary'); - -my $id = $afap->{cgi}->param('id') or $diary->errorExit('An article number was not specified'); - -$diary->errorExit("The specified article does not exist") unless $diary->existsEntry($id); - -my $tmpl; - -# submitted -if($afap->{cgi}->param('edit')) { - try { - # send trackback ping - if ($afap->{cgi}->param('tping_url')) { - $diary->sendTrackbackPing($afap->{cgi}->param('tping_url'), $afap->{cgi}->param('title'), $afap->{cgi}->param('contents'), $id); - } - - $diary->updateEntry($id, $afap->{cgi}->param('title'), $afap->{cgi}->param('contents')); - - my $filename_1 = $afap->{cgi}->param('filename_1'); - my $filename_2 = $afap->{cgi}->param('filename_2'); - - if ($afap->{cgi}->param('delete_images') or $filename_1 or $filename_2) { - $diary->removeUploadedImage($id); - } - if ($filename_1) { - $diary->saveUploadedImage($filename_1, $id); - } - if ($filename_2) { - $diary->saveUploadedImage($filename_2, $id); - } - } - catch Error with { - my $e = shift; - error($q, "Error: \n".$e); - }; - - print $diary->getRedirection("show_diary.cgi?id=$id"); - exit; -} - -# deleted -elsif($afap->{cgi}->param('delete')) { - try { - $diary->removeEntry($id); - } - catch Error with { - my $e = shift; - error($q, "Error: \n".$e); - }; - - print $diary->getRedirection("list_diary.cgi"); - exit; -} - -# confirm -elsif($afap->{cgi}->param("delete_confirm")) { - $tmpl = HTML::Template->new(filename => "./templates/edit_diary_delete_confirm.tmpl"); - my $entry = $diary->getEntry($id); - $tmpl->param(ID => $entry->{id}); -} - -# edit -else { - $tmpl = HTML::Template->new(filename => "./templates/edit_diary_edit.tmpl"); - my $entry = $diary->getEntry($id); - $entry->{contents} =~ s/]*>/\n/g; - $tmpl->param( - ID => $entry->{id}, - TITLE => $entry->{title}, - CONTENTS => $entry->{contents}, - DATETIME => "$entry->{year}/$entry->{month}/$entry->{day}", - ); -} - -print $diary->translate_templateL10N($diary->get_HTML_header); -print $diary->translate_templateL10N($tmpl->output); -print $diary->get_HTML_footer; Index: affelio_farm/admin/skelton/affelio/apps/diary/external_blog.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/external_blog.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/external_blog.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/external_blog.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/external_blog.cgi Tue Oct 25 04:20:45 2005 @@ -1,136 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; - -use Error qw(:try); - -my $urlfile = $diary->{datadir}.'url'; - -my $writable = 0; -if($afap->check_access("write_diary")){ - $writable = 1; -} - -eval { require XML::Parser; } or $diary->errorExit("XML::Parser is not available"); - -# print header -my $header = - "Content-type: text/html; charset=UTF-8\n". - "Pragma: no-cache\n\n". - $afap->get_HTML_header($diary->{header_titile}); - -# set url -if ($afap->{cgi}->param('set_url')) { - $diary->setRDFURL($afap->{cgi}->param('url')); -} -# unset url -elsif ($afap->{cgi}->param('remove_urlfile')) { - $diary->unsetRDFURL; - print $diary->getRedirection('list_diary.cgi'); - exit; -} - -# load rss file and get url of rdf -my $rssfile = $diary->getRDFURL; - -# if file was not found, show configuration file -unless ($rssfile) { - $diary->checkAccess('write_diary'); - my $tmpl = new HTML::Template(filename => "./templates/external_blog_conf.tmpl"); - print $header; - print $diary->translate_templateL10N($tmpl->output); - print $diary->get_HTML_footer; - exit; -} - -# send request -my $req = new HTTP::Request(GET => $rssfile); -my $ua = new LWP::UserAgent; -my $res = $ua->request($req); -my $str; -if ($res->is_success) { - $str = $res->content; - $str =~ s/&/&/g; # escape '&' -} -else { - unlink($urlfile) if (-f $urlfile); - print $diary->errorExit("Failed to get RDF File"); -} - -# parse and output -use lib 'extlib'; -use XML::RSS; - -my $rss = new XML::RSS; -unless (eval { $rss->parse($str); }) { - $diary->unsetRDFURL; - $diary->errorExit("Failed to parse RDF File"); -} - -my @entries; -my @entry_list; -my $i = 0; -foreach (@{ $rss->{items} }) { - push @entries, { - TITLE => $_->{'title'}, - LINK => $_->{'link'}, - CONTENTS=> &escape_html($_->{'description'}), - DATE => $_->{dc}->{'date'}, - }; - push @entry_list, { - TITLE => $_->{'title'}, - LINK => $_->{'link'}, - }; - last if (++$i >= 10); -} - -my $tmpl = new HTML::Template(filename => "./templates/external_blog.tmpl"); -$tmpl->param( - WRITABLE => $writable, - RSS_URL => $rssfile, - TITLE_MAIN => $rss->channel('title'), - LINK_MAIN => $rss->channel('link'), - ENTRIES => \@entries, - ENTRY_LIST => \@entry_list, -); - -print $header; -print $diary->translate_templateL10N($tmpl->output); -print $diary->get_HTML_footer; - -sub escape_html { - my $html = shift; - - if ($html =~ /</) { - $html =~ s/<(.*)>//g; - $html =~ s/&/&/g; - $html =~ s/&(quot|apos);/"/g; - } - - $html =~ s/&/&/g; - $html =~ s/['"]/"/g; - $html =~ s/<[^>]*>//g; - $html =~ s//>/g; - - # allow
,

,,,,,,, -# $html =~ s/<(\/?)(br|p|a|i|b|strong|em|u|font)[^&]*>/<$1$2$3>/gi; -# $html =~ s/<a +href="([^&]*)"([^&]*)>//gi; - - return $html; -} Index: affelio_farm/admin/skelton/affelio/apps/diary/get_rss.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/get_rss.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/get_rss.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/get_rss.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/get_rss.cgi Tue Oct 25 04:20:45 2005 @@ -1,23 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; - -print "Content-type: application/xml; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; - -print $diary->getRSS; Index: affelio_farm/admin/skelton/affelio/apps/diary/init.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/init.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/init.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/init.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/init.pl Tue Oct 25 04:20:45 2005 @@ -1,46 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -use strict; - -use lib("../../extlib"); -use HTML::Template; -use CGI; -use Cwd; -# -use lib("../../lib"); -use AffelioApp; -use Affelio::misc::CGIError; -# -use Diary; - -our $cgi = new CGI(); - -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -if(our $mymode eq "owner"){ - $afap->set_owner_mode(); -} - -our $diary = new Diary($afap); - -unless ($afap->check_access("DF_access")) { - $diary->accessErrorExit('Access Denied. You don\'t have permission to this application.'); -} - -########################################################################## -1; Index: affelio_farm/admin/skelton/affelio/apps/diary/list_diary.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/list_diary.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/list_diary.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/list_diary.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/list_diary.cgi Tue Oct 25 04:20:45 2005 @@ -1,78 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require('init.pl'); - -if (-f "$diary->{datadir}url") { - print $diary->getRedirection('external_blog.cgi'); - exit; -} - -print $diary->translate_templateL10N($diary->get_HTML_header); - -my $user = $afap->{cgi}->param("user"); -my $edit = 0; - -if($afap->check_access("write_diary")) { - $user = $afap->get_owner_info("nickname"); - $edit = 1; -} - -my $tmpl = HTML::Template->new(filename => "./templates/list_diary.tmpl"); -#$tmpl->param(NICKNAME => $afap->get_owner_info("nickname")); - -my @entries_param; -my $year = $afap->{cgi}->param("year"); -my $month = $afap->{cgi}->param("month"); -my $day = $afap->{cgi}->param("day"); -my @entries; - -if($year and $month){ - @entries = $diary->getEntries($year, $month, $day); - if($day and $#entries == 0) { - my ($tid) = @entries; - print $diary->getURLDescription($tid->{id}); - } -} -else { - @entries = $diary->getNewestEntries; -} - -my $i = 0; -foreach(@entries) { - my ($sec, $min, $hour) = localtime($_->{timestamp}); - push @entries_param, - { - MONTH => $_->{month}, - DAY => $_->{day}, - #TIME => sprintf("%02d:%02d", $hour, $min), - TITLE => $_->{title}, - CONTENTS=> $_->{contents}, - COMMENT_NO => $diary->getCommentsNo($_->{id}), - TRACKBACKS => $diary->getTrackbacksNo($_->{id}), - ID => $_->{id}, - IMAGES => $diary->getUploadedImages($_->{id}, 300, 300), - EDITABLE=> $edit - }; -} -$tmpl->param(ENTRIES => \@entries_param, EDITABLE => $edit); - -$tmpl->param(install_title => $afap->get_app_info("install_title")); - -print $diary->translate_templateL10N($tmpl->output); - -print $diary->get_HTML_footer; Index: affelio_farm/admin/skelton/affelio/apps/diary/no_output.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/no_output.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/no_output.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/no_output.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/no_output.cgi Tue Oct 25 04:20:45 2005 @@ -1,26 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require './common/header.pl'; - -print "\n\n"; -while(my ($key, $value) = each %{$afap->{cgi}->{'.fieldnames'}}) { - print "\n"; -} -print "
Debug info
$key$value
\n"; - -require './common/footer.pl'; Index: affelio_farm/admin/skelton/affelio/apps/diary/owner.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/owner.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/owner.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/owner.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/owner.cgi Tue Oct 25 04:20:45 2005 @@ -1,56 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -our $mymode="owner"; - -require 'init.pl'; - -$diary->checkAccess("write_diary"); - -if ($afap->{cgi}->param('save_state')) { - my $type = $afap->{cgi}->param('type'); - if ($type eq 'import') { - if ($afap->{cgi}->param('url')) { - $diary->setRDFURL($afap->{cgi}->param('url')); - print $diary->getRedirection('external_blog.cgi'); exit; - } - } - else { # normal diary - $diary->unsetRDFURL; - print $diary->getRedirection('list_diary.cgi'); exit; - } -} - -my $tmpl = new HTML::Template(filename => './templates/owner.tmpl'); -my $url = $diary->getRDFURL; -if ($url) { - $tmpl->param( - URL => $url, - SELECT_IMPORT => 'checked' - ); -} -else { - $tmpl->param(SELECT_DIARY => 'checked'); -} - -eval { require XML::Parser; } or $tmpl->param(NO_PARSER => 1); - -$tmpl->param(access_control_URL => $afap->get_URL("access_control")); - -print $diary->get_HTML_header; -print $diary->translate_templateL10N($tmpl->output); -print $diary->get_HTML_footer; Index: affelio_farm/admin/skelton/affelio/apps/diary/show_diary.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/show_diary.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/show_diary.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/show_diary.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/show_diary.cgi Tue Oct 25 04:20:45 2005 @@ -1,67 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; -print $diary->get_HTML_header; - -my $id = $afap->{cgi}->param('id') or $diary->errorExit("An article number was not specified"); - -$diary->errorExit("The specified article does not exist") unless $diary->existsEntry($id); - -my $entry = $diary->getEntry($id); - -my $tmpl = HTML::Template->new(filename => "./templates/show_diary.tmpl"); - -# Diary -$tmpl->param( - ID => $entry->{id}, - MONTH => $entry->{month}, - DAY => $entry->{day}, - TITLE => $entry->{title}, - CONTENTS=> $entry->{contents}, - IMAGES => $diary->getUploadedImages($entry->{id}, 300, 300), -); - -# Comment -if($diary->getCommentsNo($id) > 0) { - $tmpl->param(HAS_COMMENTS => 1); - my @comments_param; - my @comments = $diary->getComments($id); - foreach(@comments) { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{timestamp}); - $mon += 1; - - push @comments_param, - { - UNAME => $_->{user}, - COMMENT_TIME => "$mon??mday??hour:$min", - COMMENT => $_->{comment} - }; - } - $tmpl->param(COMMENTS => \@comments_param); -} - -if($afap->check_access("write_comment")){ - $tmpl->param("comment_write" => "true"); -} - -# Notify Trackback Ping URL -print $diary->getURLDescription($id); - -print $diary->translate_templateL10N($tmpl->output); - -print $diary->get_HTML_footer; Index: affelio_farm/admin/skelton/affelio/apps/diary/show_image.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/show_image.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/show_image.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/show_image.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/show_image.cgi Tue Oct 25 04:20:45 2005 @@ -1,56 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; - -use Error qw(:try); - -my $id = $afap->{cgi}->param('id') or die; -my $filename = $afap->{cgi}->param('filename') or die; - -my $type = $filename; -$type =~ s/[^.]+\.(.*)/$1/i; -$type =~ s/jpg/jpeg/i; -my $filepath = "$diary->{datadir}img/$id/".$filename; - -my $width = $afap->{cgi}->param('w'); -my $height = $afap->{cgi}->param('h'); - -binmode STDOUT; -print "Content-type: image/$type\n\n"; -if ($width and $height and (eval 'use Image::Magick; 1;')) { - try { - my $image = new Image::Magick; - $image->Read(filename => $filepath); - my ($w, $h) = $image->Get('columns', 'rows'); - if ($w > $width or $h > $height) { - $image->Resize(geometry => $width.'x'.$height); - $image->Set(quality => 75); - } - $image->Write(file => \*STDOUT); - } - catch Error with { - my $e = shift; - error($q, "Error: \n". $e); - }; -} -else { - open(IMG, "$filepath") or die; - binmode IMG; - print while (); - close(IMG); -} Index: affelio_farm/admin/skelton/affelio/apps/diary/show_trackback.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/show_trackback.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/show_trackback.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/show_trackback.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/show_trackback.cgi Tue Oct 25 04:20:45 2005 @@ -1,42 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; - -my $id = $afap->{cgi}->param('id') or $diary->errorExit('An article number was not specified'); - -my $tmpl = HTML::Template->new(filename => "./templates/show_trackback.tmpl"); - -my @ts = $diary->getTrackbacks($id); -my @trackbacks; -foreach (@ts) { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime($_->{timestamp}); - $year += 1900; $mon += 1; - push @trackbacks, { - TITLE => $diary->escape($_->{title}), - BLOG_NAME => $diary->escape($_->{blog_name}), - URL => $_->{url}, - EXCERPT => $diary->escape($_->{excerpt}), - DATE => "$year-$mon-$mday", - }; -} -$tmpl->param(PING_URL => $afap->get_site_info("web_root") . "/apps/$diary->{afap}->{install_name}/tb.cgi/$id", TRACKBACKS => \@trackbacks); - -print $diary->get_HTML_header; -print $diary->getURLDescription($id); -print $diary->translate_templateL10N($tmpl->output); -print $diary->get_HTML_footer; Index: affelio_farm/admin/skelton/affelio/apps/diary/style.css diff -u affelio_farm/admin/skelton/affelio/apps/diary/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/style.css:removed --- affelio_farm/admin/skelton/affelio/apps/diary/style.css:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/style.css Tue Oct 25 04:20:45 2005 @@ -1,93 +0,0 @@ -div#diary_2ColLeft { - float: left; - width: 20%; - font-size: small; -/* border-right: 1px solid #D7D7D7; */ - padding: 1.0em 1.0em 1.0em 0.5em; - padding: 5px 5px 5px 5px; -} - -div#diary_2ColRight { - float: right; - width: 70%; - padding: 5px 10px 5px 10px; -} - -div#date { - font-size: 8pt; - text-align: right; -} - -div#diary_etc h2 { - font-weight: bold; -} - -div#diary_etc h3 { - color: #663333; - font-weight: bold; -} - -div#diary_etc table { - width: 450px; - table-layout: fixed; -} - -div#diary_etc th { - color: #6699FF; - border-top: 0px; - border-left: 0px; - border-right: 0px; - border-bottom: 1px dashed #989898; - text-align: left; -} - -table#calender { - border-spacing: 0px; - border-collapse: collapse; - empty-cells: show; - font-size: x-small; - text-align: center; - border-bottom: 1px solid #989898; - width: 120px; - height: 120px; -} - -table#calender th { - border-top: 0px; - border-left: 0px; - border-right: 0px; - border-bottom: 1px solid #989898; - font-size: 7pt; -} - -table#calender td { - font-size: 8pt; - border: 0px; -} - -table#diary { - border-spacing: 0px; - border-collapse: collapse; -} - -table#diary th { - color: #333333; - text-align: left; - font-size: 12pt; -} - -table#diary h3 { - color: #663333; - font-weight: bold; - font-size: large; -} - -table#diary td { - font-size: 12pt; - padding-bottom: 1.5em; -} - -table#diary p { - padding-left: 1.0em; -} - Index: affelio_farm/admin/skelton/affelio/apps/diary/tb.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/tb.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/tb.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/tb.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/tb.cgi Tue Oct 25 04:20:45 2005 @@ -1,498 +0,0 @@ -#!/usr/bin/perl -w -# Copyright 2002 Benjamin Trott. -# This code is released under the Artistic License. -use strict; - -#------------- -use lib("../../extlib"); -use HTML::Template; -use CGI qw( :standard ); -use Cwd; -use Jcode; -# -use lib("../../lib"); -use AffelioApp; -# -use Diary; - -my $cgi = new CGI(); - -my $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -my $diary = new Diary($afap); -my $datadir = $afap->get_userdata_dir; -#------------- - -my $DataDir = $datadir; -my $RSSDir = $DataDir; -my $GenerateRSS = 0; -my $Header = "./resource/header.txt"; -my $Footer = "./resource/footer.txt"; -my $Password = ""; - -use vars qw( $VERSION ); -$VERSION = '1.02'; - -#use CGI qw( :standard ); -use File::Spec::Functions; - -my $mode = param('__mode'); -unless ($mode) { - my $tb_id = munge_tb_id(get_tb_id()); - respond_exit("No TrackBack ID (tb_id)") unless $tb_id; - my $i = { map { $_ => scalar param($_) } qw(title excerpt url blog_name) }; - $i->{title} ||= $i->{url}; - $i->{timestamp} = time; -#------------- - $i->{title} = Jcode::convert($i->{title}, 'euc'); - $i->{excerpt} = Jcode::convert($i->{excerpt}, 'euc'); - $i->{blog_name} = Jcode::convert($i->{blog_name}, 'euc'); -#------------- - respond_exit("No URL (url)") unless $i->{url}; - my $data = load_data($tb_id); - unshift @$data, $i; - store_data($tb_id, $data); - if ($GenerateRSS && open(FH, ">" . catfile($RSSDir, $tb_id . '.xml'))) { - print FH generate_rss($tb_id, $data, 15); - close FH; - } -#------------- - $diary->addTrackback($tb_id, $i->{title}, $i->{url}, $i->{excerpt}, $i->{blog_name}, $i->{timestamp}); -#------------- - respond_exit(); -} elsif ($mode eq 'list') { - my $tb_id = munge_tb_id(get_tb_id()); - die("No TrackBack ID (tb_id)") unless $tb_id; - my $me = url(); - print header(), from_file($Header), <TrackBack URL for this entry: -

- -URL - my $data = load_data($tb_id); - my $tmpl = <%s
-
» %s
-
"%s"
- -TMPL - my $i = 0; - require POSIX; - my $logged_in = is_logged_in(); - for my $item (@$data) { - my $ts = POSIX::strftime("%B %d, %Y %I:%M %p", - localtime $item->{timestamp}); - printf $tmpl, - $item->{url}, $item->{title}, - $item->{blog_name} || "[No blog name]", - $item->{excerpt} || "[No excerpt]", - $ts, - $logged_in ? qq([DELETE]) : ''; - $i++; - } - unless ($logged_in) { - print <[Is this your site? Log in to delete pings.] -HTML - } else { - print <[Log out] -HTML - } - print from_file($Footer); -} elsif ($mode eq 'delete') { - die "You are not authorized" unless is_logged_in(); - my $tb_id = munge_tb_id(get_tb_id()); - die("No TrackBack ID (tb_id)") unless $tb_id; - my $data = load_data($tb_id); - my $index = param('index') || 0; - splice @$data, $index, 1; - store_data($tb_id, $data); - print redirect(url() . "?__mode=list&tb_id=$tb_id"); -} elsif ($mode eq 'rss') { - my $tb_id = munge_tb_id(get_tb_id()); - respond_exit("No TrackBack ID (tb_id)") unless $tb_id; - my $data = load_data($tb_id); - respond_exit(undef, generate_rss($tb_id, $data)); -} elsif ($mode eq 'send_ping') { - require LWP::UserAgent; - my $ua = LWP::UserAgent->new; - $ua->agent("TrackBack/$VERSION"); - my @qs = map $_ . '=' . encode_url(param($_) || ''), - qw( title url excerpt blog_name ); - my $ping = param('ping_url') or ping_form_exit("No ping URL"); - my $req; - if ($ping =~ /\?/) { - $req = HTTP::Request->new(GET => $ping . '&' . join('&', @qs)); - } else { - $req = HTTP::Request->new(POST => $ping); - $req->content_type('application/x-www-form-urlencoded'); - $req->content(join('&', @qs)); - } - my $res = $ua->request($req); - ping_form_exit("HTTP error: " . $res->status_line) unless $res->is_success; - my($e, $msg) = $res->content =~ m!(\d+).*(.+?)!s; - $e ? ping_form_exit("Error: $msg") : ping_form_exit("Ping successfuly sent"); -} elsif ($mode eq 'send_form') { - ping_form_exit(); -} elsif ($mode eq 'login') { - print header(), login_form(); -} elsif ($mode eq 'do_login') { - my $key = param('key'); - unless ($key eq $Password) { - print header(), login_form("Invalid login"); - exit; - } - require CGI::Cookie; - my @alpha = ('a'..'z', 'A'..'Z', 0..9); - my $salt = join '', map $alpha[rand @alpha], 1..2; - my $cookie = CGI::Cookie->new(-name => 'key', - -value => crypt($key, $salt)); - print header(-cookie => $cookie), from_file($Header), - "Logged in", from_file($Footer); -} elsif ($mode eq 'logout') { - require CGI::Cookie; - my $cookie = CGI::Cookie->new(-name => 'key', -value => '', - -expire => '-1y'); - print header(-cookie => $cookie), login_form("Logged out"); -} - -sub get_tb_id { - my $tb_id = param('tb_id'); - unless ($tb_id) { - if (my $pi = path_info()) { - ($tb_id = $pi) =~ s!^/!!; - } - } - $tb_id; -} - -sub munge_tb_id { - my($id) = @_; - return '' unless $id; - $id =~ tr/a-zA-Z0-9/_/cs; - $id; -} - -sub is_logged_in { - require CGI::Cookie; - my %cookies = CGI::Cookie->fetch; - return unless $cookies{key}; - my $key = $cookies{key}->value || return; - $key eq crypt $Password, substr $key, 0, 2; -} - -sub load_data { - my($tb_id) = @_; - my $tb_file = catfile($DataDir, $tb_id . '.stor'); - require Storable; - scalar eval { Storable::retrieve($tb_file) } || []; -} - -sub store_data { - my($tb_id, $data) = @_; - my $tb_file = catfile($DataDir, $tb_id . '.stor'); - require Storable; - Storable::store($data, $tb_file); -} - -sub generate_rss { - my($tb_id, $data, $limit) = @_; - my $rss = qq(TB: $tb_id\n); - my $max = $limit ? $limit - 1 : $#$data; - for my $i (@{$data}[0..$max]) { - $rss .= sprintf "%s%s%s\n", xml('title', $i->{title}), - xml('link', $i->{url}), xml('description', $i->{excerpt}) if $i; - } - $rss . qq(); -} - -sub respond_exit { - print "Content-Type: text/xml\n\n"; - print qq(\n\n); - if ($_[0]) { - printf qq(1\n%s\n), xml('message', $_[0]); - } else { - print qq(0\n) . ($_[1] ? $_[1] : ''); - } - print "\n"; - exit; -} - -sub ping_form_exit { - print header(), from_file($Header); - print "@_" if @_; - print <Send a TrackBack ping -
- - - - - - - -
TrackBack Ping URL:
 
Title:
Blog name:
Excerpt:
Permalink URL:
- -
-HTML - print from_file($Footer); - exit; -} - -sub login_form { - my $str = from_file($Header); - $str .= "

@_

" if @_; - $str .= < - -Password: - - -HTML - $str; -} -my(%Map, $RE); -BEGIN { - %Map = ('&' => '&', '"' => '"', '<' => '<', '>' => '>'); - $RE = join '|', keys %Map; -} -sub xml { - (my $s = defined $_[1] ? $_[1] : '') =~ s!($RE)!$Map{$1}!g; - "<$_[0]>$s\n"; -} - -sub encode_url { - (my $str = $_[0]) =~ s!([^a-zA-Z0-9_.-])!uc sprintf "%%%02x", ord($1)!eg; - $str; -} - -sub from_file { - my($file) = @_; - local *FH; - open FH, $file; - my $c; - { local $/; $c = } - close FH; - $c; -} - -__END__ - -=head1 NAME - -tb-standalone - Standalone TrackBack - -=head1 DESCRIPTION - -The standalone TrackBack tool serves two purposes: 1) it allows non-Movable -Type users to use TrackBack with the tool of their choice, provided they meet -the installation requirements; 2) it serves as a reference point to aid -developers in implementing TrackBack in their own systems. This tool is a -single CGI script that accepts TrackBack pings through HTTP requests, stores -the pings locally in the filesystem, and can return a list of pings either -in RSS or in a browser-viewable format. It can also be used to send pings -to other sites. - -It is released under the Artistic License. The terms of the Artistic License -are described at I. - -=head1 REQUIREMENTS - -You'll need a webserver capable of running CGI scripts (this means, for -example, that this won't work with BlogSpot-hosted blogs). You'll also need -perl, and the following Perl modules: - -=over 4 - -=item * File::Spec - -=item * Storable - -=item * CGI - -=item * CGI::Cookie - -=item * LWP - -=back - -The first four are core modules as of perl 5.6.0, I believe, and LWP is -installed on most hosts. Furthermore LWP is only required if you wish to -B TrackBack pings. - -=head1 INSTALLATION - -Installation of the standalone TrackBack tool is very simple. It's just one -CGI script, F, along with two text files that define the header and -footer HTML for the public list of TrackBack pings. - -=over 4 - -=item 1. Configure tb.cgi - -You'll need to edit the script to change the I<$DataDir>, I<$RSSDir>, -and I<$Password> settings. - -B BEFORE INSTALLING THE TOOL.> - -I<$DataDir> is the path to the directory where the TrackBack data -files will be stored; I<$RSSDir> is the path to the directory where the static -RSS files will be generated; I<$Password> is your secret password that will -allow you to delete TrackBack pings, when logged in. - -After setting I<$DataDir> and I<$RSSDir>, you'll need to create both of these -directories and make them writeable by the user running the CGI scripts. In -most cases, this means that you must set the permissions on these directories -to 777. - -=item 2. Upload Files - -After editing the settings, upload F, F, and F -in ASCII mode to your webserver into a directory where you can run CGI -scripts. Set the permissions on F to 755. - -=back - -=head1 USAGE - -=head2 Sending Pings - -To send pings from the tool, go to the following URL: - - http://yourserver.com/cgi-bin/tb.cgi?__mode=send_form - -where I is the URL where you -installed F. Fill out the fields in the form, then press I. - -=head2 Receiving Pings - -To use the tool in your existing pages, you'll need to do two things: - -=over 4 - -=item 1. Link to TrackBack listing - -First, you'll need to add a link to each of your weblog entries with a -link to the list of TrackBack pings for that entry. You can do this by -adding the following HTML to your template: - - TrackBack - -You'll need to change C to the proper -URL for I on your server. And, depending on the weblogging tool that -you use, you'll need to change C<[TrackBack ID]> to a unique post ID. See -the L to determine the proper tag to -use for the tool that you use, to generate a unique post ID. - -=item 2. Add RDF - -TrackBack uses RDF embedded within your web page to auto-discover -TrackBack-enabled entries on your pages. It also uses this information when -building a threaded list of a cross-weblog "discussion". For these purposes, -it is useful to embed the RDF into your page. - -Add the following to your weblog template so that it is displayed for each -of the entries on your page: - - - -As above, the tags that you should use for C<[TrackBack ID]>, -C<[Entry Title]>, and C<[Entry Permalink]> all depend on the weblogging tool -that you are using. See the L. - -=back - -=head2 Conversion Table - -=over 4 - -=item * Blogger - -TrackBack ID = C$BlogItemNumber$E> - -Entry Title = CPostSubjectEE$BlogItemSubject$EE/PostSubjectE> - -Entry Permalink = C$BlogItemArchiveFileName$E#E$BlogItemNumber$E> - -=item * GreyMatter - -TrackBack ID = C<{{entrynumber}}> - -Entry Title = C<{{entrysubject}}> - -Entry Permalink = C<{{pagelink}}> - -=item * b2 - -TrackBack ID = C?php the_ID() ?E> - -Entry Title = C?php the_title() ?E> - -Entry Permalink = C?php permalink_link() ?E> - -=item * pMachine - -TrackBack ID = C<%%id%%> - -Entry Title = C<%%title%%> - -Entry Permalink = C<%%comment_permalink%%> - -=item * Bloxsom - -TrackBack ID = C<$fn> - -Entry Title = C<$title> - -Entry Permalink = C<$url/$yr/$mo/$da#$fn> - -Thanks to Rael for this list of conversions. - -=back - -=head1 POSSIBLE USES - -=over 4 - -=item 1. Content repository - -Like Movable Type's TrackBack implementation, this standalone script can -be used to power a distributed content repository. The value of the I -parameter does not necessarily have to be an integer, because all it is used -for is a filename (B that this is not true of most other TrackBack -implementations). For example, if you run a site about cats, and want to have -a way for users to ping your site with entries they write about their own -cats, you could set up a TrackBack URL like -F, then give that URL out on your -site. End users could then associate this URL with a I category in -their own blog, and ping you whenever they wrote about cats. - -=item 2. Building block - -You can use this simple implementation as a building block, or a guide, for -implementing TrackBack in your own system. It illustrates the core -functionality of the TrackBack framework, onto which you could add bells -and whistles (IP banning, password-protected TrackBacks, etc). - -=item 3. Centralized tool - -This TrackBack tool requires that the end user have the ability to run CGI -scripts on their server. For many users (eg BlogSpot users), this is not -an option. For such users, a centralized system (based on this tool, perhaps) -would be ideal. - -=back - -=cut Index: affelio_farm/admin/skelton/affelio/apps/diary/write_comment.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/write_comment.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/write_comment.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/write_comment.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/write_comment.cgi Tue Oct 25 04:20:45 2005 @@ -1,68 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -require 'init.pl'; - -use Error qw(:try); - -$diary->checkAccess('write_comment'); - -my $id = $afap->{cgi}->param('id') or $diary->errorExit('An article number was not specified'); - -$diary->errorExit("The specified article does not exist") unless $diary->existsEntry($id); - -my $user = $afap->get_visitor_info("nickname"); - -# Confirm -if($afap->{cgi}->param('comment_confirm')) { - my $tmpl = HTML::Template->new(filename => "./templates/write_comment_confirm.tmpl"); - $tmpl->param(COMMENT_SHOW => $diary->escape_comment($afap->{cgi}->param('comment')), COMMENT => $afap->{cgi}->param('comment'), ID => $id); - $tmpl->param(REQUIRE_NAME => 1) unless ($user); - print $diary->get_HTML_header; - print $diary->translate_templateL10N($diary->translate_templateL10N($tmpl->output)); - print $diary->get_HTML_footer; -} - -# Commit -elsif($afap->{cgi}->param('comment_commit')) { - - if(!$user){ - $user = $diary->escape_comment($afap->{cgi}->param('visitor_name')); - }else{ - $url = $afap->get_visitor_info('afid'); - if ($url =~ /get_site_info('web_root').'/outgoing.cgi?dest_url='.$url; - $user = "".$afap->get_visitor_info("nickname").""; - } - - try { - $diary->addComment($id, $user, $afap->{cgi}->param('comment')); - } - catch Error with { - my $e = shift; - error($q, "Error: \n".$e); - }; - - print $diary->getRedirection("show_diary.cgi?id=$id"); - exit; -} - -else { - $diary->errorExit('Invalid Access'); -} Index: affelio_farm/admin/skelton/affelio/apps/diary/write_diary.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/write_diary.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/write_diary.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/write_diary.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/write_diary.cgi Tue Oct 25 04:20:45 2005 @@ -1,82 +0,0 @@ -#!/usr/bin/perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -our $mymode="owner"; - -require 'init.pl'; - -# Error handling causes "Internal Server Error" ... -# use Error qw(:try); - -$diary->checkAccess('write_diary'); - -my $title = $afap->{cgi}->param('title'); -my $contents = $afap->{cgi}->param('contents'); - -my $tmpl; -if($afap->{cgi}->param('submit')) { -# try { - # add entry - $diary->addEntry($title, $contents); - - # send trackback ping - if ($afap->{cgi}->param('tping_url')) { - $diary->sendTrackbackPing($afap->{cgi}->param('tping_url'), $title, $contents); - } - - # update images - $diary->removeUploadedImage; - if ($afap->{cgi}->param('filename_1')) { - $diary->saveUploadedImage($afap->{cgi}->param('filename_1')); - } - if ($afap->{cgi}->param('filename_2')) { - $diary->saveUploadedImage($afap->{cgi}->param('filename_2')); - } - -# } -# catch Error with { -# my $e = shift; -# error($q, "Error: \n".$e); -# }; - - print $diary->getRedirection('list_diary.cgi'); - exit; -} -else { - print $diary->get_HTML_header; - if($afap->{cgi}->param('confirm')) { - $tmpl = new HTML::Template(filename => "./templates/write_diary_confirm.tmpl"); - $tmpl->param( - TITLE_SHOW => $diary->escape($title), - CONTENTS_SHOW => $diary->escape($contents), - ); - } - else { # edit - $tmpl = new HTML::Template(filename => "./templates/write_diary_edit.tmpl"); - } -} - -if ($contents) { - $tmpl->param( - TITLE => $title, - CONTENTS => $contents, - ); -} - -print $diary->translate_templateL10N($tmpl->output); - -print $diary->get_HTML_footer; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:46 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:46 +0900 Subject: [Affelio-cvs 636] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N Message-ID: <20051024192046.1A8662AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/en_us.pm diff -u affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/en_us.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/en_us.pm:removed --- affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/en_us.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/en_us.pm Tue Oct 25 04:20:46 2005 @@ -1,44 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: en_us.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Diary::L10N::en_us; -{ - use strict; - use lib("../../../../extlib"); - use lib("../../"); - use Diary::L10N; - # - use vars qw(@ISA %Lexicon); - - sub encoding { "UTF-8" } - - @ISA = qw(Diary::L10N); - - %Lexicon = ( - ########################################################## - #System - ########################################################## - '_SYS_ENCODING_DUMMY' =>'', - '_SYS_attr_opened' =>'Yes', - '_SYS_attr_closed' =>'', - - ########################################################## - '_AUTO' => 1, - ); -} -1; Index: affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/ja.pm diff -u affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/ja.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/ja.pm:removed --- affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/ja.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/Diary/L10N/ja.pm Tue Oct 25 04:20:46 2005 @@ -1,100 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ja.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Diary::L10N::ja; -{ - use strict; - use lib("../../../../extlib"); - use lib("../../"); - use Diary::L10N; - use Diary::L10N::en_us; - # - use vars qw(@ISA %Lexicon); - - sub encoding { "UTF-8" } - - @ISA = qw(Diary::L10N::en_us); - - %Lexicon = ( - ########################################################## - #Example - ########################################################## - '_example_ENCODING_DUMMY' =>'????祉??祉?', - '_example_check_200_err1' => '[_1] ??endmail????冴???????!', - ########################################################## - #Add pairs... - ########################################################## - #茵?????????潟??ャ??障?鐚??篏??筝??????渇???? - - 'Comments' => '?潟??潟?', - 'Trackbacks' => '???????????, - 'Edit' => '膩??', - 'Add Diary Entry' => '?ヨ?????? - 'Confirm' => '腆肴?', - 'Image' => '?糸?', - 'Upload limit is less than 300KB' => '?≪?????若??с?????????ゃ????鐚??鐚?滋?障??с?', - 'Send Trackback Ping' => 'Trackback Ping???篆?, - 'Add' => '菴遵?', - 'Modify' => '篆??', - 'Submit' => '??拭', - 'Edit Diary Entry' => '?ヨ???隈??, - 'Remove Image' => '?≪?????若?????糸??????, - 'Update' => '篆??', - 'Delete Diary Entry' => '?ヨ??????, - 'Delete' => '???', - 'Do you really want to delete this entry?' => '???????ゃ??障????', - 'yes' => '???', - 'no' => '?????, - 'Your Comment' => '篁ヤ????絎鴻??潟??潟??????, - 'Comment' => '?潟??潟?', - 'Trackback Ping-Url for this entry' => '???荐???吾?Trackback Ping-URL', - 'Diary Configuration' => '?ヨ??????就???荐??', - 'Use this diary' => '??幻???荐????????', - 'Import external blog' => '紊????鴫鐚わ痔????潟??若????', - 'Apply' => '荐??', - 'Error' => '?????, - 'An article number was not specified' => '荐????垩???????????障???, - 'The specified article does not exist' => '?????????篋??絖????????', - 'You have no permittion on this page' => '?????????????吾??≪??祉????罔???????????', - 'Current Login ID' => '?上?????違??鰹而鐚?, - 'Current Mode' => '?上?????若?', - 'Login ID' => '????ゃ?鐚?爾', - 'Password' => '????????, - 'Login' => '????ゃ?', - 'Logout' => '????≪???, - 'Allowed HTML tags:' => '篏睡??с???TML?帥?', - 'Only href attribute is allowed in anchor tag' => '?≪?????帥???賢?с?href絮?????荐?唇?с??障?', - 'To use this feature, you need XML::Parser module on youre system' => '???罘?????????????ML::Parser?≪??ャ????綽???с?', - 'Access Control' => '?≪??祉??九勝', - 'Access Control Page' => '?≪??祉??九勝????若???, - 'Failed to parse RDF File' => 'RDF????ゃ???В???紊掩??????????罩c?????ゃ??????с?????障?', - 'Su' => '??, - 'Mo' => '??, - 'Tu' => '??, - 'We' => '羂?, - 'Th' => '??, - 'Fr' => '??, - 'Sa' => '??, - - - ########################################################## - '_AUTO' => 1, - ); -} -1; - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:46 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:46 +0900 Subject: [Affelio-cvs 637] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/common Message-ID: <20051024192046.419302AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/common/checkwrite.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/common/checkwrite.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/common/checkwrite.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/common/checkwrite.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/common/checkwrite.pl Tue Oct 25 04:20:46 2005 @@ -1,33 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# ?吾?莨若??≪??祉?罔??????с???- -unless ($afap->check_access("write_diary")) { - -print< -
-

?????/h3> -

?????????????若??????昭?炊┤???????障???/p> -

- -ACCESS_ERR - -require ("./common/footer.pl"); -exit; -} - Index: affelio_farm/admin/skelton/affelio/apps/diary/common/diary.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/common/diary.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/common/diary.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/common/diary.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/common/diary.pl Tue Oct 25 04:20:46 2005 @@ -1,47 +0,0 @@ -#!/usr/bin/env perl -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -use strict; - -use Diary; - -my $diary = new Diary("ensf"); - -if($ARGV[0] eq '-r') { - my @res = $diary->getEntries($ARGV[1], $ARGV[2], $ARGV[3]); - foreach(@res) { - print "title: ".$_->{title}."\n\n".$_->{contents}."\n"; - } -} -elsif($ARGV[0] eq '-w') { - $diary->addEntry($ARGV[1], $ARGV[2]); - print "title: ".$ARGV[1]."\n\n".$ARGV[2]."\n"; -} -elsif($ARGV[0] eq '-cw') { - $diary->addComment($ARGV[1], $ARGV[2], $ARGV[3]); - print "id => $ARGV[1]\nuser: $ARGV[2]\n$ARGV[3]\n"; -} -elsif($ARGV[0] eq '-cr') { - my @res = $diary->getComments($ARGV[1]); - foreach(@res) { - print "user: $_->{user}\n$_->{comment}\n"; - } -} -else { - die("invalid arguments\n"); -} - Index: affelio_farm/admin/skelton/affelio/apps/diary/common/footer.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/common/footer.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/common/footer.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/common/footer.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/common/footer.pl Tue Oct 25 04:20:46 2005 @@ -1,22 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -########################################################################## - -#HTML Footer Part?????-print "\n\n\n\n"; -print $afap->get_HTML_footer(); - -1; Index: affelio_farm/admin/skelton/affelio/apps/diary/common/header.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/common/header.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/common/header.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/common/header.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/common/header.pl Tue Oct 25 04:20:46 2005 @@ -1,118 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -use strict; - -use lib("../../extlib"); -use HTML::Template; -use CGI; -use Cwd; -# -use lib("../../lib"); -use AffelioApp; -# -use Diary; - - -our $cgi = new CGI(); - -#AffelioApp?????? -our $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -if(our $mymode eq "owner"){ - $afap->set_owner_mode(); -} - -#Content-type?????-print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; - -#HTML Header Part?????-print $afap->get_HTML_header("Affelio Diary"); -# 茯??莨若??≪??祉?罔??????с???-unless ($afap->check_access("DF_access")) { - print "
"; - &errorExit("?????????????若?????粋昭?炊┤???????障???); -} - -my $tmpl = HTML::Template->new(filename => "./templates/menu.tmpl"); - -# ????潟??若?茵?ず -our $diary = new Diary($afap); - -my $calender = ""; -if($afap->{cgi}->param('year') and $afap->{cgi}->param('month')) { - $calender = $diary->getCalender($afap->{cgi}->param('year'), $afap->{cgi}->param('month')); -} -elsif($afap->{cgi}->param('id')) { - my $id = - my @date = $diary->getall("SELECT year, month FROM $diary->{entry_table} WHERE id = ".$afap->{cgi}->param('id')); - $calender = $diary->getCalender($date[0]->{year}, $date[0]->{month}); -} -else { - $calender = $diary->getCalender; -} - -# ?≪?????????? -my @archives = $diary->getall("SELECT DISTINCT year, month FROM $diary->{entry_table} LIMIT 10"); -if($#archives >= 0) { - shift @archives unless $archives[0]->{year}; - $tmpl->param(HAS_ARCHIVE => "1", ARCHIVES => \@archives); -} - -# ???????潟???????? -my @entries = $diary->getall("SELECT id, title FROM $diary->{entry_table} ORDER BY timestamp DESC LIMIT 5"); -if($#entries >= 0) { - $tmpl->param(HAS_ENTRY => "1", RECENT_ENTRIES => \@entries); -} - -$tmpl->param(CALENDER => $calender, RSS => $afap->get_site_info("web_root") . "/apps/diary/get_rss.cgi"); - -$tmpl->param(access_control_URL => $afap->get_URL("access_control")); - - -print $tmpl->output; - -# ????若??????????-sub errorExit { - my $msg = shift; -print< -

?????/h3> -

$msg

-

-ACCESS_ERR -require ("./common/footer.pl"); - exit; -} - -sub getParam { - my $key = shift; - my $val = $afap->{cgi}->param($key); - if ($val) { - $afap->set_session_param($key, $val); - return $val; - } - return $afap->get_session_param($key); -} - -sub unsetParam { - my $key = shift; - $afap->set_session_param($key, ""); -} - -########################################################################## -1; Index: affelio_farm/admin/skelton/affelio/apps/diary/common/rss.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/common/rss.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/common/rss.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/common/rss.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/common/rss.pl Tue Oct 25 04:20:46 2005 @@ -1,55 +0,0 @@ -# RSS茹f?????違???-# ???????違????篁ヤ?????ゃ?????????????????????????????? -# http://digit.que.ne.jp/work/index.cgi - -use strict; -use Jcode; -use Time::Local; - -sub parse_rss { - my ($rss, $num) = @_; - my @items = (); - return unless ($rss); - $num = 0 unless ($num =~ /^\d+$/); - foreach my $item ($rss =~ /.*?<\/item>/gis) { - my $parsed = {}; - foreach my $tag qw(title link description dc:date) { - if ($item =~ /<$tag\b.*?>(.*?)<\/$tag>/is) { - $parsed->{$tag} = &sanitize($1); - } - } - $parsed->{'time'} = &date_to_time($parsed->{'dc:date'}); - push(@items, $parsed); - last if ($num and @items >= $num); - } - return @items; -} - -sub sanitize { - my $str = shift; - # remove tags and unescape - my $re_tag_ = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; #'}; - my $re_comment = '-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)'; - my $re_tag = qq{$re_comment|<$re_tag_}; - $str =~ s/$re_tag//g; - # resanitize - my %unescaped = ('<' => '<', '>' => '>', '"' => '"', ''' => "'", '©' => '(c)', '&' => '&'); - my %escaped = ('<' => '<', '>' => '>', '"' => '"', ''' => "'", '&' => '&'); - $str =~ s/&(lt|gt|quot|apos|copy|amp);/$unescaped{$1}/gio; - $str =~ s/([<>"'&])/$escaped{$1}/go; - return $str; -} - -sub date_to_time { - my $date = shift; - if ($date =~ /^(\d{4})(?:-(\d{2})(?:-(\d{2})(?:T(\d{2}):(\d{2})(?::(\d{2})(?:\.(\d))?)?(Z|([+-]\d{2}):(\d{2}))?)?)?)?$/) { - my ($year, $month, $day, $hour, $min, $sec) = ($1, ($2 ? $2 : 1), ($3 ? $3 : 1), $4, $5); - my $offset = (abs($8) * 60 + $9) * ($8 >= 0 ? 60 : -60) if ($7); - my $time = ($7) ? &Time::Local::timegm($sec, $min, $hour, $day, $month - 1, $year) - $offset - : &Time::Local::timelocal($sec, $min, $hour, $day, $month - 1, $year) - $offset; - return $time; - } - return undef; -} - -1; Index: affelio_farm/admin/skelton/affelio/apps/diary/common/util.pl diff -u affelio_farm/admin/skelton/affelio/apps/diary/common/util.pl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/common/util.pl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/common/util.pl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/common/util.pl Tue Oct 25 04:20:46 2005 @@ -1,23 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -sub markupURL { - my $text = shift; - $text =~ s/(s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/$1<\/a>/g; - return $text; -} - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:46 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:46 +0900 Subject: [Affelio-cvs 638] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/tb Message-ID: <20051024192046.ABE852AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/tb/Changes diff -u affelio_farm/admin/skelton/affelio/apps/diary/tb/Changes:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/tb/Changes:removed --- affelio_farm/admin/skelton/affelio/apps/diary/tb/Changes:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/tb/Changes Tue Oct 25 04:20:46 2005 @@ -1,19 +0,0 @@ -$Id: Changes,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -Revision history for standalone TrackBack server - -1.02 2002.10.11 - - Pings are now sent using GET if the ping URL contains C, POST - otherwise. Eventually, the support for GET will be dropped - entirely. - - Changed TB ping URLs to use path info for the TrackBack ID instead - of the query string. - -1.01 2002.09.06 - - All non-alphanumerics in the tb_id parameter are now converted to - '_' (underscore) characters, so as not to cause problems when used - in filenames. Thanks to Rael for the suggestion. - - Added conversion list for Bloxsom. Thanks to Rael. - -1.00 2002.08.28 - - Initial release. Index: affelio_farm/admin/skelton/affelio/apps/diary/tb/README diff -u affelio_farm/admin/skelton/affelio/apps/diary/tb/README:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/tb/README:removed --- affelio_farm/admin/skelton/affelio/apps/diary/tb/README:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/tb/README Tue Oct 25 04:20:46 2005 @@ -1,176 +0,0 @@ -NAME - tb-standalone - Standalone TrackBack - -DESCRIPTION - The standalone TrackBack tool serves two purposes: 1) it allows - non-Movable Type users to use TrackBack with the tool of their choice, - provided they meet the installation requirements; 2) it serves as a - reference point to aid developers in implementing TrackBack in their own - systems. This tool is a single CGI script that accepts TrackBack pings - through HTTP requests, stores the pings locally in the filesystem, and - can return a list of pings either in RSS or in a browser-viewable - format. It can also be used to send pings to other sites. - - It is released under the Artistic License. The terms of the Artistic - License are described at - *http://www.perl.com/language/misc/Artistic.html*. - -REQUIREMENTS - You'll need a webserver capable of running CGI scripts (this means, for - example, that this won't work with BlogSpot-hosted blogs). You'll also - need perl, and the following Perl modules: - - * File::Spec - * Storable - * CGI - * CGI::Cookie - * LWP - - The first four are core modules as of perl 5.6.0, I believe, and LWP is - installed on most hosts. Furthermore LWP is only required if you wish to - send TrackBack pings. - -INSTALLATION - Installation of the standalone TrackBack tool is very simple. It's just - one CGI script, tb.cgi, along with two text files that define the header - and footer HTML for the public list of TrackBack pings. - - 1. Configure tb.cgi - You'll need to edit the script to change the *$DataDir*, *$RSSDir*, - and *$Password* settings. - - BE SURE TO CHANGE THE *$Password* BEFORE INSTALLING THE TOOL. - - *$DataDir* is the path to the directory where the TrackBack data - files will be stored; *$RSSDir* is the path to the directory where - the static RSS files will be generated; *$Password* is your secret - password that will allow you to delete TrackBack pings, when logged - in. - - After setting *$DataDir* and *$RSSDir*, you'll need to create both - of these directories and make them writeable by the user running the - CGI scripts. In most cases, this means that you must set the - permissions on these directories to 777. - - 2. Upload Files - After editing the settings, upload tb.cgi, header.txt, and - footer.txt in ASCII mode to your webserver into a directory where - you can run CGI scripts. Set the permissions on tb.cgi to 755. - -USAGE - Sending Pings - To send pings from the tool, go to the following URL: - - http://yourserver.com/cgi-bin/tb.cgi?__mode=send_form - - where *http://yourserver.com/cgi-bin/tb.cgi* is the URL where you - installed tb.cgi. Fill out the fields in the form, then press *Send*. - - Receiving Pings - To use the tool in your existing pages, you'll need to do two things: - - 1. Link to TrackBack listing - First, you'll need to add a link to each of your weblog entries with - a link to the list of TrackBack pings for that entry. You can do - this by adding the following HTML to your template: - - TrackBack - - You'll need to change "http://yourserver.com/cgi-bin/tb.cgi" to the - proper URL for *tb.cgi* on your server. And, depending on the - weblogging tool that you use, you'll need to change "[TrackBack ID]" - to a unique post ID. See the conversion table below to determine the - proper tag to use for the tool that you use, to generate a unique - post ID. - - 2. Add RDF - TrackBack uses RDF embedded within your web page to auto-discover - TrackBack-enabled entries on your pages. It also uses this - information when building a threaded list of a cross-weblog - "discussion". For these purposes, it is useful to embed the RDF into - your page. - - Add the following to your weblog template so that it is displayed - for each of the entries on your page: - - - - As above, the tags that you should use for "[TrackBack ID]", "[Entry - Title]", and "[Entry Permalink]" all depend on the weblogging tool - that you are using. See the conversion table below. - - Conversion Table - * Blogger - TrackBack ID = "<$BlogItemNumber$>" - - Entry Title = "<$BlogItemSubject$>" - - Entry Permalink = "<$BlogItemArchiveFileName$>#<$BlogItemNumber$>" - - * GreyMatter - TrackBack ID = "{{entrynumber}}" - - Entry Title = "{{entrysubject}}" - - Entry Permalink = "{{pagelink}}" - - * b2 - TrackBack ID = "" - - Entry Title = "" - - Entry Permalink = "" - - * pMachine - TrackBack ID = "%%id%%" - - Entry Title = "%%title%%" - - Entry Permalink = "%%comment_permalink%%" - - * Bloxsom - TrackBack ID = $fn - - Entry Title = $title - - Entry Permalink = "$url/$yr/$mo/$da#$fn" - - Thanks to Rael for this list of conversions. - -POSSIBLE USES - 1. Content repository - Like Movable Type's TrackBack implementation, this standalone script - can be used to power a distributed content repository. The value of - the *tb_id* parameter does not necessarily have to be an integer, - because all it is used for is a filename (note that this is not true - of most other TrackBack implementations). For example, if you run a - site about cats, and want to have a way for users to ping your site - with entries they write about their own cats, you could set up a - TrackBack URL like http://www.foo.com/bar/tb.cgi?tb_id=cats, then - give that URL out on your site. End users could then associate this - URL with a *Cats* category in their own blog, and ping you whenever - they wrote about cats. - - 2. Building block - You can use this simple implementation as a building block, or a - guide, for implementing TrackBack in your own system. It illustrates - the core functionality of the TrackBack framework, onto which you - could add bells and whistles (IP banning, password-protected - TrackBacks, etc). - - 3. Centralized tool - This TrackBack tool requires that the end user have the ability to - run CGI scripts on their server. For many users (eg BlogSpot users), - this is not an option. For such users, a centralized system (based - on this tool, perhaps) would be ideal. - Index: affelio_farm/admin/skelton/affelio/apps/diary/tb/footer.txt diff -u affelio_farm/admin/skelton/affelio/apps/diary/tb/footer.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/tb/footer.txt:removed --- affelio_farm/admin/skelton/affelio/apps/diary/tb/footer.txt:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/tb/footer.txt Tue Oct 25 04:20:46 2005 @@ -1,7 +0,0 @@ -
- - - - - Index: affelio_farm/admin/skelton/affelio/apps/diary/tb/header.txt diff -u affelio_farm/admin/skelton/affelio/apps/diary/tb/header.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/tb/header.txt:removed --- affelio_farm/admin/skelton/affelio/apps/diary/tb/header.txt:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/tb/header.txt Tue Oct 25 04:20:46 2005 @@ -1,85 +0,0 @@ - - - - - - -TrackBack Display - - - - - - - -
Index: affelio_farm/admin/skelton/affelio/apps/diary/tb/tb.cgi diff -u affelio_farm/admin/skelton/affelio/apps/diary/tb/tb.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/tb/tb.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/diary/tb/tb.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/tb/tb.cgi Tue Oct 25 04:20:46 2005 @@ -1,481 +0,0 @@ -#!/usr/bin/perl -w -# Copyright 2002 Benjamin Trott. -# This code is released under the Artistic License. -use strict; - -#------------- -require 'init.pl'; - -use lib "../../extlib"; -use Jcode; -#------------- - -my $DataDir = '../data'; -my $RSSDir = $DataDir; -my $GenerateRSS = 1; -my $Header = "./header.txt"; -my $Footer = "./footer.txt"; -my $Password = ""; - -use vars qw( $VERSION ); -$VERSION = '1.02'; - -use CGI qw( :standard ); -use File::Spec::Functions; - -my $mode = param('__mode'); -unless ($mode) { - my $tb_id = munge_tb_id(get_tb_id()); - respond_exit("No TrackBack ID (tb_id)") unless $tb_id; - my $i = { map { $_ => scalar param($_) } qw(title excerpt url blog_name) }; - $i->{title} ||= $i->{url}; - $i->{timestamp} = time; -#------------- - $i->{title} = Jcode::convert($i->{title}, 'euc'); - $i->{excerpt} = Jcode::convert($i->{excerpt}, 'euc'); - $i->{blog_name} = Jcode::convert($i->{blog_name}, 'euc'); -#------------- - respond_exit("No URL (url)") unless $i->{url}; - my $data = load_data($tb_id); - unshift @$data, $i; - store_data($tb_id, $data); - if ($GenerateRSS && open(FH, ">" . catfile($RSSDir, $tb_id . '.xml'))) { - print FH generate_rss($tb_id, $data, 15); - close FH; - } - respond_exit(); -} elsif ($mode eq 'list') { - my $tb_id = munge_tb_id(get_tb_id()); - die("No TrackBack ID (tb_id)") unless $tb_id; - my $me = url(); - print header(), from_file($Header), <TrackBack URL for this entry: -
$me/$tb_id
-
-URL - my $data = load_data($tb_id); - my $tmpl = <%s
-
» %s
-
"%s"
- -TMPL - my $i = 0; - require POSIX; - my $logged_in = is_logged_in(); - for my $item (@$data) { - my $ts = POSIX::strftime("%B %d, %Y %I:%M %p", - localtime $item->{timestamp}); - printf $tmpl, - $item->{url}, $item->{title}, - $item->{blog_name} || "[No blog name]", - $item->{excerpt} || "[No excerpt]", - $ts, - $logged_in ? qq([DELETE]) : ''; - $i++; - } - unless ($logged_in) { - print <[Is this your site? Log in to delete pings.]
-HTML - } else { - print <[Log out] -HTML - } - print from_file($Footer); -} elsif ($mode eq 'delete') { - die "You are not authorized" unless is_logged_in(); - my $tb_id = munge_tb_id(get_tb_id()); - die("No TrackBack ID (tb_id)") unless $tb_id; - my $data = load_data($tb_id); - my $index = param('index') || 0; - splice @$data, $index, 1; - store_data($tb_id, $data); - print redirect(url() . "?__mode=list&tb_id=$tb_id"); -} elsif ($mode eq 'rss') { - my $tb_id = munge_tb_id(get_tb_id()); - respond_exit("No TrackBack ID (tb_id)") unless $tb_id; - my $data = load_data($tb_id); - respond_exit(undef, generate_rss($tb_id, $data)); -} elsif ($mode eq 'send_ping') { - require LWP::UserAgent; - my $ua = LWP::UserAgent->new; - $ua->agent("TrackBack/$VERSION"); - my @qs = map $_ . '=' . encode_url(param($_) || ''), - qw( title url excerpt blog_name ); - my $ping = param('ping_url') or ping_form_exit("No ping URL"); - my $req; - if ($ping =~ /\?/) { - $req = HTTP::Request->new(GET => $ping . '&' . join('&', @qs)); - } else { - $req = HTTP::Request->new(POST => $ping); - $req->content_type('application/x-www-form-urlencoded'); - $req->content(join('&', @qs)); - } - my $res = $ua->request($req); - ping_form_exit("HTTP error: " . $res->status_line) unless $res->is_success; - my($e, $msg) = $res->content =~ m!(\d+).*(.+?)!s; - $e ? ping_form_exit("Error: $msg") : ping_form_exit("Ping successfuly sent"); -} elsif ($mode eq 'send_form') { - ping_form_exit(); -} elsif ($mode eq 'login') { - print header(), login_form(); -} elsif ($mode eq 'do_login') { - my $key = param('key'); - unless ($key eq $Password) { - print header(), login_form("Invalid login"); - exit; - } - require CGI::Cookie; - my @alpha = ('a'..'z', 'A'..'Z', 0..9); - my $salt = join '', map $alpha[rand @alpha], 1..2; - my $cookie = CGI::Cookie->new(-name => 'key', - -value => crypt($key, $salt)); - print header(-cookie => $cookie), from_file($Header), - "Logged in", from_file($Footer); -} elsif ($mode eq 'logout') { - require CGI::Cookie; - my $cookie = CGI::Cookie->new(-name => 'key', -value => '', - -expire => '-1y'); - print header(-cookie => $cookie), login_form("Logged out"); -} - -sub get_tb_id { - my $tb_id = param('tb_id'); - unless ($tb_id) { - if (my $pi = path_info()) { - ($tb_id = $pi) =~ s!^/!!; - } - } - $tb_id; -} - -sub munge_tb_id { - my($id) = @_; - return '' unless $id; - $id =~ tr/a-zA-Z0-9/_/cs; - $id; -} - -sub is_logged_in { - require CGI::Cookie; - my %cookies = CGI::Cookie->fetch; - return unless $cookies{key}; - my $key = $cookies{key}->value || return; - $key eq crypt $Password, substr $key, 0, 2; -} - -sub load_data { - my($tb_id) = @_; - my $tb_file = catfile($DataDir, $tb_id . '.stor'); - require Storable; - scalar eval { Storable::retrieve($tb_file) } || []; -} - -sub store_data { - my($tb_id, $data) = @_; - my $tb_file = catfile($DataDir, $tb_id . '.stor'); - require Storable; - Storable::store($data, $tb_file); -} - -sub generate_rss { - my($tb_id, $data, $limit) = @_; - my $rss = qq(TB: $tb_id\n); - my $max = $limit ? $limit - 1 : $#$data; - for my $i (@{$data}[0..$max]) { - $rss .= sprintf "%s%s%s\n", xml('title', $i->{title}), - xml('link', $i->{url}), xml('description', $i->{excerpt}) if $i; - } - $rss . qq(); -} - -sub respond_exit { - print "Content-Type: text/xml\n\n"; - print qq(\n\n); - if ($_[0]) { - printf qq(1\n%s\n), xml('message', $_[0]); - } else { - print qq(0\n) . ($_[1] ? $_[1] : ''); - } - print "\n"; - exit; -} - -sub ping_form_exit { - print header(), from_file($Header); - print "@_" if @_; - print <Send a TrackBack ping -
- - - - - - - -
TrackBack Ping URL:
 
Title:
Blog name:
Excerpt:
Permalink URL:
- -
-HTML - print from_file($Footer); - exit; -} - -sub login_form { - my $str = from_file($Header); - $str .= "

@_

" if @_; - $str .= < - -Password: - - -HTML - $str; -} -my(%Map, $RE); -BEGIN { - %Map = ('&' => '&', '"' => '"', '<' => '<', '>' => '>'); - $RE = join '|', keys %Map; -} -sub xml { - (my $s = defined $_[1] ? $_[1] : '') =~ s!($RE)!$Map{$1}!g; - "<$_[0]>$s\n"; -} - -sub encode_url { - (my $str = $_[0]) =~ s!([^a-zA-Z0-9_.-])!uc sprintf "%%%02x", ord($1)!eg; - $str; -} - -sub from_file { - my($file) = @_; - local *FH; - open FH, $file; - my $c; - { local $/; $c = } - close FH; - $c; -} - -__END__ - -=head1 NAME - -tb-standalone - Standalone TrackBack - -=head1 DESCRIPTION - -The standalone TrackBack tool serves two purposes: 1) it allows non-Movable -Type users to use TrackBack with the tool of their choice, provided they meet -the installation requirements; 2) it serves as a reference point to aid -developers in implementing TrackBack in their own systems. This tool is a -single CGI script that accepts TrackBack pings through HTTP requests, stores -the pings locally in the filesystem, and can return a list of pings either -in RSS or in a browser-viewable format. It can also be used to send pings -to other sites. - -It is released under the Artistic License. The terms of the Artistic License -are described at I. - -=head1 REQUIREMENTS - -You'll need a webserver capable of running CGI scripts (this means, for -example, that this won't work with BlogSpot-hosted blogs). You'll also need -perl, and the following Perl modules: - -=over 4 - -=item * File::Spec - -=item * Storable - -=item * CGI - -=item * CGI::Cookie - -=item * LWP - -=back - -The first four are core modules as of perl 5.6.0, I believe, and LWP is -installed on most hosts. Furthermore LWP is only required if you wish to -B TrackBack pings. - -=head1 INSTALLATION - -Installation of the standalone TrackBack tool is very simple. It's just one -CGI script, F, along with two text files that define the header and -footer HTML for the public list of TrackBack pings. - -=over 4 - -=item 1. Configure tb.cgi - -You'll need to edit the script to change the I<$DataDir>, I<$RSSDir>, -and I<$Password> settings. - -B BEFORE INSTALLING THE TOOL.> - -I<$DataDir> is the path to the directory where the TrackBack data -files will be stored; I<$RSSDir> is the path to the directory where the static -RSS files will be generated; I<$Password> is your secret password that will -allow you to delete TrackBack pings, when logged in. - -After setting I<$DataDir> and I<$RSSDir>, you'll need to create both of these -directories and make them writeable by the user running the CGI scripts. In -most cases, this means that you must set the permissions on these directories -to 777. - -=item 2. Upload Files - -After editing the settings, upload F, F, and F -in ASCII mode to your webserver into a directory where you can run CGI -scripts. Set the permissions on F to 755. - -=back - -=head1 USAGE - -=head2 Sending Pings - -To send pings from the tool, go to the following URL: - - http://yourserver.com/cgi-bin/tb.cgi?__mode=send_form - -where I is the URL where you -installed F. Fill out the fields in the form, then press I. - -=head2 Receiving Pings - -To use the tool in your existing pages, you'll need to do two things: - -=over 4 - -=item 1. Link to TrackBack listing - -First, you'll need to add a link to each of your weblog entries with a -link to the list of TrackBack pings for that entry. You can do this by -adding the following HTML to your template: - - TrackBack - -You'll need to change C to the proper -URL for I on your server. And, depending on the weblogging tool that -you use, you'll need to change C<[TrackBack ID]> to a unique post ID. See -the L to determine the proper tag to -use for the tool that you use, to generate a unique post ID. - -=item 2. Add RDF - -TrackBack uses RDF embedded within your web page to auto-discover -TrackBack-enabled entries on your pages. It also uses this information when -building a threaded list of a cross-weblog "discussion". For these purposes, -it is useful to embed the RDF into your page. - -Add the following to your weblog template so that it is displayed for each -of the entries on your page: - - - -As above, the tags that you should use for C<[TrackBack ID]>, -C<[Entry Title]>, and C<[Entry Permalink]> all depend on the weblogging tool -that you are using. See the L. - -=back - -=head2 Conversion Table - -=over 4 - -=item * Blogger - -TrackBack ID = C$BlogItemNumber$E> - -Entry Title = CPostSubjectEE$BlogItemSubject$EE/PostSubjectE> - -Entry Permalink = C$BlogItemArchiveFileName$E#E$BlogItemNumber$E> - -=item * GreyMatter - -TrackBack ID = C<{{entrynumber}}> - -Entry Title = C<{{entrysubject}}> - -Entry Permalink = C<{{pagelink}}> - -=item * b2 - -TrackBack ID = C?php the_ID() ?E> - -Entry Title = C?php the_title() ?E> - -Entry Permalink = C?php permalink_link() ?E> - -=item * pMachine - -TrackBack ID = C<%%id%%> - -Entry Title = C<%%title%%> - -Entry Permalink = C<%%comment_permalink%%> - -=item * Bloxsom - -TrackBack ID = C<$fn> - -Entry Title = C<$title> - -Entry Permalink = C<$url/$yr/$mo/$da#$fn> - -Thanks to Rael for this list of conversions. - -=back - -=head1 POSSIBLE USES - -=over 4 - -=item 1. Content repository - -Like Movable Type's TrackBack implementation, this standalone script can -be used to power a distributed content repository. The value of the I -parameter does not necessarily have to be an integer, because all it is used -for is a filename (B that this is not true of most other TrackBack -implementations). For example, if you run a site about cats, and want to have -a way for users to ping your site with entries they write about their own -cats, you could set up a TrackBack URL like -F, then give that URL out on your -site. End users could then associate this URL with a I category in -their own blog, and ping you whenever they wrote about cats. - -=item 2. Building block - -You can use this simple implementation as a building block, or a guide, for -implementing TrackBack in your own system. It illustrates the core -functionality of the TrackBack framework, onto which you could add bells -and whistles (IP banning, password-protected TrackBacks, etc). - -=item 3. Centralized tool - -This TrackBack tool requires that the end user have the ability to run CGI -scripts on their server. For many users (eg BlogSpot users), this is not -an option. For such users, a centralized system (based on this tool, perhaps) -would be ideal. - -=back - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:46 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:46 +0900 Subject: [Affelio-cvs 639] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/icons Message-ID: <20051024192046.657E62AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/icons/normal.jpg Index: affelio_farm/admin/skelton/affelio/apps/diary/icons/over.jpg Index: affelio_farm/admin/skelton/affelio/apps/diary/icons/template.jpg From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:46 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:46 +0900 Subject: [Affelio-cvs 640] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/resource Message-ID: <20051024192046.891EF2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/resource/footer.txt diff -u affelio_farm/admin/skelton/affelio/apps/diary/resource/footer.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/resource/footer.txt:removed --- affelio_farm/admin/skelton/affelio/apps/diary/resource/footer.txt:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/resource/footer.txt Tue Oct 25 04:20:46 2005 @@ -1,7 +0,0 @@ -
- - - - - Index: affelio_farm/admin/skelton/affelio/apps/diary/resource/header.txt diff -u affelio_farm/admin/skelton/affelio/apps/diary/resource/header.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/resource/header.txt:removed --- affelio_farm/admin/skelton/affelio/apps/diary/resource/header.txt:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/resource/header.txt Tue Oct 25 04:20:46 2005 @@ -1,85 +0,0 @@ - - - - - - -TrackBack Display - - - - - - - -
Index: affelio_farm/admin/skelton/affelio/apps/diary/resource/xml.gif From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:46 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:46 +0900 Subject: [Affelio-cvs 641] CVS update: affelio_farm/admin/skelton/affelio/apps/diary/templates Message-ID: <20051024192047.032A42AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/access_error.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/access_error.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/access_error.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/access_error.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/access_error.tmpl Tue Oct 25 04:20:46 2005 @@ -1,24 +0,0 @@ -
- -
-?????/td> - -( ?≪??? - -login/logout
-
-?上?????違??鰹???TMPL_VAR NAME="AFID">
-?上?????若?鐚????TMPL_VAR NAME="VIS_TYPE">
-
-
-????ゃ?ID: -???????? - -???????≪???/a> - -
-
- -
-

-
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/calender.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/calender.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/calender.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/calender.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/calender.tmpl Tue Oct 25 04:20:46 2005 @@ -1,21 +0,0 @@ -
- - - - - - - - - - - - - - -
-<< -/ ->> -
-
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary.tmpl Tue Oct 25 04:20:46 2005 @@ -1,44 +0,0 @@ - - - - -
- - - - - - -
?ヨ???隈??()
?帥????" />
-
- - - - -
?ヨ??????()
- -
-
- - - -
- - - if $language->{'numf_comma'} is true; -that's a bit of a hack that's useful for languages that express -two million as "2.000.000" and not as "2,000,000"). - -If you want anything fancier, consider overriding this with something -that uses L, or does something else -entirely. - -Note that numf is called by quant for stringifying all quantifying -numbers. - -=item $language->sprintf($format, @items) - -This is just a wrapper around Perl's normal C function. -It's provided so that you can use "sprintf" in Bracket Notation: - - "Couldn't access datanode [sprintf,%10x=~[%s~],_1,_2]!\n" - -returning... - - Couldn't access datanode Stuff=[thangamabob]! - -=item $language->language_tag() - -Currently this just takes the last bit of C, turns -underscores to dashes, and returns it. So if $language is -an object of class Hee::HOO::Haw::en_us, $language->language_tag() -returns "en-us". (Yes, the usual representation for that language -tag is "en-US", but case is I considered meaningful in -language-tag comparison.) - -You may override this as you like; Maketext doesn't use it for -anything. - -=item $language->encoding() - -Currently this isn't used for anything, but it's provided -(with default value of -C<(ref($language) && $language-E{'encoding'})) or "iso-8859-1"> -) as a sort of suggestion that it may be useful/necessary to -associate encodings with your language handles (whether on a -per-class or even per-handle basis.) - -=back - -=head2 Language Handle Attributes and Internals - -A language handle is a flyweight object -- i.e., it doesn't (necessarily) -carry any data of interest, other than just being a member of -whatever class it belongs to. - -A language handle is implemented as a blessed hash. Subclasses of yours -can store whatever data you want in the hash. Currently the only hash -entry used by any crucial Maketext method is "fail", so feel free to -use anything else as you like. - -B This documentation -is vastly longer than the module source itself. - -=over - -=back - -=head1 LANGUAGE CLASS HIERARCHIES - -These are Locale::Maketext's assumptions about the class -hierarchy formed by all your language classes: - -=over - -=item * - -You must have a project base class, which you load, and -which you then use as the first argument in -the call to YourProjClass->get_handle(...). It should derive -(whether directly or indirectly) from Locale::Maketext. -It B how you name this class, altho assuming this -is the localization component of your Super Mega Program, -good names for your project class might be -SuperMegaProgram::Localization, SuperMegaProgram::L10N, -SuperMegaProgram::I18N, SuperMegaProgram::International, -or even SuperMegaProgram::Languages or SuperMegaProgram::Messages. - -=item * - -Language classes are what YourProjClass->get_handle will try to load. -It will look for them by taking each language-tag (B it -if it doesn't look like a language-tag or locale-tag!), turning it to -all lowercase, turning and dashes to underscores, and appending it -to YourProjClass . "::". So this: - - $lh = YourProjClass->get_handle( - 'en-US', 'fr', 'kon', 'i-klingon', 'i-klingon-romanized' - ); - -will try loading the classes -YourProjClass::en_us (note lowercase!), YourProjClass::fr, -YourProjClass::kon, -YourProjClass::i_klingon -and YourProjClass::i_klingon_romanized. (And it'll stop at the -first one that actually loads.) - -=item * - -I assume that each language class derives (directly or indirectly) -from your project class, and also defines its @ISA, its %Lexicon, -or both. But I anticipate no dire consequences if these assumptions -do not hold. - -=item * - -Language classes may derive from other language classes (altho they -should have "use I" or "use base qw(I<...classes...>)"). -They may derive from the project -class. They may derive from some other class altogether. Or via -multiple inheritance, it may derive from any mixture of these. - -=item * - -I foresee no problems with having multiple inheritance in -your hierarchy of language classes. (As usual, however, Perl will -complain bitterly if you have a cycle in the hierarchy: i.e., if -any class is its own ancestor.) - -=back - -=head1 ENTRIES IN EACH LEXICON - -A typical %Lexicon entry is meant to signify a phrase, -taking some number (0 or more) of parameters. An entry -is meant to be accessed by via -a string I in $lh->maketext(I, ...parameters...), -which should return a string that is generally meant for -be used for "output" to the user -- regardless of whether -this actually means printing to STDOUT, writing to a file, -or putting into a GUI widget. - -While the key must be a string value (since that's a basic -restriction that Perl places on hash keys), the value in -the lexicon can currenly be of several types: -a defined scalar, scalarref, or coderef. The use of these is -explained above, in the section 'The "maketext" Method', and -Bracket Notation for strings is discussed in the next section. - -While you can use arbitrary unique IDs for lexicon keys -(like "_min_larger_max_error"), it is often -useful for if an entry's key is itself a valid value, like -this example error message: - - "Minimum ([_1]) is larger than maximum ([_2])!\n", - -Compare this code that uses an arbitrary ID... - - die $lh->maketext( "_min_larger_max_error", $min, $max ) - if $min > $max; - -...to this code that uses a key-as-value: - - die $lh->maketext( - "Minimum ([_1]) is larger than maximum ([_2])!\n", - $min, $max - ) if $min > $max; - -The second is, in short, more readable. In particular, it's obvious -that the number of parameters you're feeding to that phrase (two) is -the number of parameters that it I to be fed. (Since you see -_1 and a _2 being used in the key there.) - -Also, once a project is otherwise -complete and you start to localize it, you can scrape together -all the various keys you use, and pass it to a translator; and then -the translator's work will go faster if what he's presented is this: - - "Minimum ([_1]) is larger than maximum ([_2])!\n", - => "", # fill in something here, Jacques! - -rather than this more cryptic mess: - - "_min_larger_max_error" - => "", # fill in something here, Jacques - -I think that keys as lexicon values makes the completed lexicon -entries more readable: - - "Minimum ([_1]) is larger than maximum ([_2])!\n", - => "Le minimum ([_1]) est plus grand que le maximum ([_2])!\n", - -Also, having valid values as keys becomes very useful if you set -up an _AUTO lexicon. _AUTO lexicons are discussed in a later -section. - -I almost always use keys that are themselves -valid lexicon values. One notable exception is when the value is -quite long. For example, to get the screenful of data that -a command-line program might returns when given an unknown switch, -I often just use a key "_USAGE_MESSAGE". At that point I then go -and immediately to define that lexicon entry in the -ProjectClass::L10N::en lexicon (since English is always my "project -lanuage"): - - '_USAGE_MESSAGE' => <<'EOSTUFF', - ...long long message... - EOSTUFF - -and then I can use it as: - - getopt('oDI', \%opts) or die $lh->maketext('_USAGE_MESSAGE'); - -Incidentally, -note that each class's C<%Lexicon> inherits-and-extends -the lexicons in its superclasses. This is not because these are -special hashes I, but because you access them via the -C method, which looks for entries across all the -C<%Lexicon>'s in a language class I all its ancestor classes. -(This is because the idea of "class data" isn't directly implemented -in Perl, but is instead left to individual class-systems to implement -as they see fit..) - -Note that you may have things stored in a lexicon -besides just phrases for output: for example, if your program -takes input from the keyboard, asking a "(Y/N)" question, -you probably need to know what equivalent of "Y[es]/N[o]" is -in whatever language. You probably also need to know what -the equivalents of the answers "y" and "n" are. You can -store that information in the lexicon (say, under the keys -"~answer_y" and "~answer_n", and the long forms as -"~answer_yes" and "~answer_no", where "~" is just an ad-hoc -character meant to indicate to programmers/translators that -these are not phrases for output). - -Or instead of storing this in the language class's lexicon, -you can (and, in some cases, really should) represent the same bit -of knowledge as code is a method in the language class. (That -leaves a tidy distinction between the lexicon as the things we -know how to I, and the rest of the things in the lexicon class -as things that we know how to I.) Consider -this example of a processor for responses to French "oui/non" -questions: - - sub y_or_n { - return undef unless defined $_[1] and length $_[1]; - my $answer = lc $_[1]; # smash case - return 1 if $answer eq 'o' or $answer eq 'oui'; - return 0 if $answer eq 'n' or $answer eq 'non'; - return undef; - } - -...which you'd then call in a construct like this: - - my $response; - until(defined $response) { - print $lh->maketext("Open the pod bay door (y/n)? "); - $response = $lh->y_or_n( get_input_from_keyboard_somehow() ); - } - if($response) { $pod_bay_door->open() } - else { $pod_bay_door->leave_closed() } - -Other data worth storing in a lexicon might be things like -filenames for language-targetted resources: - - ... - "_main_splash_png" - => "/styles/en_us/main_splash.png", - "_main_splash_imagemap" - => "/styles/en_us/main_splash.incl", - "_general_graphics_path" - => "/styles/en_us/", - "_alert_sound" - => "/styles/en_us/hey_there.wav", - "_forward_icon" - => "left_arrow.png", - "_backward_icon" - => "right_arrow.png", - # In some other languages, left equals - # BACKwards, and right is FOREwards. - ... - -You might want to do the same thing for expressing key bindings -or the like (since hardwiring "q" as the binding for the function -that quits a screen/menu/program is useful only if your language -happens to associate "q" with "quit"!) - -=head1 BRACKET NOTATION - -Bracket Notation is a crucial feature of Locale::Maketext. I mean -Bracket Notation to provide a replacement for sprintf formatting. -Everything you do with Bracket Notation could be done with a sub block, -but bracket notation is meant to be much more concise. - -Bracket Notation is a like a miniature "template" system (in the sense -of L, not in the sense of C++ templates), -where normal text is passed thru basically as is, but text is special -regions is specially interpreted. In Bracket Notation, you use brackets -("[...]" -- not "{...}"!) to note sections that are specially interpreted. - -For example, here all the areas that are taken literally are underlined with -a "^", and all the in-bracket special regions are underlined with an X: - - "Minimum ([_1]) is larger than maximum ([_2])!\n", - ^^^^^^^^^ XX ^^^^^^^^^^^^^^^^^^^^^^^^^^ XX ^^^^ - -When that string is compiled from bracket notation into a real Perl sub, -it's basically turned into: - - sub { - my $lh = $_[0]; - my @params = @_; - return join '', - "Minimum (", - ...some code here... - ") is larger than maximum (", - ...some code here... - ")!\n", - } - # to be called by $lh->maketext(KEY, params...) - -In other words, text outside bracket groups is turned into string -literals. Text in brackets is rather more complex, and currently follows -these rules: - -=over - -=item * - -Bracket groups that are empty, or which consist only of whitespace, -are ignored. (Examples: "[]", "[ ]", or a [ and a ] with returns -and/or tabs and/or spaces between them. - -Otherwise, each group is taken to be a comma-separated group of items, -and each item is interpreted as follows: - -=item * - -An item that is "_I" or "_-I" is interpreted as -$_[I]. I.e., "_1" is becomes with $_[1], and "_-3" is interpreted -as $_[-3] (in which case @_ should have at least three elements in it). -Note that $_[0] is the language handle, and is typically not named -directly. - -=item * - -An item "_*" is interpreted to mean "all of @_ except $_[0]". -I.e., C<@_[1..$#_]>. Note that this is an empty list in the case -of calls like $lh->maketext(I) where there are no -parameters (except $_[0], the language handle). - -=item * - -Otherwise, each item is interpreted as a string literal. - -=back - -The group as a whole is interpreted as follows: - -=over - -=item * - -If the first item in a bracket group looks like a method name, -then that group is interpreted like this: - - $lh->that_method_name( - ...rest of items in this group... - ), - -=item * - -If the first item in a bracket group is "*", it's taken as shorthand -for the so commonly called "quant" method. Similarly, if the first -item in a bracket group is "#", it's taken to be shorthand for -"numf". - -=item * - -If the first item in a bracket group is empty-string, or "_*" -or "_I" or "_-I", then that group is interpreted -as just the interpolation of all its items: - - join('', - ...rest of items in this group... - ), - -Examples: "[_1]" and "[,_1]", which are synonymous; and -"[,ID-(,_4,-,_2,)]", which compiles as -C. - -=item * - -Otherwise this bracket group is invalid. For example, in the group -"[!@#,whatever]", the first item C<"!@#"> is neither empty-string, -"_I", "_-I", "_*", nor a valid method name; and so -Locale::Maketext will throw an exception of you try compiling an -expression containing this bracket group. - -=back - -Note, incidentally, that items in each group are comma-separated, -not C-separated. That is, you might expect that this -bracket group: - - "Hoohah [foo, _1 , bar ,baz]!" - -would compile to this: - - sub { - my $lh = $_[0]; - return join '', - "Hoohah ", - $lh->foo( $_[1], "bar", "baz"), - "!", - } - -But it actually compiles as this: - - sub { - my $lh = $_[0]; - return join '', - "Hoohah ", - $lh->foo(" _1 ", " bar ", "baz"), #!!! - "!", - } - -In the notation discussed so far, the characters "[" and "]" are given -special meaning, for opening and closing bracket groups, and "," has -a special meaning inside bracket groups, where it separates items in the -group. This begs the question of how you'd express a literal "[" or -"]" in a Bracket Notation string, and how you'd express a literal -comma inside a bracket group. For this purpose I've adopted "~" (tilde) -as an escape character: "~[" means a literal '[' character anywhere -in Bracket Notation (i.e., regardless of whether you're in a bracket -group or not), and ditto for "~]" meaning a literal ']', and "~," meaning -a literal comma. (Altho "," means a literal comma outside of -bracket groups -- it's only inside bracket groups that commas are special.) - -And on the off chance you need a literal tilde in a bracket expression, -you get it with "~~". - -Currently, an unescaped "~" before a character -other than a bracket or a comma is taken to mean just a "~" and that -charecter. I.e., "~X" means the same as "~~X" -- i.e., one literal tilde, -and then one literal "X". However, by using "~X", you are assuming that -no future version of Maketext will use "~X" as a magic escape sequence. -In practice this is not a great problem, since first off you can just -write "~~X" and not worry about it; second off, I doubt I'll add lots -of new magic characters to bracket notation; and third off, you -aren't likely to want literal "~" characters in your messages anyway, -since it's not a character with wide use in natural language text. - -Brackets must be balanced -- every openbracket must have -one matching closebracket, and vice versa. So these are all B: - - "I ate [quant,_1,rhubarb pie." - "I ate [quant,_1,rhubarb pie[." - "I ate quant,_1,rhubarb pie]." - "I ate quant,_1,rhubarb pie[." - -Currently, bracket groups do not nest. That is, you B say: - - "Foo [bar,baz,[quux,quuux]]\n"; - -If you need a notation that's that powerful, use normal Perl: - - %Lexicon = ( - ... - "some_key" => sub { - my $lh = $_[0]; - join '', - "Foo ", - $lh->bar('baz', $lh->quux('quuux')), - "\n", - }, - ... - ); - -Or write the "bar" method so you don't need to pass it the -output from calling quux. - -I do not anticipate that you will need (or particularly want) -to nest bracket groups, but you are welcome to email me with -convincing (real-life) arguments to the contrary. - -=head1 AUTO LEXICONS - -If maketext goes to look in an individual %Lexicon for an entry -for I (where I does not start with an underscore), and -sees none, B an entry of "_AUTO" => I, -then we actually define $Lexicon{I} = I right then and there, -and then use that value as if it had been there all -along. This happens before we even look in any superclass %Lexicons! - -(This is meant to be somewhat like the AUTOLOAD mechanism in -Perl's function call system -- or, looked at another way, -like the L module.) - -I can picture all sorts of circumstances where you just -do not want lookup to be able to fail (since failing -normally means that maketext throws a C, altho -see the next section for greater control over that). But -here's one circumstance where _AUTO lexicons are meant to -be I useful: - -As you're writing an application, you decide as you go what messages -you need to emit. Normally you'd go to write this: - - if(-e $filename) { - go_process_file($filename) - } else { - print "Couldn't find file \"$filename\"!\n"; - } - -but since you anticipate localizing this, you write: - - use ThisProject::I18N; - my $lh = ThisProject::I18N->get_handle(); - # For the moment, assume that things are set up so - # that we load class ThisProject::I18N::en - # and that that's the class that $lh belongs to. - ... - if(-e $filename) { - go_process_file($filename) - } else { - print $lh->maketext( - "Couldn't find file \"[_1]\"!\n", $filename - ); - } - -Now, right after you've just written the above lines, you'd -normally have to go open the file -ThisProject/I18N/en.pm, and immediately add an entry: - - "Couldn't find file \"[_1]\"!\n" - => "Couldn't find file \"[_1]\"!\n", - -But I consider that somewhat of a distraction from the work -of getting the main code working -- to say nothing of the fact -that I often have to play with the program a few times before -I can decide exactly what wording I want in the messages (which -in this case would require me to go changing three lines of code: -the call to maketext with that key, and then the two lines in -ThisProject/I18N/en.pm). - -However, if you set "_AUTO => 1" in the %Lexicon in, -ThisProject/I18N/en.pm (assuming that English (en) is -the language that all your programmers will be using for this -project's internal message keys), then you don't ever have to -go adding lines like this - - "Couldn't find file \"[_1]\"!\n" - => "Couldn't find file \"[_1]\"!\n", - -to ThisProject/I18N/en.pm, because if _AUTO is true there, -then just looking for an entry with the key "Couldn't find -file \"[_1]\"!\n" in that lexicon will cause it to be added, -with that value! - -Note that the reason that keys that start with "_" -are immune to _AUTO isn't anything generally magical about -the underscore character -- I just wanted a way to have most -lexicon keys be autoable, except for possibly a few, and I -arbitrarily decided to use a leading underscore as a signal -to distinguish those few. - -=head1 CONTROLLING LOOKUP FAILURE - -If you call $lh->maketext(I, ...parameters...), -and there's no entry I in $lh's class's %Lexicon, nor -in the superclass %Lexicon hash, I if we can't auto-make -I (because either it starts with a "_", or because none -of its lexicons have C<_AUTO =E 1,>), then we have -failed to find a normal way to maketext I. What then -happens in these failure conditions, depends on the $lh object -"fail" attribute. - -If the language handle has no "fail" attribute, maketext -will simply throw an exception (i.e., it calls C, mentioning -the I whose lookup failed, and naming the line number where -the calling $lh->maketext(I,...) was. - -If the language handle has a "fail" attribute whose value is a -coderef, then $lh->maketext(I,...params...) gives up and calls: - - return &{$that_subref}($lh, $key, @params); - -Otherwise, the "fail" attribute's value should be a string denoting -a method name, so that $lh->maketext(I,...params...) can -give up with: - - return $lh->$that_method_name($phrase, @params); - -The "fail" attribute can be accessed with the C method: - - # Set to a coderef: - $lh->fail_with( \&failure_handler ); - - # Set to a method name: - $lh->fail_with( 'failure_method' ); - - # Set to nothing (i.e., so failure throws a plain exception) - $lh->fail_with( undef ); - - # Simply read: - $handler = $lh->fail_with(); - -Now, as to what you may want to do with these handlers: Maybe you'd -want to log what key failed for what class, and then die. Maybe -you don't like C and instead you want to send the error message -to STDOUT (or wherever) and then merely C. - -Or maybe you don't want to C at all! Maybe you could use a -handler like this: - - # Make all lookups fall back onto an English value, - # but after we log it for later fingerpointing. - my $lh_backup = ThisProject->get_handle('en'); - open(LEX_FAIL_LOG, ">>wherever/lex.log") || die "GNAARGH $!"; - sub lex_fail { - my($failing_lh, $key, $params) = @_; - print LEX_FAIL_LOG scalar(localtime), "\t", - ref($failing_lh), "\t", $key, "\n"; - return $lh_backup->maketext($key, @ params); - } - -Some users have expressed that they think this whole mechanism of -having a "fail" attribute at all, seems a rather pointless complication. -But I want Locale::Maketext to be usable for software projects of I -scale and type; and different software projects have different ideas -of what the right thing is to do in failure conditions. I could simply -say that failure always throws an exception, and that if you want to be -careful, you'll just have to wrap every call to $lh->maketext in an -S. However, I want programmers to reserve the right (via -the "fail" attribute) to treat lookup failure as something other than -an exception of the same level of severity as a config file being -unreadable, or some essential resource being inaccessable. - -One possibly useful value for the "fail" attribute is the method name -"failure_handler_auto". This is a method defined in class -Locale::Maketext itself. You set it with: - - $lh->fail_with('failure_handler_auto'); - -Then when you call $lh->maketext(I, ...parameters...) and -there's no I in any of those lexicons, maketext gives up with - - return $lh->failure_handler_auto($key, @params); - -But failure_handler_auto, instead of dying or anything, compiles -$key, caching it in $lh->{'failure_lex'}{$key} = $complied, -and then calls the compiled value, and returns that. (I.e., if -$key looks like bracket notation, $compiled is a sub, and we return -&{$compiled}(@params); but if $key is just a plain string, we just -return that.) - -The effect of using "failure_auto_handler" -is like an AUTO lexicon, except that it 1) compiles $key even if -it starts with "_", and 2) you have a record in the new hashref -$lh->{'failure_lex'} of all the keys that have failed for -this object. This should avoid your program dying -- as long -as your keys aren't actually invalid as bracket code, and as -long as they don't try calling methods that don't exist. - -"failure_auto_handler" may not be exactly what you want, but I -hope it at least shows you that maketext failure can be mitigated -in any number of very flexible ways. If you can formalize exactly -what you want, you should be able to express that as a failure -handler. You can even make it default for every object of a given -class, by setting it in that class's init: - - sub init { - my $lh = $_[0]; # a newborn handle - $lh->SUPER::init(); - $lh->fail_with('my_clever_failure_handler'); - return; - } - sub my_clever_failure_handler { - ...you clever things here... - } - -=head1 HOW TO USE MAKETEXT - -Here is a brief checklist on how to use Maketext to localize -applications: - -=over - -=item * - -Decide what system you'll use for lexicon keys. If you insist, -you can use opaque IDs (if you're nostalgic for C), -but I have better suggestions in the -section "Entries in Each Lexicon", above. Assuming you opt for -meaningful keys that double as values (like "Minimum ([_1]) is -larger than maximum ([_2])!\n"), you'll have to settle on what -language those should be in. For the sake of argument, I'll -call this English, specifically American English, "en-US". - -=item * - -Create a class for your localization project. This is -the name of the class that you'll use in the idiom: - - use Projname::L10N; - my $lh = Projname::L10N->get_handle(...) || die "Language?"; - -Assuming your call your class Projname::L10N, create a class -consisting minimally of: - - package Projname::L10N; - use base qw(Locale::Maketext); - ...any methods you might want all your languages to share... - - # And, assuming you want the base class to be an _AUTO lexicon, - # as is discussed a few sections up: - - 1; - -=item * - -Create a class for the language your internal keys are in. Name -the class after the language-tag for that language, in lowercase, -with dashes changed to underscores. Assuming your project's first -language is US English, you should call this Projname::L10N::en_us. -It should consist minimally of: - - package Projname::L10N::en_us; - use base qw(Projname::L10N); - %Lexicon = ( - '_AUTO' => 1, - ); - 1; - -(For the rest of this section, I'll assume that this "first -language class" of Projname::L10N::en_us has -_AUTO lexicon.) - -=item * - -Go and write your program. Everywhere in your program where -you would say: - - print "Foobar $thing stuff\n"; - -instead do it thru maketext, using no variable interpolation in -the key: - - print $lh->maketext("Foobar [_1] stuff\n", $thing); - -If you get tired of constantly saying Cmaketext>, -consider making a functional wrapper for it, like so: - - use Projname::L10N; - use vars qw($lh); - $lh = Projname::L10N->get_handle(...) || die "Language?"; - sub pmt (@) { print( $lh->maketext(@_)) } - # "pmt" is short for "Print MakeText" - $Carp::Verbose = 1; - # so if maketext fails, we see made the call to pmt - -Besides whole phrases meant for output, anything language-dependent -should be put into the class Projname::L10N::en_us, -whether as methods, or as lexicon entries -- this is discussed -in the section "Entries in Each Lexicon", above. - -=item * - -Once the program is otherwise done, and once its localization for -the first language works right (via the data and methods in -Projname::L10N::en_us), you can get together the data for translation. -If your first language lexicon isn't an _AUTO lexicon, then you already -have all the messages explicitly in the lexicon (or else you'd be -getting exceptions thrown when you call $lh->maketext to get -messages that aren't in there). But if you were (advisedly) lazy and are -using an _AUTO lexicon, then you've got to make a list of all the phrases -that you've so far been letting _AUTO generate for you. There are very -many ways to assemble such a list. The most straightforward is to simply -grep the source for every occurrence of "maketext" (or calls -to wrappers around it, like the above C function), and to log the -following phrase. - -=item * - -You may at this point want to consider whether the your base class -(Projname::L10N) that all lexicons inherit from (Projname::L10N::en, -Projname::L10N::es, etc.) should be an _AUTO lexicon. It may be true -that in theory, all needed messages will be in each language class; -but in the presumably unlikely or "impossible" case of lookup failure, -you should consider whether your program should throw an exception, -emit text in English (or whatever your project's first language is), -or some more complex solution as described in the section -"Controlling Lookup Failure", above. - -=item * - -Submit all messages/phrases/etc. to translators. - -(You may, in fact, want to start with localizing to I other language -at first, if you're not sure that you've property abstracted the -language-dependent parts of your code.) - -Translators may request clarification of the situation in which a -particular phrase is found. For example, in English we are entirely happy -saying "I files found", regardless of whether we mean "I looked for files, -and found I of them" or the rather distinct situation of "I looked for -something else (like lines in files), and along the way I saw I -files." This may involve rethinking things that you thought quite clear: -should "Edit" on a toolbar be a noun ("editing") or a verb ("to edit")? Is -there already a conventionalized way to express that menu option, separate -from the target language's normal word for "to edit"? - -In all cases where the very common phenomenon of quantification -(saying "I files", for B value of N) -is involved, each translator should make clear what dependencies the -number causes in the sentence. In many cases, dependency is -limited to words adjacent to the number, in places where you might -expect them ("I found the-?PLURAL I -empty-?PLURAL directory-?PLURAL"), but in some cases there are -unexpected dependencies ("I found-?PLURAL ..."!) as well as long-distance -dependencies "The I directory-?PLURAL could not be deleted-?PLURAL"!). - -Remind the translators to consider the case where N is 0: -"0 files found" isn't exactly natural-sounding in any language, but it -may be unacceptable in many -- or it may condition special -kinds of agreement (similar to English "I didN'T find ANY files"). - -Remember to ask your translators about numeral formatting in their -language, so that you can override the C method as -appropriate. Typical variables in number formatting are: what to -use as a decimal point (comma? period?); what to use as a thousands -separator (space? nonbreakinng space? comma? period? small -middot? prime? apostrophe?); and even whether the so-called "thousands -separator" is actually for every third digit -- I've heard reports of -two hundred thousand being expressable as "2,00,000" for some Indian -(Subcontinental) languages, besides the less surprising "S<200 000>", -"200.000", "200,000", and "200'000". Also, using a set of numeral -glyphs other than the usual ASCII "0"-"9" might be appreciated, as via -C for getting digits in Devanagari script -(for Hindi, Konkani, others). - -The basic C method that Locale::Maketext provides should be -good for many languages. For some languages, it might be useful -to modify it (or its constituent C method) -to take a plural form in the two-argument call to C -(as in "[quant,_1,files]") if -it's all-around easier to infer the singular form from the plural, than -to infer the plural form from the singular. - -But for other languages (as is discussed at length -in L), simple -C/C is not enough. For the particularly problematic -Slavic languages, what you may need is a method which you provide -with the number, the citation form of the noun to quantify, and -the case and gender that the sentence's syntax projects onto that -noun slot. The method would then be responsible for determining -what grammatical number that numeral projects onto its noun phrase, -and what case and gender it may override the normal case and gender -with; and then it would look up the noun in a lexicon providing -all needed inflected forms. - -=item * - -You may also wish to discuss with the translators the question of -how to relate different subforms of the same language tag, -considering how this reacts with C's treatment of -these. For example, if a user accepts interfaces in "en, fr", and -you have interfaces available in "en-US" and "fr", what should -they get? You may wish to resolve this by establishing that "en" -and "en-US" are effectively synonymous, by having one class -zero-derive from the other. - -For some languages this issue may never come up (Danish is rarely -expressed as "da-DK", but instead is just "da"). And for other -languages, the whole concept of a "generic" form may verge on -being uselessly vague, particularly for interfaces involving voice -media in forms of Arabic or Chinese. - -=item * - -Once you've localized your program/site/etc. for all desired -languages, be sure to show the result (whether live, or via -screenshots) to the translators. Once they approve, make every -effort to have it then checked by at least one other speaker of -that language. This holds true even when (or especially when) the -translation is done by one of your own programmers. Some -kinds of systems may be harder to find testers for than others, -depending on the amount of domain-specific jargon and concepts -involved -- it's easier to find people who can tell you whether -they approve of your translation for "delete this message" in an -email-via-Web interface, than to find people who can give you -an informed opinion on your translation for "attribute value" -in an XML query tool's interface. - -=back - -=head1 SEE ALSO - -I recommend reading all of these: - -L -- my I article about Maketext. It explains many important concepts -underlying Locale::Maketext's design, and some insight into why -Maketext is better than the plain old approach of just having -message catalogs that are just databases of sprintf formats. - -L is a sample application/module -that uses Locale::Maketext to localize its messages. - -L. - -L. - -RFC 3066, I, -as at http://sunsite.dk/RFC/rfc/rfc3066.html - -RFC 2277, I -is at http://sunsite.dk/RFC/rfc/rfc2277.html -- much of it is -just things of interest to protocol designers, but it explains -some basic concepts, like the distinction between locales and -language-tags. - -The manual for GNU C. The gettext dist is available in -C -- get -a recent gettext tarball and look in its "doc/" directory, there's -an easily browsable HTML version in there. The -gettext documentation asks lots of questions worth thinking -about, even if some of their answers are sometimes wonky, -particularly where they start talking about pluralization. - -The Locale/Maketext.pm source. Obverse that the module is much -shorter than its documentation! - -=head1 COPYRIGHT AND DISCLAIMER - -Copyright (c) 1999-2001 Sean M. Burke. All rights reserved. - -This library 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 - -# Zing! From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:51 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:51 +0900 Subject: [Affelio-cvs 663] CVS update: affelio_farm/admin/skelton/affelio/extlib/Mail Message-ID: <20051024192051.48D622AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Mail/Mailer.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Mail/Mailer.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Mail/Mailer.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Mail/Mailer.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Mail/Mailer.pm Tue Oct 25 04:20:51 2005 @@ -1,327 +0,0 @@ -# - -package Mail::Mailer; - -=head1 NAME - -Mail::Mailer - Simple interface to electronic mailing mechanisms - -=head1 SYNOPSIS - - use Mail::Mailer; - use Mail::Mailer qw(mail); - - $mailer = new Mail::Mailer; - - $mailer = new Mail::Mailer $type, @args; - - $mailer->open(\%headers); - - print $mailer $body; - - $mailer->close; - - -=head1 DESCRIPTION - -Sends mail using any of the built-in methods. As C<$type> you can specify -any of: - -=over 4 - -=item C -Use the C program to deliver the mail. - -=item C - -Use the C protocol via Net::SMTP to deliver the mail. The server -to use can be specified in C<@args> with - - $mailer = new Mail::Mailer 'smtp', Server => $server; - -The smtp mailer does not handle C and C lines, neither their -C fellows. The C options enables debugging output -from C. - -=item C - -Use qmail's qmail-inject program to deliver the mail. - -=item C - -Used for debugging, this displays the data to the file named in -C<$Mail::Mailer::testfile::config{outfile}> which defaults to a file -named C. No mail is ever sent. - -=back - -C will search for executables in the above order. The -default mailer will be the first one found. - -=head2 ARGUMENTS - -C can optionally be given a C<$type>, which -is one C, C, ... given above. - -C is given a reference to a hash. The hash consists of key and -value pairs, the key being the name of the header field (eg, C), -and the value being the corresponding contents of the header field. -The value can either be a scalar (eg, C) or a reference -to an array of scalars (C). - -=head1 TO DO - -Assist formatting of fields in ...::rfc822:send_headers to ensure -valid in the face of newlines and longlines etc. - -Secure all forms of send_headers() against hacker attack and invalid -contents. Especially "\n~..." in ...::mail::send_headers. - -=head1 ENVIRONMENT VARIABLES - -=over 4 - -=item PERL_MAILERS - -Augments/override the build in choice for binary used to send out -our mail messages. - -Format: - - "type1:mailbinary1;mailbinary2;...:type2:mailbinaryX;...:..." - -Example: assume you want you use private sendmail binary instead -of mailx, one could set C to: - - "mail:/does/not/exists:sendmail:$HOME/test/bin/sendmail" - -On systems which may include C<:> in file names, use C<|> as separator -between type-groups. - - "mail:c:/does/not/exists|sendmail:$HOME/test/bin/sendmail" - - -=back - -=head1 SEE ALSO - -Mail::Send - -=head1 AUTHORS - -Maintained by Mark Overmeer - -Original code written by Tim Bunce EFE, -with a kick start from Graham Barr EFE. With -contributions by Gerard Hickey EFE Small fix -and documentation by Nathan Torkington EFE. - -=cut - -use Carp; -use IO::Handle; -use vars qw(@ISA $VERSION $MailerBinary $MailerType %Mailers @Mailers); -use Config; -use strict; - -$VERSION = "1.64"; - -sub Version { $VERSION } - - @ ISA = qw(IO::Handle); - -# Suggested binaries for types? Should this be handled in the object class? - @ Mailers = ( - - # Headers-blank-Body all on stdin - 'sendmail' => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail', - - 'smtp'=> undef, - 'qmail' => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject', - 'testfile'=> undef - ); - -if($ENV{PERL_MAILERS}) -{ push @Mailers - , map { split /\:/, $_, 2} - split /$Config{path_sep}/, $ENV{PERL_MAILERS}; -} - -%Mailers = @Mailers; - -$MailerBinary = undef; - -# does this really need to be done? or should a default mailer be specfied? - -if($^O eq 'os2') { - $Mailers{sendmail} = 'sendmail' unless is_exe($Mailers{sendmail}); -} - -if($^O eq 'MacOS' || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'os2') { - $MailerType = 'smtp'; - $MailerBinary = $Mailers{$MailerType}; -} -else { - my $i; - for($i = 0 ; $i < @Mailers ; $i += 2) { - $MailerType = $Mailers[$i]; - my $binary; - if($binary = is_exe($Mailers{$MailerType})) { - $MailerBinary = $binary; - last; - } - } -} - -sub import { - shift; - - if(@_) { - my $type = shift; - my $exe = shift || $Mailers{$type}; - - carp "Cannot locate '$exe'" - unless is_exe($exe); - - $MailerType = $type; - $Mailers{$MailerType} = $exe; - } -} - -sub to_array { - my($self, $thing) = @_; - if (ref($thing)) { - return @$thing; - } else { - return ($thing); - } -} - -sub is_exe { - my $exe = shift || ''; - my $cmd; - - foreach $cmd (split /\;/, $exe) { - $cmd =~ s/^\s+//; - - # remove any options - my $name = ($cmd =~ /^(\S+)/)[0]; - - # check for absolute or relative path - return ($cmd) - if (-x $name and ! -d $name and $name =~ m:[\\/]:); - - if (defined $ENV{PATH}) { - my $dir; - foreach $dir (split(/$Config{path_sep}/, $ENV{PATH})) { - return "$dir/$cmd" - if (-x "$dir/$name" && ! -d "$dir/$name"); - } - } - } - 0; -} - -sub new { - my($class, $type, @args) = @_; - - $type = $MailerType unless $type; - croak "No MailerType specified" unless defined $type; - - my $exe = $Mailers{$type}; - - if(defined($exe)) { - $exe = is_exe ($exe) if defined $type; - - $exe = $MailerBinary unless $exe; - croak "No mailer type specified (and no default available), thus can not find executable program." - unless $exe; - } - - $class = "Mail::Mailer::$type"; - eval "require $class" or die $@; - my $glob = $class->SUPER::new; # local($glob) = gensym;# Make glob for FileHandle and attributes - - %{*$glob} = (Exe => $exe, - Args=> [ @args ] - ); - - $glob; # bless $glob, $class; -} - - -sub open { - my($self, $hdrs) = @_; - my $exe = *$self->{Exe}; # || Carp::croak "$self->open: bad exe"; - my $args = *$self->{Args}; - _cleanup_hdrs($hdrs); - my @to = $self->who_to($hdrs); - - $self->close;# just in case; - - # Fork and start a mailer - (defined($exe) && open($self,"|-")) - || $self->exec($exe, $args, \@to) - || die $!; - - # Set the headers - $self->set_headers($hdrs); - - # return self (a FileHandle) ready to accept the body - $self; -} - - -sub _cleanup_hdrs { - my $hdrs = shift; - my $h; - foreach $h (values %$hdrs) { - foreach (ref($h) ? @{$h} : $h) { - s/\n\s*/ /g; - s/\s+$//; - } - } -} - - -sub exec { - my($self, $exe, $args, $to) = @_; - # Fork and exec the mailer (no shell involved to avoid risks) - my @exe = split(/\s+/,$exe); - - exec(@exe, @$args, @$to); -} - -sub can_cc { 1 }# overridden in subclass for mailer that can't - -sub who_to { - my($self, $hdrs) = @_; - my @to = $self->to_array($hdrs->{To}); - if (!$self->can_cc) { # Can't cc/bcc so add them to @to - push(@to, $self->to_array($hdrs->{Cc})) if $hdrs->{Cc}; - push(@to, $self->to_array($hdrs->{Bcc})) if $hdrs->{Bcc}; - } - @to; -} - -sub epilogue { - # This could send a .signature, also see ::smtp subclass -} - -sub close { - my($self, @to) = @_; - if (fileno($self)) { - $self->epilogue; - close($self) - } -} - - -sub DESTROY { - my $self = shift; - $self->close; -} - -1; - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:51 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:51 +0900 Subject: [Affelio-cvs 664] CVS update: affelio_farm/admin/skelton/affelio/extlib/MIME/Base64 Message-ID: <20051024192051.2A3EE2AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/MIME/Base64/Perl.pm diff -u affelio_farm/admin/skelton/affelio/extlib/MIME/Base64/Perl.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/MIME/Base64/Perl.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/MIME/Base64/Perl.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/MIME/Base64/Perl.pm Tue Oct 25 04:20:51 2005 @@ -1,152 +0,0 @@ -package MIME::Base64::Perl; - -# $Id: Perl.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use vars qw(@ISA @EXPORT $VERSION); - -require Exporter; - @ ISA = qw(Exporter); - @ EXPORT = qw(encode_base64 decode_base64); - -$VERSION = '1.00'; - -sub encode_base64 ($;$) -{ - if ($] >= 5.006) { - require bytes; - if (bytes::length($_[0]) > length($_[0]) || - ($] >= 5.008 && $_[0] =~ /[^\0-\xFF]/)) - { - require Carp; - Carp::croak("The Base64 encoding is only defined for bytes"); - } - } - - use integer; - - my $eol = $_[1]; - $eol = "\n" unless defined $eol; - - my $res = pack("u", $_[0]); - # Remove first character of each line, remove newlines - $res =~ s/^.//mg; - $res =~ s/\n//g; - - $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs - # fix padding at the end - my $padding = (3 - length($_[0]) % 3) % 3; - $res =~ s/.{$padding}$/'=' x $padding/e if $padding; - # break encoded string into lines of no more than 76 characters each - if (length $eol) { - $res =~ s/(.{1,76})/$1$eol/g; - } - return $res; -} - - -sub decode_base64 ($) -{ - local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123] - use integer; - - my $str = shift; - $str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars - if (length($str) % 4) { - require Carp; - Carp::carp("Length of base64 data not a multiple of 4") - } - $str =~ s/=+$//; # remove padding - $str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format - return "" unless length $str; - - ## I guess this could be written as - #return unpack("u", join('', map( chr(32 + length($_)*3/4) . $_, - # $str =~ /(.{1,60})/gs) ) ); - ## but I do not like that... - my $uustr = ''; - my ($i, $l); - $l = length($str) - 60; - for ($i = 0; $i <= $l; $i += 60) { - $uustr .= "M" . substr($str, $i, 60); - } - $str = substr($str, $i); - # and any leftover chars - if ($str ne "") { - $uustr .= chr(32 + length($str)*3/4) . $str; - } - return unpack ("u", $uustr); -} - -1; - -__END__ - -=head1 NAME - -MIME::Base64::Perl - Encoding and decoding of base64 strings - -=head1 SYNOPSIS - - use MIME::Base64::Perl; - - $encoded = encode_base64('Aladdin:open sesame'); - $decoded = decode_base64($encoded); - -=head1 DESCRIPTION - -This module provide the same interface as C, but these -functions are implemented in pure perl. - -This module provides functions to encode and decode strings into and from the -base64 encoding specified in RFC 2045 - I. The base64 encoding is designed to represent -arbitrary sequences of octets in a form that need not be humanly -readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used, -enabling 6 bits to be represented per printable character. - -The following functions are provided: - -=over 4 - -=item encode_base64($str) - -=item encode_base64($str, $eol); - -Encode data by calling the encode_base64() function. The first -argument is the string to encode. The second argument is the -line-ending sequence to use. It is optional and defaults to "\n". The -returned encoded string is broken into lines of no more than 76 -characters each and it will end with $eol unless it is empty. Pass an -empty string as second argument if you do not want the encoded string -to be broken into lines. - -=item decode_base64($str) - -Decode a base64 string by calling the decode_base64() function. This -function takes a single argument which is the string to decode and -returns the decoded data. - -Any character not part of the 65-character base64 subset is -silently ignored. Characters occurring after a '=' padding character -are never decoded. - -=back - -=head1 COPYRIGHT - -Copyright 1995-1999, 2001-2004 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -Distantly based on LWP::Base64 written by Martijn Koster - and Joerg Reichelt and -code posted to comp.lang.perl <3pd2lp$6gf @ wsinti07.win.tue.nl> by Hans -Mulder - -=head1 SEE ALSO - -L, L - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:51 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:51 +0900 Subject: [Affelio-cvs 665] CVS update: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport Message-ID: <20051024192051.DDBF12AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm Tue Oct 25 04:20:51 2005 @@ -1,110 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: FTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::FTP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use Net::FTP; -use IO::File; -use URI; - -# ====================================================================== - -package SOAP::Transport::FTP::Client; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Client); - -sub new { - my $self = shift; - my $class = ref($self) || $self; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - $endpoint ||= $self->endpoint; # ftp://login:password @ ftp.something/dir/file - - my $uri = URI->new($endpoint); - my($server, $auth) = reverse split /@/, $uri->authority; - my $dir = substr($uri->path, 1, rindex($uri->path, '/')); - my $file = substr($uri->path, rindex($uri->path, '/')+1); - - eval { - my $ftp = Net::FTP->new($server, %$self) or die "Can't connect to $server: $@\n"; - $ftp->login(split /:/, $auth) or die "Couldn't login\n"; - $dir and ($ftp->cwd($dir) or - $ftp->mkdir($dir, 'recurse') and $ftp->cwd($dir) or die "Couldn't change directory to '$dir'\n"); - - my $FH = IO::File->new_tmpfile; print $FH $envelope; $FH->flush; $FH->seek(0,0); - $ftp->put($FH => $file) or die "Couldn't put file '$file'\n"; - $ftp->quit; - }; - - (my $code = $@) =~ s/\n$//; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::FTP - Client side FTP support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'ftp://login:password @ ftp.somewhere.com/relative/path/to/file.xml', # ftp server - # proxy => 'ftp://login:password @ ftp.somewhere.com//absolute/path/to/file.xml', # ftp server - ; - - print getStateName(1); - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm Tue Oct 25 04:20:51 2005 @@ -1,888 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: HTTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::HTTP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use SOAP::Lite; - -# ====================================================================== - -package SOAP::Transport::HTTP::Client; - -use vars qw(@ISA $COMPRESS); - @ ISA = qw(SOAP::Client LWP::UserAgent); - -$COMPRESS = 'deflate'; - -my(%redirect, %mpost, %nocompress); - -# hack for HTTP conection that returns Keep-Alive -# miscommunication (?) between LWP::Protocol and LWP::Protocol::http -# dies after timeout, but seems like we could make it work -sub patch { - local $^W; - { sub LWP::UserAgent::redirect_ok; *LWP::UserAgent::redirect_ok = sub {1} } - { package LWP::Protocol; - my $collect = \&collect; # store original - *collect = sub { - if (defined $_[2]->header('Connection') && $_[2]->header('Connection') eq 'Keep-Alive') { - my $data = $_[3]->(); - my $next = SOAP::Utils::bytelength($$data) == $_[2]->header('Content-Length') ? sub { \'' } : $_[3]; - my $done = 0; $_[3] = sub { $done++ ? &$next : $data }; - } - goto &$collect; - }; - } - *patch = sub {}; -}; - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require LWP::UserAgent; patch; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@params); - $self->agent(join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION); - $self->options({}); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action, $encoding) = - @parameters{qw(envelope endpoint action encoding)}; - - $endpoint ||= $self->endpoint; - - my $method = 'POST'; - my $resp; - - $self->options->{is_compress} ||= exists $self->options->{compress_threshold} && - eval { require Compress::Zlib }; - - COMPRESS: { - - my $compressed = !exists $nocompress{$endpoint} && - $self->options->{is_compress} && - ($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $envelope; - $envelope = Compress::Zlib::compress($envelope) if $compressed; - - while (1) { - - # check cache for redirect - $endpoint = $redirect{$endpoint} if exists $redirect{$endpoint}; - # check cache for M-POST - $method = 'M-POST' if exists $mpost{$endpoint}; - - # what's this all about? - # unfortunately combination of LWP and Perl 5.6.1 and later has bug - # in sending multibyte characters. LWP uses length() to calculate - # content-length header and starting 5.6.1 length() calculates chars - # instead of bytes. 'use bytes' in THIS file doesn't work, because - # it's lexically scoped. Unfortunately, content-length we calculate - # here doesn't work either, because LWP overwrites it with - # content-length it calculates (which is wrong) AND uses length() - # during syswrite/sysread, so we are in a bad shape anyway. - - # what to do? we calculate proper content-length (using - # bytelength() function from SOAP::Utils) and then drop utf8 mark - # from string (doing pack with 'C0A*' modifier) if length and - # bytelength are not the same - my $bytelength = SOAP::Utils::bytelength($envelope); - $envelope = pack('C0A*', $envelope) - if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength; - - my $req = HTTP::Request->new($method => $endpoint, HTTP::Headers->new, $envelope); - - $req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'}) - if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'}); # by Murray Nesbitt - - if ($method eq 'M-POST') { - my $prefix = sprintf '%04d', int(rand(1000)); - $req->header(Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix!); - $req->header("$prefix-SOAPAction" => $action) if defined $action; - } else { - $req->header(SOAPAction => $action) if defined $action; - } - - # allow compress if present and let server know we could handle it - $req->header(Accept => ['text/xml', 'multipart/*']); - - $req->header('Accept-Encoding' => [$COMPRESS]) if $self->options->{is_compress}; - $req->content_encoding($COMPRESS) if $compressed; - - $req->content_type(join '; ', 'text/xml', - !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? 'charset=' . lc($encoding) : ()); - $req->content_length($bytelength); - - SOAP::Trace::transport($req); - SOAP::Trace::debug($req->as_string); - - $self->SUPER::env_proxy if $ENV{'HTTP_proxy'}; - - $resp = $self->SUPER::request($req); - - SOAP::Trace::transport($resp); - SOAP::Trace::debug($resp->as_string); - - # 100 OK, continue to read? - if (($resp->code == 510 || $resp->code == 501) && $method ne 'M-POST') { - $mpost{$endpoint} = 1; - } elsif ($resp->code == 415 && $compressed) { # 415 Unsupported Media Type - $nocompress{$endpoint} = 1; - $envelope = Compress::Zlib::uncompress($envelope); - redo COMPRESS; # try again without compression - } else { - last; - } - } - } - - $redirect{$endpoint} = $resp->request->url - if $resp->previous && $resp->previous->is_redirect; - - $self->code($resp->code); - $self->message($resp->message); - $self->is_success($resp->is_success); - $self->status($resp->status_line); - - my $content = ($resp->content_encoding || '') =~ /\b$COMPRESS\b/o && $self->options->{is_compress} - ? Compress::Zlib::uncompress($resp->content) - : ($resp->content_encoding || '') =~ /\S/ - ? die "Unexpected Content-Encoding '@{[$resp->content_encoding]}' returned\n" - : $resp->content; - $resp->content_type =~ m!^multipart/! - ? join("\n", $resp->headers_as_string, $content) - : ($resp->content_type eq 'text/xml' || # text/xml - !$resp->is_success || # failed request - $SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE) - ? $content - : die "Unexpected Content-Type '@{[join '; ', $resp->content_type]}' returned\n"; -} - -# ====================================================================== - -package SOAP::Transport::HTTP::Server; - -use vars qw(@ISA $COMPRESS); - @ ISA = qw(SOAP::Server); - -use URI; - -$COMPRESS = 'deflate'; - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require LWP::UserAgent; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - $self->on_action(sub { - (my $action = shift) =~ s/^("?)(.*)\1$/$2/; - die "SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n" - if $action && $action ne join('#', @_) - && $action ne join('/', @_) - && (substr($_[0], -1, 1) ne '/' || $action ne join('', @_)); - }); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - for my $method (qw(request response)) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; - } - } -} - -sub handle { - my $self = shift->new; - - if ($self->request->method eq 'POST') { - $self->action($self->request->header('SOAPAction')); - } elsif ($self->request->method eq 'M-POST') { - return $self->response(HTTP::Response->new(510, # NOT EXTENDED - "Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI")) - if $self->request->header('Man') !~ /^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/; - $self->action($self->request->header("$1-SOAPAction")); - } else { - return $self->response(HTTP::Response->new(405)) # METHOD NOT ALLOWED - } - - my $compressed = ($self->request->content_encoding || '') =~ /\b$COMPRESS\b/; - $self->options->{is_compress} ||= $compressed && eval { require Compress::Zlib }; - - # signal error if content-encoding is 'deflate', but we don't want it OR - # something else, so we don't understand it - return $self->response(HTTP::Response->new(415)) # UNSUPPORTED MEDIA TYPE - if $compressed && !$self->options->{is_compress} || - !$compressed && ($self->request->content_encoding || '') =~ /\S/; - - my $content_type = $self->request->content_type || ''; - # in some environments (PerlEx?) content_type could be empty, so allow it also - # anyway it'll blow up inside ::Server::handle if something wrong with message - # TBD: but what to do with MIME encoded messages in THOSE environments? - return $self->make_fault($SOAP::Constants::FAULT_CLIENT, "Content-Type must be 'text/xml' instead of '$content_type'") - if $content_type && - $content_type ne 'text/xml' && - $content_type !~ m!^multipart/!; - - my $content = $compressed ? Compress::Zlib::uncompress($self->request->content) : $self->request->content; - my $response = $self->SUPER::handle( - $self->request->content_type =~ m!^multipart/! - ? join("\n", $self->request->headers_as_string, $content) : $content - ) or return; - - $self->make_response($SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response); -} - -sub make_fault { - my $self = shift; - $self->make_response($SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_)); - return; -} - -sub make_response { - my $self = shift; - my($code, $response) = @_; - - my $encoding = $1 if $response =~ /^<\?xml(?: version="1.0"| encoding="([^"]+)")+\?>/; - $response =~ s!(\?>)!$1! if $self->request->content_type eq 'multipart/form-data'; - - $self->options->{is_compress} ||= - exists $self->options->{compress_threshold} && eval { require Compress::Zlib }; - - my $compressed = $self->options->{is_compress} && - grep(/\b($COMPRESS|\*)\b/, $self->request->header('Accept-Encoding')) && - ($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $response; - $response = Compress::Zlib::compress($response) if $compressed; - - $self->response(HTTP::Response->new( - $code => undef, - HTTP::Headers->new( - 'SOAPServer' => $self->product_tokens, - $compressed ? ('Content-Encoding' => $COMPRESS) : (), - 'Content-Type' => join('; ', 'text/xml', - !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? 'charset=' . lc($encoding) : ()), - 'Content-Length' => SOAP::Utils::bytelength $response), - $response, - )); -} - -sub product_tokens { join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION } - -# ====================================================================== - -package SOAP::Transport::HTTP::CGI; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Transport::HTTP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub handle { - my $self = shift->new; - - my $content; binmode(STDIN); read(STDIN,$content,$ENV{'CONTENT_LENGTH'} || 0); - $self->request(HTTP::Request->new( - $ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'}, - HTTP::Headers->new(map {(/^HTTP_(.+)/i ? $1 : $_) => $ENV{$_}} keys %ENV), - $content, - )); - $self->SUPER::handle; - - # imitate nph- cgi for IIS (pointed by Murray Nesbitt) - my $status = defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/ - ? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' : 'Status:'; - my $code = $self->response->code; - binmode(STDOUT); print STDOUT - "$status $code ", HTTP::Status::status_message($code), - "\015\012", $self->response->headers_as_string, - "\015\012", $self->response->content; -} - -# ====================================================================== - -package SOAP::Transport::HTTP::Daemon; - -use Carp (); -use vars qw($AUTOLOAD @ISA); - @ ISA = qw(SOAP::Transport::HTTP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require HTTP::Daemon; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new; - $self->{_daemon} = HTTP::Daemon->new(@params) or Carp::croak "Can't create daemon: $!"; - $self->myuri(URI->new($self->url)->canonical->as_string); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_daemon}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - my $self = shift->new; - while (my $c = $self->accept) { - while (my $r = $c->get_request) { - $self->request($r); - $self->SUPER::handle; - $c->send_response($self->response) - } - $c->shutdown(2); # replaced ->close, thanks to Sean Meisner - undef $c; - } -} - -# ====================================================================== - -package SOAP::Transport::HTTP::Apache; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Transport::HTTP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require Apache; require Apache::Constants; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub handler { - my $self = shift->new; - my $r = shift || Apache->request; - - $self->request(HTTP::Request->new( - $r->method => $r->uri, - HTTP::Headers->new($r->headers_in), - do { my $buf; $r->read($buf, $r->header_in('Content-length')); $buf; } - )); - $self->SUPER::handle; - - # we will specify status manually for Apache, because - # if we do it as it has to be done, returning SERVER_ERROR, - # Apache will modify our content_type to 'text/html; ....' - # which is not what we want. - # will emulate normal response, but with custom status code - # which could also be 500. - $r->status($self->response->code); - $self->response->headers->scan(sub { $r->header_out(@_) }); - $r->send_http_header(join '; ', $self->response->content_type); - $r->print($self->response->content); - &Apache::Constants::OK; -} - -sub configure { - my $self = shift->new; - my $config = shift->dir_config; - foreach (%$config) { - $config->{$_} =~ /=>/ - ? $self->$_({split /\s*(?:=>|,)\s*/, $config->{$_}}) - : ref $self->$_() ? () # hm, nothing can be done here - : $self->$_(split /\s+|\s*,\s*/, $config->{$_}) - if $self->can($_); - } - $self; -} - -{ sub handle; *handle = \&handler } # just create alias - -# ====================================================================== -# -# Copyright (C) 2001 Single Source oy (marko.asplund @ kronodoc.fi) -# a FastCGI transport class for SOAP::Lite. -# -# $Id: HTTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::HTTP::FCGI; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Transport::HTTP::CGI); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require FCGI; Exporter::require_version('FCGI' => 0.47); # requires thread-safe interface - my $self = shift; - - if (!ref($self)) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - $self->{_fcgirq} = FCGI::Request(\*STDIN, \*STDOUT, \*STDERR); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub handle { - my $self = shift->new; - - my ($r1, $r2); - my $fcgirq = $self->{_fcgirq}; - - while (($r1 = $fcgirq->Accept()) >= 0) { - $r2 = $self->SUPER::handle; - } - - return undef; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::HTTP - Server/Client side HTTP support for SOAP::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'http://localhost/', - # proxy => 'http://localhost/cgi-bin/soap.cgi', # local CGI server - # proxy => 'http://localhost/', # local daemon server - # proxy => 'http://localhost/soap', # local mod_perl server - # proxy => 'https://localhost/soap', # local mod_perl SECURE server - # proxy => 'http://login:password @ localhost/cgi-bin/soap.cgi', # local CGI server with authentication - ; - - print getStateName(1); - -=item CGI server - - use SOAP::Transport::HTTP; - - SOAP::Transport::HTTP::CGI - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=item Daemon server - - use SOAP::Transport::HTTP; - - # change LocalPort to 81 if you want to test it with soapmark.pl - - my $daemon = SOAP::Transport::HTTP::Daemon - -> new (LocalAddr => 'localhost', LocalPort => 80) - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to SOAP server at ", $daemon->url, "\n"; - $daemon->handle; - -=item Apache mod_perl server - -See F and L section for more information. - -=item mod_soap server (.htaccess, directory-based access) - - SetHandler perl-script - PerlHandler Apache::SOAP - PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" - PerlSetVar options "compress_threshold => 10000" - -See L for more information. - -=back - -=head1 DESCRIPTION - -This class encapsulates all HTTP related logic for a SOAP server, -independent of what web server it's attached to. -If you want to use this class you should follow simple guideline -mentioned above. - -Following methods are available: - -=over 4 - -=item on_action() - -on_action method lets you specify SOAPAction understanding. It accepts -reference to subroutine that takes three parameters: - - SOAPAction, method_uri and method_name. - -C is taken from HTTP header and method_uri and method_name are -extracted from request's body. Default behavior is match C if -present and ignore it otherwise. You can specify you own, for example -die if C doesn't match with following code: - - $server->on_action(sub { - (my $action = shift) =~ s/^("?)(.+)\1$/$2/; - die "SOAPAction shall match 'uri#method'\n" if $action ne join '#', @_; - }); - -=item dispatch_to() - -dispatch_to lets you specify where you want to dispatch your services -to. More precisely, you can specify C, C, C or -combination C. Example: - - dispatch_to( - 'PATH/', # dynamic: load anything from there, any module, any method - 'MODULE', # static: any method from this module - 'MODULE::method', # static: specified method from this module - 'method', # static: specified method from main:: - ); - -If you specify C name of module/classes will be taken from uri as -path component and converted to Perl module name with substitution -'::' for '/'. Example: - - urn:My/Examples => My::Examples - urn://localhost/My/Examples => My::Examples - http://localhost/My/Examples => My::Examples - -For consistency first '/' in the path will be ignored. - -According to this scheme to deploy new class you should put this -class in one of the specified directories and enjoy its services. -Easy, eh? - -=item handle() - -handle method will handle your request. You should provide parameters -with request() method, call handle() and get it back with response() . - -=item request() - -request method gives you access to HTTP::Request object which you -can provide for Server component to handle request. - -=item response() - -response method gives you access to HTTP::Response object which -you can access to get results from Server component after request was -handled. - -=back - -=head2 PROXY SETTINGS - -You can use any proxy setting you use with LWP::UserAgent modules: - - SOAP::Lite->proxy('http://endpoint.server/', - proxy => ['http' => 'http://my.proxy.server']); - -or - - $soap->transport->proxy('http' => 'http://my.proxy.server'); - -should specify proxy server for you. And if you use C -and C for proxy authorization SOAP::Lite should know -how to handle it properly. - -=head2 COOKIE-BASED AUTHENTICATION - - use HTTP::Cookies; - - my $cookies = HTTP::Cookies->new(ignore_discard => 1); - # you may also add 'file' if you want to keep them between sessions - - my $soap = SOAP::Lite->proxy('http://localhost/'); - $soap->transport->cookie_jar($cookies); - -Cookies will be taken from response and provided for request. You may -always add another cookie (or extract what you need after response) -with HTTP::Cookies interface. - -You may also do it in one line: - - $soap->proxy('http://localhost/', - cookie_jar => HTTP::Cookies->new(ignore_discard => 1)); - -=head2 SSL CERTIFICATE AUTHENTICATION - -To get certificate authentication working you need to specify three -environment variables: C, C, and -(optionally) C: - - $ENV{HTTPS_CERT_FILE} = 'client-cert.pem'; - $ENV{HTTPS_KEY_FILE} = 'client-key.pem'; - -Crypt::SSLeay (which is used for https support) will take care about -everything else. Other options (like CA peer verification) can be specified -in a similar way. See Crypt::SSLeay documentation for more details. - -Those who would like to use encrypted keys may check -http://groups.yahoo.com/group/soaplite/message/729 for details. - -=head2 COMPRESSION - -SOAP::Lite provides you with the option for enabling compression on the -wire (for HTTP transport only). Both server and client should support -this capability, but this should be absolutely transparent to your -application. The Server will respond with an encoded message only if -the client can accept it (indicated by client sending an Accept-Encoding -header with 'deflate' or '*' values) and client has fallback logic, -so if server doesn't understand specified encoding -(Content-Encoding: deflate) and returns proper error code -(415 NOT ACCEPTABLE) client will repeat the same request without encoding -and will store this server in a per-session cache, so all other requests -will go there without encoding. - -Having options on client and server side that let you specify threshold -for compression you can safely enable this feature on both client and -server side. - -=over 4 - -=item Client - - print SOAP::Lite - -> uri('http://localhost/My/Parameters') - -> proxy('http://localhost/', options => {compress_threshold => 10000}) - -> echo(1 x 10000) - -> result - ; - -=item Server - - my $server = SOAP::Transport::HTTP::CGI - -> dispatch_to('My::Parameters') - -> options({compress_threshold => 10000}) - -> handle; - -=back - -Compression will be enabled on the client side -B the threshold is specified -B the size of current message is bigger than the threshold -B the module Compress::Zlib is available. - -The Client will send the header 'Accept-Encoding' with value 'deflate' -B the threshold is specified -B the module Compress::Zlib is available. - -Server will accept the compressed message if the module Compress::Zlib -is available, and will respond with the compressed message -B the threshold is specified -B the size of the current message is bigger than the threshold -B the module Compress::Zlib is available -B the header 'Accept-Encoding' is presented in the request. - -=head1 EXAMPLES - -Consider following examples of SOAP servers: - -=over 4 - -=item CGI: - - use SOAP::Transport::HTTP; - - SOAP::Transport::HTTP::CGI - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=item daemon: - - use SOAP::Transport::HTTP; - - my $daemon = SOAP::Transport::HTTP::Daemon - -> new (LocalAddr => 'localhost', LocalPort => 80) - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to SOAP server at ", $daemon->url, "\n"; - $daemon->handle; - -=item mod_perl: - -httpd.conf: - - - SetHandler perl-script - PerlHandler SOAP::Apache - - -Apache.pm: - - package SOAP::Apache; - - use SOAP::Transport::HTTP; - - my $server = SOAP::Transport::HTTP::Apache - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method'); - - sub handler { $server->handler(@_) } - - 1; - -=item Apache::Registry: - -httpd.conf: - - Alias /mod_perl/ "/Apache/mod_perl/" - - SetHandler perl-script - PerlHandler Apache::Registry - PerlSendHeader On - Options +ExecCGI - - -soap.mod_cgi (put it in /Apache/mod_perl/ directory mentioned above) - - use SOAP::Transport::HTTP; - - SOAP::Transport::HTTP::CGI - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=back - -WARNING: dynamic deployment with Apache::Registry will fail, because -module will be loaded dynamically only for the first time. After that -it is already in the memory, that will bypass dynamic deployment and -produces error about denied access. Specify both PATH/ and MODULE name -in dispatch_to() and module will be loaded dynamically and then will work -as under static deployment. See examples/server/soap.mod_cgi for example. - -=head1 TROUBLESHOOTING - -=over 4 - -=item Dynamic libraries are not found - -If you see in webserver's log file something like this: - -Can't load '/usr/local/lib/perl5/site_perl/.../XML/Parser/Expat/Expat.so' -for module XML::Parser::Expat: dynamic linker: /usr/local/bin/perl: - libexpat.so.0 is NEEDED, but object does not exist at -/usr/local/lib/perl5/.../DynaLoader.pm line 200. - -and you are using Apache web server, try to put into your httpd.conf - - - PassEnv LD_LIBRARY_PATH - - -=item Apache is crashing with segfaults (it may looks like "500 unexpected EOF before status line seen" on client side) - -If using SOAP::Lite (or XML::Parser::Expat) in combination with mod_perl -causes random segmentation faults in httpd processes try to configure -Apache with: - - RULE_EXPAT=no - --- OR (for Apache 1.3.20 and later) -- - - ./configure --disable-rule=EXPAT - -See http://archive.covalent.net/modperl/2000/04/0185.xml for more -details and lot of thanks to Robert Barta for -explaining this weird behavior. - -If it doesn't help, you may also try -Uusemymalloc -(or something like that) to get perl to use the system's own malloc. -Thanks to Tim Bunce . - -=item CGI scripts are not running under Microsoft Internet Information Server (IIS) - -CGI scripts may not work under IIS unless scripts are .pl, not .cgi. - -=back - -=head1 DEPENDENCIES - - Crypt::SSLeay for HTTPS/SSL - SOAP::Lite, URI for SOAP::Transport::HTTP::Server - LWP::UserAgent, URI for SOAP::Transport::HTTP::Client - HTTP::Daemon for SOAP::Transport::HTTP::Daemon - Apache, Apache::Constants for SOAP::Transport::HTTP::Apache - -=head1 SEE ALSO - - See ::CGI, ::Daemon and ::Apache for implementation details. - See examples/server/soap.cgi as SOAP::Transport::HTTP::CGI example. - See examples/server/soap.daemon as SOAP::Transport::HTTP::Daemon example. - See examples/My/Apache.pm as SOAP::Transport::HTTP::Apache example. - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm Tue Oct 25 04:20:51 2005 @@ -1,129 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: IO.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::IO; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use IO::File; -use SOAP::Lite; - -# ====================================================================== - -package SOAP::Transport::IO::Server; - -use strict; -use Carp (); -use vars qw(@ISA); - @ ISA = qw(SOAP::Server); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - my %modes = (in => '<', out => '>'); - for my $method (keys %modes) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - return $self->{$field} unless @_; - - my $file = shift; - if (defined $file && !ref $file && !defined fileno($file)) { - my $name = $file; - open($file = new IO::File, $modes{$method} . $name) or Carp::croak "$name: $!"; - } - $self->{$field} = $file; - return $self; - } - } -} - -sub handle { - my $self = shift->new; - - $self->in(*STDIN)->out(*STDOUT) unless defined $self->in; - my $in = $self->in; - my $out = $self->out; - - my $result = $self->SUPER::handle(join '', <$in>); - no strict 'refs'; print {$out} $result if defined $out; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::IO - Server side IO support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Transport::IO; - - SOAP::Transport::IO::Server - - # you may specify as parameters for new(): - # -> new( in => 'in_file_name' [, out => 'out_file_name'] ) - # -> new( in => IN_HANDLE [, out => OUT_HANDLE] ) - # -> new( in => *IN_HANDLE [, out => *OUT_HANDLE] ) - # -> new( in => \*IN_HANDLE [, out => \*OUT_HANDLE] ) - - # -- OR -- - # any combinations - # -> new( in => *STDIN, out => 'out_file_name' ) - # -> new( in => 'in_file_name', => \*OUT_HANDLE ) - - # -- OR -- - # use in() and/or out() methods - # -> in( *STDIN ) -> out( *STDOUT ) - - # -- OR -- - # use default (when nothing specified): - # in => *STDIN, out => *STDOUT - - # don't forget, if you want to accept parameters from command line - # \*HANDLER will be understood literally, so this syntax won't work - # and server will complain - - -> new(@ARGV) - - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm Tue Oct 25 04:20:51 2005 @@ -1,294 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: JABBER.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::JABBER; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use Net::Jabber 1.0021 qw(Client); -use URI::Escape; -use URI; -use SOAP::Lite; - -my $NAMESPACE = "http://namespaces.soaplite.com/transport/jabber"; - -{ local $^W; - # fix problem with printData in 1.0021 - *Net::Jabber::printData = sub {'nothing'} if Net::Jabber->VERSION == 1.0021; - - # fix problem with Unicode encoding in EscapeXML. Jabber ALWAYS convert latin to utf8 - *Net::Jabber::EscapeXML = *Net::Jabber::EscapeXML = # that's Jabber 1.0021 - *XML::Stream::EscapeXML = *XML::Stream::EscapeXML = # that's Jabber 1.0022 - \&SOAP::Utils::encode_data; - - # There is also an error in XML::Stream::UnescapeXML 1.12, but - # we can't do anything there, except hack it also :( -} - -# ====================================================================== - -package URI::jabber; # ok, lets do 'jabber://' scheme -require URI::_server; require URI::_userpass; - @ URI::jabber::ISA=qw(URI::_server URI::_userpass); - - # jabber://soaplite_client:soapliteclient @ jabber.org:5222/soaplite_server @ jabber.org/Home - # ^^^^^^ ^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^ ^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ - -# ====================================================================== - -package SOAP::Transport::JABBER::Query; - -sub new { - my $proto = shift; - bless {} => ref($proto) || $proto; -} - -sub SetPayload { - shift; Net::Jabber::SetXMLData("single",shift->{QUERY},"payload",shift,{}); -} - -sub GetPayload { - shift; Net::Jabber::GetXMLData("value",shift->{QUERY},"payload",""); -} - -# ====================================================================== - -package SOAP::Transport::JABBER::Client; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Client Net::Jabber::Client); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@params); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub endpoint { - my $self = shift; - - return $self->SUPER::endpoint unless @_; - - my $endpoint = shift; - - # nothing to do if new endpoint is the same as current one - return $self if $self->SUPER::endpoint && $self->SUPER::endpoint eq $endpoint; - - my $uri = URI->new($endpoint); - my($undef, $to, $resource) = split m!/!, $uri->path, 3; - $self->Connect( - hostname => $uri->host, - port => $uri->port, - ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!"; - - my @result = $self->AuthSend( - username => $uri->user, - password => $uri->password, - resource => 'soapliteClient', - ); - $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result"; - - $self->AddDelegate( - namespace => $NAMESPACE, - parent => 'Net::Jabber::Query', - parenttype => 'query', - delegate => 'SOAP::Transport::JABBER::Query', - ); - - # Get roster and announce presence - $self->RosterGet(); - $self->PresenceSend(); - - $self->SUPER::endpoint($endpoint); -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $encoding) = - @parameters{qw(envelope endpoint encoding)}; - - $self->endpoint($endpoint ||= $self->endpoint); - - my($undef, $to, $resource) = split m!/!, URI->new($endpoint)->path, 3; - - # Create a Jabber info/query message - my $iq = new Net::Jabber::IQ(); - $iq->SetIQ( - type => 'set', - to => join '/', $to => $resource || 'soapliteServer', - ); - my $query = $iq->NewQuery($NAMESPACE); - $query->SetPayload($envelope); - - SOAP::Trace::debug($envelope); - - my $iq_rcvd = $self->SendAndReceiveWithID($iq); - my($query_rcvd) = $iq_rcvd->GetQuery($NAMESPACE) if $iq_rcvd; # expect only one - my $msg = $query_rcvd->GetPayload() if $query_rcvd; - - SOAP::Trace::debug($msg); - - my $code = $self->GetErrorCode(); - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return $msg; -} - -# ====================================================================== - -package SOAP::Transport::JABBER::Server; - -use Carp (); -use vars qw(@ISA $AUTOLOAD); - @ ISA = qw(SOAP::Server); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my $uri = URI->new(shift); - $self = $class->SUPER::new(@_); - - $self->{_jabberserver} = Net::Jabber::Client->new; - $self->{_jabberserver}->Connect( - hostname => $uri->host, - port => $uri->port, - ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!"; - - my($undef, $resource) = split m!/!, $uri->path, 2; - my @result = $self->AuthSend( - username => $uri->user, - password => $uri->password, - resource => $resource || 'soapliteServer', - ); - $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result"; - - $self->{_jabberserver}->SetCallBacks( - iq => sub { - shift; - my $iq = new Net::Jabber::IQ(@_); - - my($query) = $iq->GetQuery($NAMESPACE); # expect only one - my $request = $query->GetPayload(); - - SOAP::Trace::debug($request); - - # Set up response - my $reply = $iq->Reply; - my $x = $reply->NewQuery($NAMESPACE); - - my $response = $self->SUPER::handle($request); - $x->SetPayload($response); - - # Send response - $self->{_jabberserver}->Send($reply); - } - ); - - $self->AddDelegate( - namespace => $NAMESPACE, - parent => 'Net::Jabber::Query', - parenttype => 'query', - delegate => 'SOAP::Transport::JABBER::Query', - ); - - $self->RosterGet(); - $self->PresenceSend(); - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_jabberserver}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - shift->Process(); -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::JABBER - Server/Client side JABBER support for SOAP::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'jabber://username:password @ jabber.org:5222/soaplite_server @ jabber.org/', - # proto username passwd server port destination resource (optional) - ; - - print getStateName(1); - -=item Server - - use SOAP::Transport::JABBER; - - my $server = SOAP::Transport::JABBER::Server - -> new('jabber://username:password @ jabber.org:5222') - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - - print "Contact to SOAP server\n"; - do { $server->handle } while sleep 10; - -=back - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm Tue Oct 25 04:20:51 2005 @@ -1,78 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: LOCAL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::LOCAL; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -# ====================================================================== - -package SOAP::Transport::LOCAL::Client; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Client SOAP::Server); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@params); - $self->is_success(1); # it's difficult to fail in this module - $self->dispatch_to(@INC); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - SOAP::Trace::debug($envelope); - my $response = $self->SUPER::handle($envelope); - SOAP::Trace::debug($response); - - $response; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::LOCAL - Client side no-transport support for SOAP::Lite - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm Tue Oct 25 04:20:51 2005 @@ -1,122 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: MAILTO.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::MAILTO; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use MIME::Lite; -use URI; - -# ====================================================================== - -package SOAP::Transport::MAILTO::Client; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Client); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - $endpoint ||= $self->endpoint; - my $uri = URI->new($endpoint); - %parameters = (%$self, map {URI::Escape::uri_unescape($_)} map {split/=/,$_,2} split /[&;]/, $uri->query || ''); - - my $msg = MIME::Lite->new( - To => $uri->to, - Type => 'text/xml', - Encoding => $parameters{Encoding} || 'base64', - Data => $envelope, - $parameters{From} ? (From => $parameters{From}) : (), - $parameters{'Reply-To'} ? ('Reply-To' => $parameters{'Reply-To'}) : (), - $parameters{Subject} ? (Subject => $parameters{Subject}) : (), - ); - $msg->replace('X-Mailer' => join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::MAILTO->VERSION); - $msg->add(SOAPAction => $action); - - SOAP::Trace::transport($msg); - SOAP::Trace::debug($msg->as_string); - - MIME::Lite->send(map {exists $parameters{$_} ? ($_ => $parameters{$_}) : ()} 'smtp', 'sendmail'); - eval { local $SIG{__DIE__}; $MIME::Lite::AUTO_CC = 0; $msg->send }; - (my $code = $@) =~ s/ at .*\n//; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return; -} - -# ====================================================================== - -1; - -=head1 NAME - -SOAP::Transport::MAILTO - Client side SMTP/sendmail support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Lite; - - SOAP::Lite - -> uri('http://soaplite.com/My/Examples') - -> proxy('mailto:destination.email @ address', smtp => 'smtp.server', From => 'your.email', Subject => 'SOAP message') - - # or - # -> proxy('mailto:destination.email @ address?From=your.email&Subject=SOAP%20message', smtp => 'smtp.server') - - # or if you want to send with sendmail - # -> proxy('mailto:destination.email @ address?From=your.email&Subject=SOAP%20message') - - # or if your sendmail is in undiscoverable place - # -> proxy('mailto:destination.email @ address?From=your.email&Subject=SOAP%20message', sendmail => 'command to run your sendmail') - - -> getStateName(12) - ; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm Tue Oct 25 04:20:51 2005 @@ -1,286 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: MQ.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::MQ; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use MQClient::MQSeries; -use MQSeries::QueueManager; -use MQSeries::Queue; -use MQSeries::Message; - -use URI; -use URI::Escape; -use SOAP::Lite; - -# ====================================================================== - -package URI::mq; # ok, lets do 'mq://' scheme -require URI::_server; require URI::_userpass; - @ URI::mq::ISA=qw(URI::_server URI::_userpass); - - # mq://user @ host:port?Channel=A;QueueManager=B;RequestQueue=C;ReplyQueue=D - # ^^ ^^^^ ^^^^ ^^^^ ^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^^^ - -# ====================================================================== - -package SOAP::Transport::MQ::Client; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Client); - -use MQSeries qw(:constants); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - for my $method (qw(requestqueue replyqueue)) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; - } - } -} - -sub endpoint { - my $self = shift; - - return $self->SUPER::endpoint unless @_; - - my $endpoint = shift; - - # nothing to do if new endpoint is the same as the current one - return $self if $self->SUPER::endpoint eq $endpoint; - - my $uri = URI->new($endpoint); - my %parameters = (%$self, map {URI::Escape::uri_unescape($_)} map {split/=/,$_,2} split /[&;]/, $uri->query || ''); - - $ENV{MQSERVER} = sprintf "%s/TCP/%s(%s)", $parameters{Channel}, $uri->host, $uri->port - if $uri->host; - - my $qmgr = MQSeries::QueueManager->new(QueueManager => $parameters{QueueManager}) || - die "Unable to connect to queue manager $parameters{QueueManager}\n"; - - $self->requestqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{RequestQueue}, - Mode => 'output', - ) || die "Unable to open $parameters{RequestQueue}\n"); - - $self->replyqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{ReplyQueue}, - Mode => 'input', - ) || die "Unable to open $parameters{ReplyQueue}\n"); - - $self->SUPER::endpoint($endpoint); -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint) = - @parameters{qw(envelope endpoint)}; - - $self->endpoint($endpoint ||= $self->endpoint); - - %parameters = (%$self, %parameters); - my $expiry = $parameters{Expiry} || 60000; - - SOAP::Trace::debug($envelope); - - my $request = MQSeries::Message->new ( - MsgDesc => {Format => MQFMT_STRING, Expiry => $expiry}, - Data => $envelope, - ); - - $self->requestqueue->Put(Message => $request) || - die "Unable to put message to queue\n"; - - my $reply = MQSeries::Message->new ( - MsgDesc => {CorrelId => $request->MsgDesc('MsgId')}, - ); - - my $result = $self->replyqueue->Get ( - Message => $reply, - Wait => $expiry, - ); - - my $msg = $reply->Data if $result > 0; - - SOAP::Trace::debug($msg); - - my $code = $result > 0 ? undef : - $result < 0 ? 'Timeout' : 'Error occured while waiting for response'; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return $msg; -} - -# ====================================================================== - -package SOAP::Transport::MQ::Server; - -use Carp (); -use vars qw(@ISA $AUTOLOAD); - @ ISA = qw(SOAP::Server); - -use MQSeries qw(:constants); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my $uri = URI->new(shift); - $self = $class->SUPER::new(@_); - - my %parameters = (%$self, map {URI::Escape::uri_unescape($_)} map {split/=/,$_,2} split /[&;]/, $uri->query || ''); - - $ENV{MQSERVER} = sprintf "%s/TCP/%s(%s)", $parameters{Channel}, $uri->host, $uri->port - if $uri->host; - - my $qmgr = MQSeries::QueueManager->new(QueueManager => $parameters{QueueManager}) || - Carp::croak "Unable to connect to queue manager $parameters{QueueManager}"; - - $self->requestqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{RequestQueue}, - Mode => 'input', - ) || Carp::croak "Unable to open $parameters{RequestQueue}"); - - $self->replyqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{ReplyQueue}, - Mode => 'output', - ) || Carp::croak "Unable to open $parameters{ReplyQueue}"); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - for my $method (qw(requestqueue replyqueue)) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; - } - } -} - -sub handle { - my $self = shift->new; - - my $msg = 0; - while (1) { - my $request = MQSeries::Message->new; - - # nonblock waiting - $self->requestqueue->Get ( - Message => $request, - ) || die "Error occured while waiting for requests\n"; - - return $msg if $self->requestqueue->Reason == MQRC_NO_MSG_AVAILABLE; - - my $reply = MQSeries::Message->new ( - MsgDesc => { - CorrelId => $request->MsgDesc('MsgId'), - Expiry => $request->MsgDesc('Expiry'), - }, - Data => $self->SUPER::handle($request->Data), - ); - - $self->replyqueue->Put ( - Message => $reply, - ) || die "Unable to put reply message\n"; - - $msg++; - } -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::MQ - Server/Client side MQ support for SOAP::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'mq://server:port?Channel=CHAN1;QueueManager=QM_SOAP;RequestQueue=SOAPREQ1;ReplyQueue=SOAPRESP1', - ; - - print getStateName(1); - -=item Server - - use SOAP::Transport::MQ; - - my $server = SOAP::Transport::MQ::Server - ->new('mq://server:port?Channel=CHAN1;QueueManager=QM_SOAP;RequestQueue=SOAPREQ1;ReplyQueue=SOAPRESP1') - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - - print "Contact to SOAP server\n"; - do { $server->handle } while sleep 1; - -=back - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm Tue Oct 25 04:20:51 2005 @@ -1,120 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: POP3.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::POP3; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use Net::POP3; -use URI; -use SOAP::Lite; - -# ====================================================================== - -package SOAP::Transport::POP3::Server; - -use Carp (); -use vars qw(@ISA $AUTOLOAD); - @ ISA = qw(SOAP::Server); - -sub DESTROY { my $self = shift; $self->quit if $self->{_pop3server} } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my $address = shift; - Carp::carp "URLs without 'pop://' scheme are deprecated. Still continue" - if $address =~ s!^(pop://)?!pop://!i && !$1; - my $server = URI->new($address); - $self = $class->SUPER::new(@_); - $self->{_pop3server} = Net::POP3->new($server->host_port) or Carp::croak "Can't connect to '@{[$server->host_port]}': $!"; - my $method = !$server->auth || $server->auth eq '*' ? 'login' : - $server->auth eq '+APOP' ? 'apop' : - Carp::croak "Unsupported authentication scheme '@{[$server->auth]}'"; - $self->{_pop3server}->$method(split /:/, $server->user) or Carp::croak "Can't authenticate to '@{[$server->host_port]}' with '$method' method" - if defined $server->user; - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_pop3server}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - my $self = shift->new; - my $messages = $self->list or return; - foreach my $msgid (keys %$messages) { - $self->SUPER::handle(join '', @{$self->get($msgid)}); - } continue { - $self->delete($msgid); - } - return scalar keys %$messages; -} - -sub make_fault { return } - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::POP3 - Server side POP3 support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Transport::POP3; - - my $server = SOAP::Transport::POP3::Server - -> new('pop://pop.mail.server') - # if you want to have all in one place - # -> new('pop://user:password @ pop.mail.server') - # or, if you have server that supports MD5 protected passwords - # -> new('pop://user:password;AUTH=+APOP @ pop.mail.server') - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - # you don't need to use next line if you specified your password in new() - $server->login('user' => 'password') or die "Can't authenticate to POP3 server\n"; - - # handle will return number of processed mails - # you can organize loop if you want - do { $server->handle } while sleep 10; - - # you may also call $server->quit explicitly to purge deleted messages - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm Tue Oct 25 04:20:51 2005 @@ -1,247 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: TCP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::TCP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use URI; -use IO::Socket; -use IO::Select; -use IO::SessionData; -use SOAP::Lite; - -# ====================================================================== - -package URI::tcp; # ok, lets do 'tcp://' scheme -require URI::_server; - @ URI::tcp::ISA=qw(URI::_server); - -# ====================================================================== - -package SOAP::Transport::TCP::Client; - -use vars qw(@ISA); - @ ISA = qw(SOAP::Client); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - # use SSL if there is any parameter with SSL_* in the name - $self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self; - SOAP::Trace::objects('()'); - } - return $self; -} - -sub SSL { - my $self = shift->new; - @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL}; -} - -sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' } - -sub syswrite { - my($self, $sock, $data) = @_; - - my $timeout = $sock->timeout; - - my $select = IO::Select->new($sock); - - my $len = length $data; - while (length $data > 0) { - return unless $select->can_write($timeout); - local $SIG{PIPE} = 'IGNORE'; - my $wc = syswrite($sock, $data); - if (defined $wc) { - substr($data, 0, $wc) = ''; - } elsif (!IO::SessionData::WOULDBLOCK($!)) { - return; - } - } - return $len; -} - -sub sysread { - my($self, $sock) = @_; - - my $timeout = $sock->timeout; - my $select = IO::Select->new($sock); - - my $result = ''; - my $data; - while (1) { - return unless $select->can_read($timeout); - my $rc = sysread($sock, $data, 4096); - if ($rc) { - $result .= $data; - } elsif (defined $rc) { - return $result; - } elsif (!IO::SessionData::WOULDBLOCK($!)) { - return; - } - } -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - $endpoint ||= $self->endpoint; - warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n" - if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1; - my $uri = URI->new($endpoint); - - local($^W, $@, $!); - my $sock = $self->io_socket_class->new ( - PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self - ); - - SOAP::Trace::debug($envelope); - - my $result; - if ($sock) { - $sock->blocking(0); - $self->syswrite($sock, $envelope) and - $sock->shutdown(1) and # stop writing - $result = $self->sysread($sock); - } - - SOAP::Trace::debug($result); - - my $code = $@ || $!; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return $result; -} - -# ====================================================================== - -package SOAP::Transport::TCP::Server; - -use IO::SessionSet; - -use Carp (); -use vars qw($AUTOLOAD @ISA); - @ ISA = qw(SOAP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@methods); - - # use SSL if there is any parameter with SSL_* in the name - $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params; - - my $socket = $self->io_socket_class; - eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new'); - $self->{_socket} = $socket->new(Proto => 'tcp', @params) - or Carp::croak "Can't open socket: $!"; - - SOAP::Trace::objects('()'); - } - return $self; -} - -sub SSL { - my $self = shift->new; - @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL}; -} - -sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' } - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_socket}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - my $self = shift->new; - my $sock = $self->{_socket}; - my $session_set = IO::SessionSet->new($sock); - my %data; - while (1) { - my @ready = $session_set->wait($sock->timeout); - for my $session (@ready) { - my $data; - if (my $rc = $session->read($data, 4096)) { - $data{$session} .= $data if $rc > 0; - } else { - $session->write($self->SUPER::handle(delete $data{$session})); - $session->close; - } - } - } -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::TCP - Server/Client side TCP support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Transport::TCP; - - my $daemon = SOAP::Transport::TCP::Server - -> new (LocalAddr => 'localhost', LocalPort => 82, Listen => 5, Reuse => 1) - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to SOAP server at ", join(':', $daemon->sockhost, $daemon->sockport), "\n"; - $daemon->handle; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:51 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:51 +0900 Subject: [Affelio-cvs 666] CVS update: affelio_farm/admin/skelton/affelio/extlib/Math/BigInt Message-ID: <20051024192051.8D4672AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Calc.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Calc.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Calc.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Calc.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Calc.pm Tue Oct 25 04:20:51 2005 @@ -1,2102 +0,0 @@ -package Math::BigInt::Calc; - -use 5.005; -use strict; -# use warnings; # dont use warnings for older Perls - -use vars qw/$VERSION/; - -$VERSION = '0.47'; - -# Package to store unsigned big integers in decimal and do math with them - -# Internally the numbers are stored in an array with at least 1 element, no -# leading zero parts (except the first) and in base 1eX where X is determined -# automatically at loading time to be the maximum possible value - -# todo: -# - fully remove funky $# stuff in div() (maybe - that code scares me...) - -# USE_MUL: due to problems on certain os (os390, posix-bc) "* 1e-5" is used -# instead of "/ 1e5" at some places, (marked with USE_MUL). Other platforms -# BS2000, some Crays need USE_DIV instead. -# The BEGIN block is used to determine which of the two variants gives the -# correct result. - -# Beware of things like: -# $i = $i * $y + $car; $car = int($i / $MBASE); $i = $i % $MBASE; -# This works on x86, but fails on ARM (SA1100, iPAQ) due to whoknows what -# reasons. So, use this instead (slower, but correct): -# $i = $i * $y + $car; $car = int($i / $MBASE); $i -= $MBASE * $car; - -############################################################################## -# global constants, flags and accessory - -# announce that we are compatible with MBI v1.70 and up -sub api_version () { 1; } - -# constants for easier life -my ($BASE,$BASE_LEN,$MBASE,$RBASE,$MAX_VAL,$BASE_LEN_SMALL); -my ($AND_BITS,$XOR_BITS,$OR_BITS); -my ($AND_MASK,$XOR_MASK,$OR_MASK); - -sub _base_len - { - # set/get the BASE_LEN and assorted other, connected values - # used only be the testsuite, set is used only by the BEGIN block below - shift; - - my $b = shift; - if (defined $b) - { - # find whether we can use mul or div or none in mul()/div() - # (in last case reduce BASE_LEN_SMALL) - $BASE_LEN_SMALL = $b+1; - my $caught = 0; - while (--$BASE_LEN_SMALL > 5) - { - $MBASE = int("1e".$BASE_LEN_SMALL); - $RBASE = abs('1e-'.$BASE_LEN_SMALL); # see USE_MUL - $caught = 0; - $caught += 1 if (int($MBASE * $RBASE) != 1); # should be 1 - $caught += 2 if (int($MBASE / $MBASE) != 1); # should be 1 - last if $caught != 3; - } - # BASE_LEN is used for anything else than mul()/div() - $BASE_LEN = $BASE_LEN_SMALL; - $BASE_LEN = shift if (defined $_[0]); # one more arg? - $BASE = int("1e".$BASE_LEN); - - $MBASE = int("1e".$BASE_LEN_SMALL); - $RBASE = abs('1e-'.$BASE_LEN_SMALL); # see USE_MUL - $MAX_VAL = $MBASE-1; - - # avoid redefinitions - - undef &_mul; - undef &_div; - - # $caught & 1 != 0 => cannot use MUL - # $caught & 2 != 0 => cannot use DIV - # The parens around ($caught & 1) were important, indeed, if we would use - # & here. - if ($caught == 2) # 2 - { - # must USE_MUL since we cannot use DIV - *{_mul} = \&_mul_use_mul; - *{_div} = \&_div_use_mul; - } - else # 0 or 1 - { - # can USE_DIV instead - *{_mul} = \&_mul_use_div; - *{_div} = \&_div_use_div; - } - } - return $BASE_LEN unless wantarray; - return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL, $BASE); - } - -sub _new - { - # (ref to string) return ref to num_array - # Convert a number from string format (without sign) to internal base - # 1ex format. Assumes normalized value as input. - my $il = length($_[1])-1; - - # < BASE_LEN due len-1 above - return [ int($_[1]) ] if $il < $BASE_LEN; # shortcut for short numbers - - # this leaves '00000' instead of int 0 and will be corrected after any op - [ reverse(unpack("a" . ($il % $BASE_LEN+1) - . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ]; - } - -BEGIN - { - # from Daniel Pfeiffer: determine largest group of digits that is precisely - # multipliable with itself plus carry - # Test now changed to expect the proper pattern, not a result off by 1 or 2 - my ($e, $num) = 3; # lowest value we will use is 3+1-1 = 3 - do - { - $num = ('9' x ++$e) + 0; - $num *= $num + 1.0; - } while ("$num" =~ /9{$e}0{$e}/); # must be a certain pattern - $e--; # last test failed, so retract one step - # the limits below brush the problems with the test above under the rug: - # the test should be able to find the proper $e automatically - $e = 5 if $^O =~ /^uts/; # UTS get's some special treatment - $e = 5 if $^O =~ /^unicos/; # unicos is also problematic (6 seems to work - # there, but we play safe) - $e = 5 if $] < 5.006; # cap, for older Perls - $e = 7 if $e > 7; # cap, for VMS, OS/390 and other 64 bit systems - # 8 fails inside random testsuite, so take 7 - - __PACKAGE__->_base_len($e); # set and store - - use integer; - # find out how many bits _and, _or and _xor can take (old default = 16) - # I don't think anybody has yet 128 bit scalars, so let's play safe. - local $^W = 0; # don't warn about 'nonportable number' - $AND_BITS = 15; $XOR_BITS = 15; $OR_BITS = 15; - - # find max bits, we will not go higher than numberofbits that fit into $BASE - # to make _and etc simpler (and faster for smaller, slower for large numbers) - my $max = 16; - while (2 ** $max < $BASE) { $max++; } - { - no integer; - $max = 16 if $] < 5.006; # older Perls might not take >16 too well - } - my ($x,$y,$z); - do { - $AND_BITS++; - $x = oct('0b' . '1' x $AND_BITS); $y = $x & $x; - $z = (2 ** $AND_BITS) - 1; - } while ($AND_BITS < $max && $x == $z && $y == $x); - $AND_BITS --; # retreat one step - do { - $XOR_BITS++; - $x = oct('0b' . '1' x $XOR_BITS); $y = $x ^ 0; - $z = (2 ** $XOR_BITS) - 1; - } while ($XOR_BITS < $max && $x == $z && $y == $x); - $XOR_BITS --; # retreat one step - do { - $OR_BITS++; - $x = oct('0b' . '1' x $OR_BITS); $y = $x | $x; - $z = (2 ** $OR_BITS) - 1; - } while ($OR_BITS < $max && $x == $z && $y == $x); - $OR_BITS --; # retreat one step - - $AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS )); - $XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS )); - $OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS )); - } - -############################################################################### - -sub _zero - { - # create a zero - [ 0 ]; - } - -sub _one - { - # create a one - [ 1 ]; - } - -sub _two - { - # create a two (used internally for shifting) - [ 2 ]; - } - -sub _ten - { - # create a 10 (used internally for shifting) - [ 10 ]; - } - -sub _copy - { - # make a true copy - [ @{$_[1]} ]; - } - -# catch and throw away -sub import { } - -############################################################################## -# convert back to string and number - -sub _str - { - # (ref to BINT) return num_str - # Convert number from internal base 100000 format to string format. - # internal format is always normalized (no leading zeros, "-0" => "+0") - my $ar = $_[1]; - - my $l = scalar @$ar; # number of parts - if ($l < 1) # should not happen - { - require Carp; - Carp::croak("$_[1] has no elements"); - } - - my $ret = ""; - # handle first one different to strip leading zeros from it (there are no - # leading zero parts in internal representation) - $l --; $ret .= int($ar->[$l]); $l--; - # Interestingly, the pre-padd method uses more time - # the old grep variant takes longer (14 vs. 10 sec) - my $z = '0' x ($BASE_LEN-1); - while ($l >= 0) - { - $ret .= substr($z.$ar->[$l],-$BASE_LEN); # fastest way I could think of - $l--; - } - $ret; - } - -sub _num - { - # Make a number (scalar int/float) from a BigInt object - my $x = $_[1]; - - return 0+$x->[0] if scalar @$x == 1; # below $BASE - my $fac = 1; - my $num = 0; - foreach (@$x) - { - $num += $fac*$_; $fac *= $BASE; - } - $num; - } - -############################################################################## -# actual math code - -sub _add - { - # (ref to int_num_array, ref to int_num_array) - # routine to add two base 1eX numbers - # stolen from Knuth Vol 2 Algorithm A pg 231 - # there are separate routines to add and sub as per Knuth pg 233 - # This routine clobbers up array x, but not y. - - my ($c,$x,$y) = @_; - - return $x if (@$y == 1) && $y->[0] == 0; # $x + 0 => $x - if ((@$x == 1) && $x->[0] == 0) # 0 + $y => $y->copy - { - # twice as slow as $x = [ @$y ], but necc. to retain $x as ref :( - @$x = @$y; return $x; - } - - # for each in Y, add Y to X and carry. If after that, something is left in - # X, foreach in X add carry to X and then return X, carry - # Trades one "$j++" for having to shift arrays - my $i; my $car = 0; my $j = 0; - for $i (@$y) - { - $x->[$j] -= $BASE if $car = (($x->[$j] += $i + $car) >= $BASE) ? 1 : 0; - $j++; - } - while ($car != 0) - { - $x->[$j] -= $BASE if $car = (($x->[$j] += $car) >= $BASE) ? 1 : 0; $j++; - } - $x; - } - -sub _inc - { - # (ref to int_num_array, ref to int_num_array) - # Add 1 to $x, modify $x in place - my ($c,$x) = @_; - - for my $i (@$x) - { - return $x if (($i += 1) < $BASE); # early out - $i = 0; # overflow, next - } - push @$x,1 if (($x->[-1] || 0) == 0); # last overflowed, so extend - $x; - } - -sub _dec - { - # (ref to int_num_array, ref to int_num_array) - # Sub 1 from $x, modify $x in place - my ($c,$x) = @_; - - my $MAX = $BASE-1; # since MAX_VAL based on MBASE - for my $i (@$x) - { - last if (($i -= 1) >= 0); # early out - $i = $MAX; # underflow, next - } - pop @$x if $x->[-1] == 0 && @$x > 1; # last underflowed (but leave 0) - $x; - } - -sub _sub - { - # (ref to int_num_array, ref to int_num_array, swap) - # subtract base 1eX numbers -- stolen from Knuth Vol 2 pg 232, $x > $y - # subtract Y from X by modifying x in place - my ($c,$sx,$sy,$s) = @_; - - my $car = 0; my $i; my $j = 0; - if (!$s) - { - for $i (@$sx) - { - last unless defined $sy->[$j] || $car; - $i += $BASE if $car = (($i -= ($sy->[$j] || 0) + $car) < 0); $j++; - } - # might leave leading zeros, so fix that - return __strip_zeros($sx); - } - for $i (@$sx) - { - # we can't do an early out if $x is < than $y, since we - # need to copy the high chunks from $y. Found by Bob Mathews. - #last unless defined $sy->[$j] || $car; - $sy->[$j] += $BASE - if $car = (($sy->[$j] = $i-($sy->[$j]||0) - $car) < 0); - $j++; - } - # might leave leading zeros, so fix that - __strip_zeros($sy); - } - -sub _mul_use_mul - { - # (ref to int_num_array, ref to int_num_array) - # multiply two numbers in internal representation - # modifies first arg, second need not be different from first - my ($c,$xv,$yv) = @_; - - if (@$yv == 1) - { - # shortcut for two very short numbers (improved by Nathan Zook) - # works also if xv and yv are the same reference, and handles also $x == 0 - if (@$xv == 1) - { - if (($xv->[0] *= $yv->[0]) >= $MBASE) - { - $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $MBASE; - }; - return $xv; - } - # $x * 0 => 0 - if ($yv->[0] == 0) - { - @$xv = (0); - return $xv; - } - # multiply a large number a by a single element one, so speed up - my $y = $yv->[0]; my $car = 0; - foreach my $i (@$xv) - { - $i = $i * $y + $car; $car = int($i * $RBASE); $i -= $car * $MBASE; - } - push @$xv, $car if $car != 0; - return $xv; - } - # shortcut for result $x == 0 => result = 0 - return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); - - # since multiplying $x with $x fails, make copy in this case - $yv = [@$xv] if $xv == $yv; # same references? - - my @prod = (); my ($prod,$car,$cty,$xi,$yi); - - for $xi (@$xv) - { - $car = 0; $cty = 0; - - # slow variant -# for $yi (@$yv) -# { -# $prod = $xi * $yi + ($prod[$cty] || 0) + $car; -# $prod[$cty++] = -# $prod - ($car = int($prod * RBASE)) * $MBASE; # see USE_MUL -# } -# $prod[$cty] += $car if $car; # need really to check for 0? -# $xi = shift @prod; - - # faster variant - # looping through this if $xi == 0 is silly - so optimize it away! - $xi = (shift @prod || 0), next if $xi == 0; - for $yi (@$yv) - { - $prod = $xi * $yi + ($prod[$cty] || 0) + $car; -## this is actually a tad slower -## $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here - $prod[$cty++] = - $prod - ($car = int($prod * $RBASE)) * $MBASE; # see USE_MUL - } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy - } - push @$xv, @prod; - __strip_zeros($xv); - $xv; - } - -sub _mul_use_div - { - # (ref to int_num_array, ref to int_num_array) - # multiply two numbers in internal representation - # modifies first arg, second need not be different from first - my ($c,$xv,$yv) = @_; - - if (@$yv == 1) - { - # shortcut for two small numbers, also handles $x == 0 - if (@$xv == 1) - { - # shortcut for two very short numbers (improved by Nathan Zook) - # works also if xv and yv are the same reference, and handles also $x == 0 - if (($xv->[0] *= $yv->[0]) >= $MBASE) - { - $xv->[0] = - $xv->[0] - ($xv->[1] = int($xv->[0] / $MBASE)) * $MBASE; - }; - return $xv; - } - # $x * 0 => 0 - if ($yv->[0] == 0) - { - @$xv = (0); - return $xv; - } - # multiply a large number a by a single element one, so speed up - my $y = $yv->[0]; my $car = 0; - foreach my $i (@$xv) - { - $i = $i * $y + $car; $car = int($i / $MBASE); $i -= $car * $MBASE; - } - push @$xv, $car if $car != 0; - return $xv; - } - # shortcut for result $x == 0 => result = 0 - return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); - - # since multiplying $x with $x fails, make copy in this case - $yv = [@$xv] if $xv == $yv; # same references? - - my @prod = (); my ($prod,$car,$cty,$xi,$yi); - for $xi (@$xv) - { - $car = 0; $cty = 0; - # looping through this if $xi == 0 is silly - so optimize it away! - $xi = (shift @prod || 0), next if $xi == 0; - for $yi (@$yv) - { - $prod = $xi * $yi + ($prod[$cty] || 0) + $car; - $prod[$cty++] = - $prod - ($car = int($prod / $MBASE)) * $MBASE; - } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy - } - push @$xv, @prod; - __strip_zeros($xv); - $xv; - } - -sub _div_use_mul - { - # ref to array, ref to array, modify first array and return remainder if - # in list context - - # see comments in _div_use_div() for more explanations - - my ($c,$x,$yorg) = @_; - - # the general div algorithmn here is about O(N*N) and thus quite slow, so - # we first check for some special cases and use shortcuts to handle them. - - # This works, because we store the numbers in a chunked format where each - # element contains 5..7 digits (depending on system). - - # if both numbers have only one element: - if (@$x == 1 && @$yorg == 1) - { - # shortcut, $yorg and $x are two small numbers - if (wantarray) - { - my $r = [ $x->[0] % $yorg->[0] ]; - $x->[0] = int($x->[0] / $yorg->[0]); - return ($x,$r); - } - else - { - $x->[0] = int($x->[0] / $yorg->[0]); - return $x; - } - } - - # if x has more than one, but y has only one element: - if (@$yorg == 1) - { - my $rem; - $rem = _mod($c,[ @$x ],$yorg) if wantarray; - - # shortcut, $y is < $BASE - my $j = scalar @$x; my $r = 0; - my $y = $yorg->[0]; my $b; - while ($j-- > 0) - { - $b = $r * $MBASE + $x->[$j]; - $x->[$j] = int($b/$y); - $r = $b % $y; - } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero - return ($x,$rem) if wantarray; - return $x; - } - - # now x and y have more than one element - - # check whether y has more elements than x, if yet, the result will be 0 - if (@$yorg > @$x) - { - my $rem; - $rem = [@$x] if wantarray; # make copy - splice (@$x,1); # keep ref to original array - $x->[0] = 0; # set to 0 - return ($x,$rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now - } - # check whether the numbers have the same number of elements, in that case - # the result will fit into one element and can be computed efficiently - if (@$yorg == @$x) - { - my $rem; - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) - { - $rem = [@$x] if wantarray; # make copy - splice (@$x,1); # keep ref to org array - $x->[0] = 0; # set to 0 - return ($x,$rem) if wantarray; # including remainder? - return $x; - } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) - { - # same length, so make full compare - - my $a = 0; my $j = scalar @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) - { - last if ($a = $x->[$j] - $yorg->[$j]); $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) - { - $rem = [ 0 ]; # a = 0 => x == y => rem 0 - $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x - splice(@$x,1); # keep single element - $x->[0] = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x,$rem) if wantarray; - return $x; - } - # $x >= $y, so proceed normally - } - } - - # all other cases: - - my $y = [ @$yorg ]; # always make copy to preserve - - my ($car,$bar,$prd,$dd,$xi,$yi, @ q,$v2,$v1, @ d,$tmp,$q,$u2,$u1,$u0); - - $car = $bar = $prd = 0; - if (($dd = int($MBASE/($y->[-1]+1))) != 1) - { - for $xi (@$x) - { - $xi = $xi * $dd + $car; - $xi -= ($car = int($xi * $RBASE)) * $MBASE; # see USE_MUL - } - push(@$x, $car); $car = 0; - for $yi (@$y) - { - $yi = $yi * $dd + $car; - $yi -= ($car = int($yi * $RBASE)) * $MBASE; # see USE_MUL - } - } - else - { - push(@$x, 0); - } - @q = (); ($v2,$v1) = @$y[-2,-1]; - $v2 = 0 unless $v2; - while ($#$x > $#$y) - { - ($u2,$u1,$u0) = @$x[-3..-1]; - $u2 = 0 unless $u2; - #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" - # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$MBASE+$u1)/$v1)); - --$q while ($v2*$q > ($u0*$MBASE+$u1-$q*$v1)*$MBASE+$u2); - if ($q) - { - ($car, $bar) = (0,0); - for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) - { - $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd * $RBASE)) * $MBASE; # see USE_MUL - $x->[$xi] += $MBASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); - } - if ($x->[-1] < $car + $bar) - { - $car = 0; --$q; - for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) - { - $x->[$xi] -= $MBASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $MBASE)); - } - } - } - pop(@$x); - unshift(@q, $q); - } - if (wantarray) - { - @d = (); - if ($dd != 1) - { - $car = 0; - for $xi (reverse @$x) - { - $prd = $car * $MBASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL - unshift(@d, $tmp); - } - } - else - { - @d = @$x; - } - @$x = @q; - my $d = \@d; - __strip_zeros($x); - __strip_zeros($d); - return ($x,$d); - } - @$x = @q; - __strip_zeros($x); - $x; - } - -sub _div_use_div - { - # ref to array, ref to array, modify first array and return remainder if - # in list context - my ($c,$x,$yorg) = @_; - - # the general div algorithmn here is about O(N*N) and thus quite slow, so - # we first check for some special cases and use shortcuts to handle them. - - # This works, because we store the numbers in a chunked format where each - # element contains 5..7 digits (depending on system). - - # if both numbers have only one element: - if (@$x == 1 && @$yorg == 1) - { - # shortcut, $yorg and $x are two small numbers - if (wantarray) - { - my $r = [ $x->[0] % $yorg->[0] ]; - $x->[0] = int($x->[0] / $yorg->[0]); - return ($x,$r); - } - else - { - $x->[0] = int($x->[0] / $yorg->[0]); - return $x; - } - } - # if x has more than one, but y has only one element: - if (@$yorg == 1) - { - my $rem; - $rem = _mod($c,[ @$x ],$yorg) if wantarray; - - # shortcut, $y is < $BASE - my $j = scalar @$x; my $r = 0; - my $y = $yorg->[0]; my $b; - while ($j-- > 0) - { - $b = $r * $MBASE + $x->[$j]; - $x->[$j] = int($b/$y); - $r = $b % $y; - } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero - return ($x,$rem) if wantarray; - return $x; - } - # now x and y have more than one element - - # check whether y has more elements than x, if yet, the result will be 0 - if (@$yorg > @$x) - { - my $rem; - $rem = [@$x] if wantarray; # make copy - splice (@$x,1); # keep ref to original array - $x->[0] = 0; # set to 0 - return ($x,$rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now - } - # check whether the numbers have the same number of elements, in that case - # the result will fit into one element and can be computed efficiently - if (@$yorg == @$x) - { - my $rem; - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) - { - $rem = [@$x] if wantarray; # make copy - splice (@$x,1); # keep ref to org array - $x->[0] = 0; # set to 0 - return ($x,$rem) if wantarray; # including remainder? - return $x; - } - # now calculate $x / $yorg - - if (length(int($yorg->[-1])) == length(int($x->[-1]))) - { - # same length, so make full compare - - my $a = 0; my $j = scalar @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) - { - last if ($a = $x->[$j] - $yorg->[$j]); $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) - { - $rem = [ 0 ]; # a = 0 => x == y => rem 0 - $rem = [@$x] if $a != 0; # a < 0 => x < y => rem = x - splice(@$x,1); # keep single element - $x->[0] = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x,$rem) if wantarray; # including remainder? - return $x; - } - # $x >= $y, so proceed normally - - } - } - - # all other cases: - - my $y = [ @$yorg ]; # always make copy to preserve - - my ($car,$bar,$prd,$dd,$xi,$yi, @ q,$v2,$v1, @ d,$tmp,$q,$u2,$u1,$u0); - - $car = $bar = $prd = 0; - if (($dd = int($MBASE/($y->[-1]+1))) != 1) - { - for $xi (@$x) - { - $xi = $xi * $dd + $car; - $xi -= ($car = int($xi / $MBASE)) * $MBASE; - } - push(@$x, $car); $car = 0; - for $yi (@$y) - { - $yi = $yi * $dd + $car; - $yi -= ($car = int($yi / $MBASE)) * $MBASE; - } - } - else - { - push(@$x, 0); - } - - # @q will accumulate the final result, $q contains the current computed - # part of the final result - - @q = (); ($v2,$v1) = @$y[-2,-1]; - $v2 = 0 unless $v2; - while ($#$x > $#$y) - { - ($u2,$u1,$u0) = @$x[-3..-1]; - $u2 = 0 unless $u2; - #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" - # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0*$MBASE+$u1)/$v1)); - --$q while ($v2*$q > ($u0*$MBASE+$u1-$q*$v1)*$MBASE+$u2); - if ($q) - { - ($car, $bar) = (0,0); - for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) - { - $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd / $MBASE)) * $MBASE; - $x->[$xi] += $MBASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); - } - if ($x->[-1] < $car + $bar) - { - $car = 0; --$q; - for ($yi = 0, $xi = $#$x-$#$y-1; $yi <= $#$y; ++$yi,++$xi) - { - $x->[$xi] -= $MBASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $MBASE)); - } - } - } - pop(@$x); unshift(@q, $q); - } - if (wantarray) - { - @d = (); - if ($dd != 1) - { - $car = 0; - for $xi (reverse @$x) - { - $prd = $car * $MBASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; - unshift(@d, $tmp); - } - } - else - { - @d = @$x; - } - @$x = @q; - my $d = \@d; - __strip_zeros($x); - __strip_zeros($d); - return ($x,$d); - } - @$x = @q; - __strip_zeros($x); - $x; - } - -############################################################################## -# testing - -sub _acmp - { - # internal absolute post-normalized compare (ignore signs) - # ref to array, ref to array, return <0, 0, >0 - # arrays must have at least one entry; this is not checked for - my ($c,$cx,$cy) = @_; - - # shortcut for short numbers - return (($cx->[0] <=> $cy->[0]) <=> 0) - if scalar @$cx == scalar @$cy && scalar @$cx == 1; - - # fast comp based on number of array elements (aka pseudo-length) - my $lxy = (scalar @$cx - scalar @$cy) - # or length of first element if same number of elements (aka difference 0) - || - # need int() here because sometimes the last element is '00018' vs '18' - (length(int($cx->[-1])) - length(int($cy->[-1]))); - return -1 if $lxy < 0; # already differs, ret - return 1 if $lxy > 0; # ditto - - # manual way (abort if unequal, good for early ne) - my $a; my $j = scalar @$cx; - while (--$j >= 0) - { - last if ($a = $cx->[$j] - $cy->[$j]); - } - $a <=> 0; - } - -sub _len - { - # compute number of digits - - # int() because add/sub sometimes leaves strings (like '00005') instead of - # '5' in this place, thus causing length() to report wrong length - my $cx = $_[1]; - - (@$cx-1)*$BASE_LEN+length(int($cx->[-1])); - } - -sub _digit - { - # return the nth digit, negative values count backward - # zero is rightmost, so _digit(123,0) will give 3 - my ($c,$x,$n) = @_; - - my $len = _len('',$x); - - $n = $len+$n if $n < 0; # -1 last, -2 second-to-last - $n = abs($n); # if negative was too big - $len--; $n = $len if $n > $len; # n to big? - - my $elem = int($n / $BASE_LEN); # which array element - my $digit = $n % $BASE_LEN; # which digit in this element - $elem = '0' x $BASE_LEN . @$x[$elem]; # get element padded with 0's - substr($elem,-$digit-1,1); - } - -sub _zeros - { - # return amount of trailing zeros in decimal - # check each array elem in _m for having 0 at end as long as elem == 0 - # Upon finding a elem != 0, stop - my $x = $_[1]; - - return 0 if scalar @$x == 1 && $x->[0] == 0; - - my $zeros = 0; my $elem; - foreach my $e (@$x) - { - if ($e != 0) - { - $elem = "$e"; # preserve x - $elem =~ s/.*?(0*$)/$1/; # strip anything not zero - $zeros *= $BASE_LEN; # elems * 5 - $zeros += length($elem); # count trailing zeros - last; # early out - } - $zeros ++; # real else branch: 50% slower! - } - $zeros; - } - -############################################################################## -# _is_* routines - -sub _is_zero - { - # return true if arg is zero - (((scalar @{$_[1]} == 1) && ($_[1]->[0] == 0))) <=> 0; - } - -sub _is_even - { - # return true if arg is even - (!($_[1]->[0] & 1)) <=> 0; - } - -sub _is_odd - { - # return true if arg is even - (($_[1]->[0] & 1)) <=> 0; - } - -sub _is_one - { - # return true if arg is one - (scalar @{$_[1]} == 1) && ($_[1]->[0] == 1) <=> 0; - } - -sub _is_two - { - # return true if arg is two - (scalar @{$_[1]} == 1) && ($_[1]->[0] == 2) <=> 0; - } - -sub _is_ten - { - # return true if arg is ten - (scalar @{$_[1]} == 1) && ($_[1]->[0] == 10) <=> 0; - } - -sub __strip_zeros - { - # internal normalization function that strips leading zeros from the array - # args: ref to array - my $s = shift; - - my $cnt = scalar @$s; # get count of parts - my $i = $cnt-1; - push @$s,0 if $i < 0; # div might return empty results, so fix it - - return $s if @$s == 1; # early out - - #print "strip: cnt $cnt i $i\n"; - # '0', '3', '4', '0', '0', - # 0 1 2 3 4 - # cnt = 5, i = 4 - # i = 4 - # i = 3 - # => fcnt = cnt - i (5-2 => 3, cnt => 5-1 = 4, throw away from 4th pos) - # >= 1: skip first part (this can be zero) - while ($i > 0) { last if $s->[$i] != 0; $i--; } - $i++; splice @$s,$i if ($i < $cnt); # $i cant be 0 - $s; - } - -############################################################################### -# check routine to test internal state for corruptions - -sub _check - { - # used by the test suite - my $x = $_[1]; - - return "$x is not a reference" if !ref($x); - - # are all parts are valid? - my $i = 0; my $j = scalar @$x; my ($e,$try); - while ($i < $j) - { - $e = $x->[$i]; $e = 'undef' unless defined $e; - $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e)"; - last if $e !~ /^[+]?[0-9]+$/; - $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (stringify)"; - last if "$e" !~ /^[+]?[0-9]+$/; - $try = '=~ /^[\+]?[0-9]+\$/; '."($x, $e) (cat-stringify)"; - last if '' . "$e" !~ /^[+]?[0-9]+$/; - $try = ' < 0 || >= $BASE; '."($x, $e)"; - last if $e <0 || $e >= $BASE; - # this test is disabled, since new/bnorm and certain ops (like early out - # in add/sub) are allowed/expected to leave '00000' in some elements - #$try = '=~ /^00+/; '."($x, $e)"; - #last if $e =~ /^00+/; - $i++; - } - return "Illegal part '$e' at pos $i (tested: $try)" if $i < $j; - 0; - } - - -############################################################################### - -sub _mod - { - # if possible, use mod shortcut - my ($c,$x,$yo) = @_; - - # slow way since $y to big - if (scalar @$yo > 1) - { - my ($xo,$rem) = _div($c,$x,$yo); - return $rem; - } - - my $y = $yo->[0]; - # both are single element arrays - if (scalar @$x == 1) - { - $x->[0] %= $y; - return $x; - } - - # @y is a single element, but @x has more than one element - my $b = $BASE % $y; - if ($b == 0) - { - # when BASE % Y == 0 then (B * BASE) % Y == 0 - # (B * BASE) % $y + A % Y => A % Y - # so need to consider only last element: O(1) - $x->[0] %= $y; - } - elsif ($b == 1) - { - # else need to go through all elements: O(N), but loop is a bit simplified - my $r = 0; - foreach (@$x) - { - $r = ($r + $_) % $y; # not much faster, but heh... - #$r += $_ % $y; $r %= $y; - } - $r = 0 if $r == $y; - $x->[0] = $r; - } - else - { - # else need to go through all elements: O(N) - my $r = 0; my $bm = 1; - foreach (@$x) - { - $r = ($_ * $bm + $r) % $y; - $bm = ($bm * $b) % $y; - - #$r += ($_ % $y) * $bm; - #$bm *= $b; - #$bm %= $y; - #$r %= $y; - } - $r = 0 if $r == $y; - $x->[0] = $r; - } - splice (@$x,1); # keep one element of $x - $x; - } - -############################################################################## -# shifts - -sub _rsft - { - my ($c,$x,$y,$n) = @_; - - if ($n != 10) - { - $n = _new($c,$n); return _div($c,$x, _pow($c,$n,$y)); - } - - # shortcut (faster) for shifting by 10) - # multiples of $BASE_LEN - my $dst = 0; # destination - my $src = _num($c,$y); # as normal int - my $xlen = (@$x-1)*$BASE_LEN+length(int($x->[-1])); # len of x in digits - if ($src >= $xlen or ($src == $xlen and ! defined $x->[1])) - { - # 12345 67890 shifted right by more than 10 digits => 0 - splice (@$x,1); # leave only one element - $x->[0] = 0; # set to zero - return $x; - } - my $rem = $src % $BASE_LEN; # remainder to shift - $src = int($src / $BASE_LEN); # source - if ($rem == 0) - { - splice (@$x,0,$src); # even faster, 38.4 => 39.3 - } - else - { - my $len = scalar @$x - $src; # elems to go - my $vd; my $z = '0'x $BASE_LEN; - $x->[scalar @$x] = 0; # avoid || 0 test inside loop - while ($dst < $len) - { - $vd = $z.$x->[$src]; - $vd = substr($vd,-$BASE_LEN,$BASE_LEN-$rem); - $src++; - $vd = substr($z.$x->[$src],-$rem,$rem) . $vd; - $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN; - $x->[$dst] = int($vd); - $dst++; - } - splice (@$x,$dst) if $dst > 0; # kill left-over array elems - pop @$x if $x->[-1] == 0 && @$x > 1; # kill last element if 0 - } # else rem == 0 - $x; - } - -sub _lsft - { - my ($c,$x,$y,$n) = @_; - - if ($n != 10) - { - $n = _new($c,$n); return _mul($c,$x, _pow($c,$n,$y)); - } - - # shortcut (faster) for shifting by 10) since we are in base 10eX - # multiples of $BASE_LEN: - my $src = scalar @$x; # source - my $len = _num($c,$y); # shift-len as normal int - my $rem = $len % $BASE_LEN; # remainder to shift - my $dst = $src + int($len/$BASE_LEN); # destination - my $vd; # further speedup - $x->[$src] = 0; # avoid first ||0 for speed - my $z = '0' x $BASE_LEN; - while ($src >= 0) - { - $vd = $x->[$src]; $vd = $z.$vd; - $vd = substr($vd,-$BASE_LEN+$rem,$BASE_LEN-$rem); - $vd .= $src > 0 ? substr($z.$x->[$src-1],-$BASE_LEN,$rem) : '0' x $rem; - $vd = substr($vd,-$BASE_LEN,$BASE_LEN) if length($vd) > $BASE_LEN; - $x->[$dst] = int($vd); - $dst--; $src--; - } - # set lowest parts to 0 - while ($dst >= 0) { $x->[$dst--] = 0; } - # fix spurios last zero element - splice @$x,-1 if $x->[-1] == 0; - $x; - } - -sub _pow - { - # power of $x to $y - # ref to array, ref to array, return ref to array - my ($c,$cx,$cy) = @_; - - if (scalar @$cy == 1 && $cy->[0] == 0) - { - splice (@$cx,1); $cx->[0] = 1; # y == 0 => x => 1 - return $cx; - } - if ((scalar @$cx == 1 && $cx->[0] == 1) || # x == 1 - (scalar @$cy == 1 && $cy->[0] == 1)) # or y == 1 - { - return $cx; - } - if (scalar @$cx == 1 && $cx->[0] == 0) - { - splice (@$cx,1); $cx->[0] = 0; # 0 ** y => 0 (if not y <= 0) - return $cx; - } - - my $pow2 = _one(); - - my $y_bin = _as_bin($c,$cy); $y_bin =~ s/^0b//; - my $len = length($y_bin); - while (--$len > 0) - { - _mul($c,$pow2,$cx) if substr($y_bin,$len,1) eq '1'; # is odd? - _mul($c,$cx,$cx); - } - - _mul($c,$cx,$pow2); - $cx; - } - -sub _fac - { - # factorial of $x - # ref to array, return ref to array - my ($c,$cx) = @_; - - if ((@$cx == 1) && ($cx->[0] <= 2)) - { - $cx->[0] ||= 1; # 0 => 1, 1 => 1, 2 => 2 - return $cx; - } - - # go forward until $base is exceeded - # limit is either $x steps (steps == 100 means a result always too high) or - # $base. - my $steps = 100; $steps = $cx->[0] if @$cx == 1; - my $r = 2; my $cf = 3; my $step = 2; my $last = $r; - while ($r*$cf < $BASE && $step < $steps) - { - $last = $r; $r *= $cf++; $step++; - } - if ((@$cx == 1) && $step == $cx->[0]) - { - # completely done, so keep reference to $x and return - $cx->[0] = $r; - return $cx; - } - - # now we must do the left over steps - my $n; # steps still to do - if (scalar @$cx == 1) - { - $n = $cx->[0]; - } - else - { - $n = _copy($c,$cx); - } - - $cx->[0] = $last; splice (@$cx,1); # keep ref to $x - my $zero_elements = 0; - - # do left-over steps fit into a scalar? - if (ref $n eq 'ARRAY') - { - # No, so use slower inc() & cmp() - $step = [$step]; - while (_acmp($step,$n) <= 0) - { - # as soon as the last element of $cx is 0, we split it up and remember - # how many zeors we got so far. The reason is that n! will accumulate - # zeros at the end rather fast. - if ($cx->[0] == 0) - { - $zero_elements ++; shift @$cx; - } - _mul($c,$cx,$step); _inc($c,$step); - } - } - else - { - # Yes, so we can speed it up slightly - while ($step <= $n) - { - # When the last element of $cx is 0, we split it up and remember - # how many we got so far. The reason is that n! will accumulate - # zeros at the end rather fast. - if ($cx->[0] == 0) - { - $zero_elements ++; shift @$cx; - } - _mul($c,$cx,[$step]); $step++; - } - } - # multiply in the zeros again - while ($zero_elements-- > 0) - { - unshift @$cx, 0; - } - $cx; # return result - } - -############################################################################# - -sub _log_int - { - # calculate integer log of $x to base $base - # ref to array, ref to array - return ref to array - my ($c,$x,$base) = @_; - - # X == 0 => NaN - return if (scalar @$x == 1 && $x->[0] == 0); - # BASE 0 or 1 => NaN - return if (scalar @$base == 1 && $base->[0] < 2); - my $cmp = _acmp($c,$x,$base); # X == BASE => 1 - if ($cmp == 0) - { - splice (@$x,1); $x->[0] = 1; - return ($x,1) - } - # X < BASE - if ($cmp < 0) - { - splice (@$x,1); $x->[0] = 0; - return ($x,undef); - } - - # this trial multiplication is very fast, even for large counts (like for - # 2 ** 1024, since this still requires only 1024 very fast steps - # (multiplication of a large number by a very small number is very fast)) - my $x_org = _copy($c,$x); # preserve x - splice(@$x,1); $x->[0] = 1; # keep ref to $x - - my $trial = _copy($c,$base); - - # XXX TODO this only works if $base has only one element - if (scalar @$base == 1) - { - # compute int ( length_in_base_10(X) / ( log(base) / log(10) ) ) - my $len = _len($c,$x_org); - my $res = int($len / (log($base->[0]) / log(10))) || 1; # avoid $res == 0 - - $x->[0] = $res; - $trial = _pow ($c, _copy($c, $base), $x); - my $a = _acmp($x,$trial,$x_org); - return ($x,1) if $a == 0; - # we now know that $res is too small - if ($res < 0) - { - _mul($c,$trial,$base); _add($c, $x, [1]); - } - else - { - # or too big - _div($c,$trial,$base); _sub($c, $x, [1]); - } - # did we now get the right result? - $a = _acmp($x,$trial,$x_org); - return ($x,1) if $a == 0; # yes, exactly - # still too big - if ($a > 0) - { - _div($c,$trial,$base); _sub($c, $x, [1]); - } - } - - # simple loop that increments $x by two in each step, possible overstepping - # the real result by one - - my $a; - my $base_mul = _mul($c, _copy($c,$base), $base); - - while (($a = _acmp($c,$trial,$x_org)) < 0) - { - _mul($c,$trial,$base_mul); _add($c, $x, [2]); - } - - my $exact = 1; - if ($a > 0) - { - # overstepped the result - _dec($c, $x); - _div($c,$trial,$base); - $a = _acmp($c,$trial,$x_org); - if ($a > 0) - { - _dec($c, $x); - } - $exact = 0 if $a != 0; - } - - ($x,$exact); # return result - } - -# for debugging: - use constant DEBUG => 0; - my $steps = 0; - sub steps { $steps }; - -sub _sqrt - { - # square-root of $x in place - # Compute a guess of the result (by rule of thumb), then improve it via - # Newton's method. - my ($c,$x) = @_; - - if (scalar @$x == 1) - { - # fit's into one Perl scalar, so result can be computed directly - $x->[0] = int(sqrt($x->[0])); - return $x; - } - my $y = _copy($c,$x); - # hopefully _len/2 is < $BASE, the -1 is to always undershot the guess - # since our guess will "grow" - my $l = int((_len($c,$x)-1) / 2); - - my $lastelem = $x->[-1]; # for guess - my $elems = scalar @$x - 1; - # not enough digits, but could have more? - if ((length($lastelem) <= 3) && ($elems > 1)) - { - # right-align with zero pad - my $len = length($lastelem) & 1; - print "$lastelem => " if DEBUG; - $lastelem .= substr($x->[-2] . '0' x $BASE_LEN,0,$BASE_LEN); - # former odd => make odd again, or former even to even again - $lastelem = $lastelem / 10 if (length($lastelem) & 1) != $len; - print "$lastelem\n" if DEBUG; - } - - # construct $x (instead of _lsft($c,$x,$l,10) - my $r = $l % $BASE_LEN; # 10000 00000 00000 00000 ($BASE_LEN=5) - $l = int($l / $BASE_LEN); - print "l = $l " if DEBUG; - - splice @$x,$l; # keep ref($x), but modify it - - # we make the first part of the guess not '1000...0' but int(sqrt($lastelem)) - # that gives us: - # 14400 00000 => sqrt(14400) => guess first digits to be 120 - # 144000 000000 => sqrt(144000) => guess 379 - - print "$lastelem (elems $elems) => " if DEBUG; - $lastelem = $lastelem / 10 if ($elems & 1 == 1); # odd or even? - my $g = sqrt($lastelem); $g =~ s/\.//; # 2.345 => 2345 - $r -= 1 if $elems & 1 == 0; # 70 => 7 - - # padd with zeros if result is too short - $x->[$l--] = int(substr($g . '0' x $r,0,$r+1)); - print "now ",$x->[-1] if DEBUG; - print " would have been ", int('1' . '0' x $r),"\n" if DEBUG; - - # If @$x > 1, we could compute the second elem of the guess, too, to create - # an even better guess. Not implemented yet. Does it improve performance? - $x->[$l--] = 0 while ($l >= 0); # all other digits of guess are zero - - print "start x= ",_str($c,$x),"\n" if DEBUG; - my $two = _two(); - my $last = _zero(); - my $lastlast = _zero(); - $steps = 0 if DEBUG; - while (_acmp($c,$last,$x) != 0 && _acmp($c,$lastlast,$x) != 0) - { - $steps++ if DEBUG; - $lastlast = _copy($c,$last); - $last = _copy($c,$x); - _add($c,$x, _div($c,_copy($c,$y),$x)); - _div($c,$x, $two ); - print " x= ",_str($c,$x),"\n" if DEBUG; - } - print "\nsteps in sqrt: $steps, " if DEBUG; - _dec($c,$x) if _acmp($c,$y,_mul($c,_copy($c,$x),$x)) < 0; # overshot? - print " final ",$x->[-1],"\n" if DEBUG; - $x; - } - -sub _root - { - # take n'th root of $x in place (n >= 3) - my ($c,$x,$n) = @_; - - if (scalar @$x == 1) - { - if (scalar @$n > 1) - { - # result will always be smaller than 2 so trunc to 1 at once - $x->[0] = 1; - } - else - { - # fit's into one Perl scalar, so result can be computed directly - # cannot use int() here, because it rounds wrongly (try - # (81 ** 3) ** (1/3) to see what I mean) - #$x->[0] = int( $x->[0] ** (1 / $n->[0]) ); - # round to 8 digits, then truncate result to integer - $x->[0] = int ( sprintf ("%.8f", $x->[0] ** (1 / $n->[0]) ) ); - } - return $x; - } - - # we know now that X is more than one element long - - # if $n is a power of two, we can repeatedly take sqrt($X) and find the - # proper result, because sqrt(sqrt($x)) == root($x,4) - my $b = _as_bin($c,$n); - if ($b =~ /0b1(0+)$/) - { - my $count = CORE::length($1); # 0b100 => len('00') => 2 - my $cnt = $count; # counter for loop - unshift (@$x, 0); # add one element, together with one - # more below in the loop this makes 2 - while ($cnt-- > 0) - { - # 'inflate' $X by adding one element, basically computing - # $x * $BASE * $BASE. This gives us more $BASE_LEN digits for result - # since len(sqrt($X)) approx == len($x) / 2. - unshift (@$x, 0); - # calculate sqrt($x), $x is now one element to big, again. In the next - # round we make that two, again. - _sqrt($c,$x); - } - # $x is now one element to big, so truncate result by removing it - splice (@$x,0,1); - } - else - { - # trial computation by starting with 2,4,8,16 etc until we overstep - my $step; - my $trial = _two(); - - # while still to do more than X steps - do - { - $step = _two(); - while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0) - { - _mul ($c, $step, [2]); - _add ($c, $trial, $step); - } - - # hit exactly? - if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) == 0) - { - @$x = @$trial; # make copy while preserving ref to $x - return $x; - } - # overstepped, so go back on step - _sub($c, $trial, $step); - } while (scalar @$step > 1 || $step->[0] > 128); - - # reset step to 2 - $step = _two(); - # add two, because $trial cannot be exactly the result (otherwise we would - # alrady have found it) - _add($c, $trial, $step); - - # and now add more and more (2,4,6,8,10 etc) - while (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) < 0) - { - _add ($c, $trial, $step); - } - - # hit not exactly? (overstepped) - if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0) - { - _dec($c,$trial); - } - - # hit not exactly? (overstepped) - # 80 too small, 81 slightly too big, 82 too big - if (_acmp($c, _pow($c, _copy($c, $trial), $n), $x) > 0) - { - _dec ($c, $trial); - } - - @$x = @$trial; # make copy while preserving ref to $x - return $x; - } - $x; - } - -############################################################################## -# binary stuff - -sub _and - { - my ($c,$x,$y) = @_; - - # the shortcut makes equal, large numbers _really_ fast, and makes only a - # very small performance drop for small numbers (e.g. something with less - # than 32 bit) Since we optimize for large numbers, this is enabled. - return $x if _acmp($c,$x,$y) == 0; # shortcut - - my $m = _one(); my ($xr,$yr); - my $mask = $AND_MASK; - - my $x1 = $x; - my $y1 = _copy($c,$y); # make copy - $x = _zero(); - my ($b,$xrr,$yrr); - use integer; - while (!_is_zero($c,$x1) && !_is_zero($c,$y1)) - { - ($x1, $xr) = _div($c,$x1,$mask); - ($y1, $yr) = _div($c,$y1,$mask); - - # make ints() from $xr, $yr - # this is when the AND_BITS are greater than $BASE and is slower for - # small (<256 bits) numbers, but faster for large numbers. Disabled - # due to KISS principle - -# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } -# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } -# _add($c,$x, _mul($c, _new( $c, ($xrr & $yrr) ), $m) ); - - # 0+ due to '&' doesn't work in strings - _add($c,$x, _mul($c, [ 0+$xr->[0] & 0+$yr->[0] ], $m) ); - _mul($c,$m,$mask); - } - $x; - } - -sub _xor - { - my ($c,$x,$y) = @_; - - return _zero() if _acmp($c,$x,$y) == 0; # shortcut (see -and) - - my $m = _one(); my ($xr,$yr); - my $mask = $XOR_MASK; - - my $x1 = $x; - my $y1 = _copy($c,$y); # make copy - $x = _zero(); - my ($b,$xrr,$yrr); - use integer; - while (!_is_zero($c,$x1) && !_is_zero($c,$y1)) - { - ($x1, $xr) = _div($c,$x1,$mask); - ($y1, $yr) = _div($c,$y1,$mask); - # make ints() from $xr, $yr (see _and()) - #$b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } - #$b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } - #_add($c,$x, _mul($c, _new( $c, ($xrr ^ $yrr) ), $m) ); - - # 0+ due to '^' doesn't work in strings - _add($c,$x, _mul($c, [ 0+$xr->[0] ^ 0+$yr->[0] ], $m) ); - _mul($c,$m,$mask); - } - # the loop stops when the shorter of the two numbers is exhausted - # the remainder of the longer one will survive bit-by-bit, so we simple - # multiply-add it in - _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1); - _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1); - - $x; - } - -sub _or - { - my ($c,$x,$y) = @_; - - return $x if _acmp($c,$x,$y) == 0; # shortcut (see _and) - - my $m = _one(); my ($xr,$yr); - my $mask = $OR_MASK; - - my $x1 = $x; - my $y1 = _copy($c,$y); # make copy - $x = _zero(); - my ($b,$xrr,$yrr); - use integer; - while (!_is_zero($c,$x1) && !_is_zero($c,$y1)) - { - ($x1, $xr) = _div($c,$x1,$mask); - ($y1, $yr) = _div($c,$y1,$mask); - # make ints() from $xr, $yr (see _and()) -# $b = 1; $xrr = 0; foreach (@$xr) { $xrr += $_ * $b; $b *= $BASE; } -# $b = 1; $yrr = 0; foreach (@$yr) { $yrr += $_ * $b; $b *= $BASE; } -# _add($c,$x, _mul($c, _new( $c, ($xrr | $yrr) ), $m) ); - - # 0+ due to '|' doesn't work in strings - _add($c,$x, _mul($c, [ 0+$xr->[0] | 0+$yr->[0] ], $m) ); - _mul($c,$m,$mask); - } - # the loop stops when the shorter of the two numbers is exhausted - # the remainder of the longer one will survive bit-by-bit, so we simple - # multiply-add it in - _add($c,$x, _mul($c, $x1, $m) ) if !_is_zero($c,$x1); - _add($c,$x, _mul($c, $y1, $m) ) if !_is_zero($c,$y1); - - $x; - } - -sub _as_hex - { - # convert a decimal number to hex (ref to array, return ref to string) - my ($c,$x) = @_; - - # fit's into one element (handle also 0x0 case) - return sprintf("0x%x",$x->[0]) if @$x == 1; - - my $x1 = _copy($c,$x); - - my $es = ''; - my ($xr, $h, $x10000); - if ($] >= 5.006) - { - $x10000 = [ 0x10000 ]; $h = 'h4'; - } - else - { - $x10000 = [ 0x1000 ]; $h = 'h3'; - } - while (@$x1 != 1 || $x1->[0] != 0) # _is_zero() - { - ($x1, $xr) = _div($c,$x1,$x10000); - $es .= unpack($h,pack('v',$xr->[0])); # XXX TODO: why pack('v',...)? - } - $es = reverse $es; - $es =~ s/^[0]+//; # strip leading zeros - '0x' . $es; # return result prepended with 0x - } - -sub _as_bin - { - # convert a decimal number to bin (ref to array, return ref to string) - my ($c,$x) = @_; - - # fit's into one element (and Perl recent enough), handle also 0b0 case - # handle zero case for older Perls - if ($] <= 5.005 && @$x == 1 && $x->[0] == 0) - { - my $t = '0b0'; return $t; - } - if (@$x == 1 && $] >= 5.006) - { - my $t = sprintf("0b%b",$x->[0]); - return $t; - } - my $x1 = _copy($c,$x); - - my $es = ''; - my ($xr, $b, $x10000); - if ($] >= 5.006) - { - $x10000 = [ 0x10000 ]; $b = 'b16'; - } - else - { - $x10000 = [ 0x1000 ]; $b = 'b12'; - } - while (!(@$x1 == 1 && $x1->[0] == 0)) # _is_zero() - { - ($x1, $xr) = _div($c,$x1,$x10000); - $es .= unpack($b,pack('v',$xr->[0])); # XXX TODO: why pack('v',...)? - # $es .= unpack($b,$xr->[0]); - } - $es = reverse $es; - $es =~ s/^[0]+//; # strip leading zeros - '0b' . $es; # return result prepended with 0b - } - -sub _from_hex - { - # convert a hex number to decimal (ref to string, return ref to array) - my ($c,$hs) = @_; - - my $m = _new($c, 0x10000000); # 28 bit at a time (<32 bit!) - my $d = 7; # 7 digits at a time - if ($] <= 5.006) - { - # for older Perls, play safe - $m = [ 0x10000 ]; # 16 bit at a time (<32 bit!) - $d = 4; # 4 digits at a time - } - - my $mul = _one(); - my $x = _zero(); - - my $len = int( (length($hs)-2)/$d ); # $d digit parts, w/o the '0x' - my $val; my $i = -$d; - while ($len >= 0) - { - $val = substr($hs,$i,$d); # get hex digits - $val =~ s/^[+-]?0x// if $len == 0; # for last part only because - $val = hex($val); # hex does not like wrong chars - $i -= $d; $len --; - my $adder = [ $val ]; - # if the resulting number was to big to fit into one element, create a - # two-element version (bug found by Mark Lakata - Thanx!) - if (CORE::length($val) > $BASE_LEN) - { - $adder = _new($c,$val); - } - _add ($c, $x, _mul ($c, $adder, $mul ) ) if $val != 0; - _mul ($c, $mul, $m ) if $len >= 0; # skip last mul - } - $x; - } - -sub _from_bin - { - # convert a hex number to decimal (ref to string, return ref to array) - my ($c,$bs) = @_; - - # instead of converting X (8) bit at a time, it is faster to "convert" the - # number to hex, and then call _from_hex. - - my $hs = $bs; - $hs =~ s/^[+-]?0b//; # remove sign and 0b - my $l = length($hs); # bits - $hs = '0' x (8-($l % 8)) . $hs if ($l % 8) != 0; # padd left side w/ 0 - my $h = '0x' . unpack('H*', pack ('B*', $hs)); # repack as hex - - $c->_from_hex($h); - } - -############################################################################## -# special modulus functions - -sub _modinv - { - # modular inverse - my ($c,$x,$y) = @_; - - my $u = _zero($c); my $u1 = _one($c); - my $a = _copy($c,$y); my $b = _copy($c,$x); - - # Euclid's Algorithm for bgcd(), only that we calc bgcd() ($a) and the - # result ($u) at the same time. See comments in BigInt for why this works. - my $q; - ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1 - my $sign = 1; - while (!_is_zero($c,$b)) - { - my $t = _add($c, # step 2: - _mul($c,_copy($c,$u1), $q) , # t = u1 * q - $u ); # + u - $u = $u1; # u = u1, u1 = t - $u1 = $t; - $sign = -$sign; - ($a, $q, $b) = ($b, _div($c,$a,$b)); # step 1 - } - - # if the gcd is not 1, then return NaN - return (undef,undef) unless _is_one($c,$a); - - ($u1, $sign == 1 ? '+' : '-'); - } - -sub _modpow - { - # modulus of power ($x ** $y) % $z - my ($c,$num,$exp,$mod) = @_; - - # in the trivial case, - if (_is_one($c,$mod)) - { - splice @$num,0,1; $num->[0] = 0; - return $num; - } - if ((scalar @$num == 1) && (($num->[0] == 0) || ($num->[0] == 1))) - { - $num->[0] = 1; - return $num; - } - -# $num = _mod($c,$num,$mod); # this does not make it faster - - my $acc = _copy($c,$num); my $t = _one(); - - my $expbin = _as_bin($c,$exp); $expbin =~ s/^0b//; - my $len = length($expbin); - while (--$len >= 0) - { - if ( substr($expbin,$len,1) eq '1') # is_odd - { - _mul($c,$t,$acc); - $t = _mod($c,$t,$mod); - } - _mul($c,$acc,$acc); - $acc = _mod($c,$acc,$mod); - } - @$num = @$t; - $num; - } - -sub _gcd - { - # greatest common divisor - my ($c,$x,$y) = @_; - - while ( (scalar @$y != 1) || ($y->[0] != 0) ) # while ($y != 0) - { - my $t = _copy($c,$y); - $y = _mod($c, $x, $y); - $x = $t; - } - $x; - } - -############################################################################## -############################################################################## - -1; -__END__ - -=head1 NAME - -Math::BigInt::Calc - Pure Perl module to support Math::BigInt - -=head1 SYNOPSIS - -Provides support for big integer calculations. Not intended to be used by other -modules. Other modules which sport the same functions can also be used to support -Math::BigInt, like Math::BigInt::GMP or Math::BigInt::Pari. - -=head1 DESCRIPTION - -In order to allow for multiple big integer libraries, Math::BigInt was -rewritten to use library modules for core math routines. Any module which -follows the same API as this can be used instead by using the following: - - use Math::BigInt lib => 'libname'; - -'libname' is either the long name ('Math::BigInt::Pari'), or only the short -version like 'Pari'. - -=head1 STORAGE - -=head1 METHODS - -The following functions MUST be defined in order to support the use by -Math::BigInt v1.70 or later: - - api_version() return API version, minimum 1 for v1.70 - _new(string) return ref to new object from ref to decimal string - _zero() return a new object with value 0 - _one() return a new object with value 1 - _two() return a new object with value 2 - _ten() return a new object with value 10 - - _str(obj) return ref to a string representing the object - _num(obj) returns a Perl integer/floating point number - NOTE: because of Perl numeric notation defaults, - the _num'ified obj may lose accuracy due to - machine-dependend floating point size limitations - - _add(obj,obj) Simple addition of two objects - _mul(obj,obj) Multiplication of two objects - _div(obj,obj) Division of the 1st object by the 2nd - In list context, returns (result,remainder). - NOTE: this is integer math, so no - fractional part will be returned. - The second operand will be not be 0, so no need to - check for that. - _sub(obj,obj) Simple subtraction of 1 object from another - a third, optional parameter indicates that the params - are swapped. In this case, the first param needs to - be preserved, while you can destroy the second. - sub (x,y,1) => return x - y and keep x intact! - _dec(obj) decrement object by one (input is garant. to be > 0) - _inc(obj) increment object by one - - - _acmp(obj,obj) <=> operator for objects (return -1, 0 or 1) - - _len(obj) returns count of the decimal digits of the object - _digit(obj,n) returns the n'th decimal digit of object - - _is_one(obj) return true if argument is 1 - _is_two(obj) return true if argument is 2 - _is_ten(obj) return true if argument is 10 - _is_zero(obj) return true if argument is 0 - _is_even(obj) return true if argument is even (0,2,4,6..) - _is_odd(obj) return true if argument is odd (1,3,5,7..) - - _copy return a ref to a true copy of the object - - _check(obj) check whether internal representation is still intact - return 0 for ok, otherwise error message as string - - _from_hex(str) return ref to new object from ref to hexadecimal string - _from_bin(str) return ref to new object from ref to binary string - - _as_hex(str) return string containing the value as - unsigned hex string, with the '0x' prepended. - Leading zeros must be stripped. - _as_bin(str) Like as_hex, only as binary string containing only - zeros and ones. Leading zeros must be stripped and a - '0b' must be prepended. - - _rsft(obj,N,B) shift object in base B by N 'digits' right - _lsft(obj,N,B) shift object in base B by N 'digits' left - - _xor(obj1,obj2) XOR (bit-wise) object 1 with object 2 - Note: XOR, AND and OR pad with zeros if size mismatches - _and(obj1,obj2) AND (bit-wise) object 1 with object 2 - _or(obj1,obj2) OR (bit-wise) object 1 with object 2 - - _mod(obj,obj) Return remainder of div of the 1st by the 2nd object - _sqrt(obj) return the square root of object (truncated to int) - _root(obj) return the n'th (n >= 3) root of obj (truncated to int) - _fac(obj) return factorial of object 1 (1*2*3*4..) - _pow(obj,obj) return object 1 to the power of object 2 - return undef for NaN - _zeros(obj) return number of trailing decimal zeros - _modinv return inverse modulus - _modpow return modulus of power ($x ** $y) % $z - _log_int(X,N) calculate integer log() of X in base N - X >= 0, N >= 0 (return undef for NaN) - returns (RESULT, EXACT) where EXACT is: - 1 : result is exactly RESULT - 0 : result was truncated to RESULT - undef : unknown whether result is exactly RESULT - _gcd(obj,obj) return Greatest Common Divisor of two objects - -The following functions are optional, and can be defined if the underlying lib -has a fast way to do them. If undefined, Math::BigInt will use pure Perl (hence -slow) fallback routines to emulate these: - - _signed_or - _signed_and - _signed_xor - - -Input strings come in as unsigned but with prefix (i.e. as '123', '0xabc' -or '0b1101'). - -So the library needs only to deal with unsigned big integers. Testing of input -parameter validity is done by the caller, so you need not worry about -underflow (f.i. in C<_sub()>, C<_dec()>) nor about division by zero or similar -cases. - -The first parameter can be modified, that includes the possibility that you -return a reference to a completely different object instead. Although keeping -the reference and just changing it's contents is prefered over creating and -returning a different reference. - -Return values are always references to objects, strings, or true/false for -comparisation routines. - -=head1 WRAP YOUR OWN - -If you want to port your own favourite c-lib for big numbers to the -Math::BigInt interface, you can take any of the already existing modules as -a rough guideline. You should really wrap up the latest BigInt and BigFloat -testsuites with your module, and replace in them any of the following: - - use Math::BigInt; - -by this: - - use Math::BigInt lib => 'yourlib'; - -This way you ensure that your library really works 100% within Math::BigInt. - -=head1 LICENSE - -This program is free software; you may redistribute it and/or modify it under -the same terms as Perl itself. - -=head1 AUTHORS - -Original math code by Mark Biggar, rewritten by Tels L -in late 2000. -Seperated from BigInt and shaped API with the help of John Peacock. - -Fixed, speed-up, streamlined and enhanced by Tels 2001 - 2005. - -=head1 SEE ALSO - -L, L, L, -L, L and L. - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/CalcEmu.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/CalcEmu.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/CalcEmu.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/CalcEmu.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/CalcEmu.pm Tue Oct 25 04:20:51 2005 @@ -1,329 +0,0 @@ -package Math::BigInt::CalcEmu; - -use 5.005; -use strict; -# use warnings; # dont use warnings for older Perls -use vars qw/$VERSION/; - -$VERSION = '0.05'; - -package Math::BigInt; - -# See SYNOPSIS below. - -my $CALC_EMU; - -BEGIN - { - $CALC_EMU = Math::BigInt->config()->{'lib'}; - # register us with MBI to get notified of future lib changes - Math::BigInt::_register_callback( __PACKAGE__, sub { $CALC_EMU = $_[0]; } ); - } - -sub __emu_band - { - my ($self,$x,$y,$sx,$sy, @ r) = @_; - - return $x->bzero(@r) if $y->is_zero() || $x->is_zero(); - - my $sign = 0; # sign of result - $sign = 1 if $sx == -1 && $sy == -1; - - my ($bx,$by); - - if ($sx == -1) # if x is negative - { - # two's complement: inc and flip all "bits" in $bx - $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc - $bx =~ s/-?0x//; - $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - else - { - $bx = $x->as_hex(); # get binary representation - $bx =~ s/-?0x//; - $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - if ($sy == -1) # if y is negative - { - # two's complement: inc and flip all "bits" in $by - $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc - $by =~ s/-?0x//; - $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - else - { - $by = $y->as_hex(); # get binary representation - $by =~ s/-?0x//; - $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - # now we have bit-strings from X and Y, reverse them for padding - $bx = reverse $bx; - $by = reverse $by; - - # padd the shorter string - my $xx = "\x00"; $xx = "\x0f" if $sx == -1; - my $yy = "\x00"; $yy = "\x0f" if $sy == -1; - my $diff = CORE::length($bx) - CORE::length($by); - if ($diff > 0) - { - # if $yy eq "\x00", we can cut $bx, otherwise we need to padd $by - $by .= $yy x $diff; - } - elsif ($diff < 0) - { - # if $xx eq "\x00", we can cut $by, otherwise we need to padd $bx - $bx .= $xx x abs($diff); - } - - # and the strings together - my $r = $bx & $by; - - # and reverse the result again - $bx = reverse $r; - - # One of $x or $y was negative, so need to flip bits in the result. - # In both cases (one or two of them negative, or both positive) we need - # to get the characters back. - if ($sign == 1) - { - $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/; - } - else - { - $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/; - } - - # leading zeros will be stripped by _from_hex() - $bx = '0x' . $bx; - $x->{value} = $CALC_EMU->_from_hex( $bx ); - - # calculate sign of result - $x->{sign} = '+'; - $x->{sign} = '-' if $sign == 1 && !$x->is_zero(); - - $x->bdec() if $sign == 1; - - $x->round(@r); - } - -sub __emu_bior - { - my ($self,$x,$y,$sx,$sy, @ r) = @_; - - return $x->round(@r) if $y->is_zero(); - - my $sign = 0; # sign of result - $sign = 1 if ($sx == -1) || ($sy == -1); - - my ($bx,$by); - - if ($sx == -1) # if x is negative - { - # two's complement: inc and flip all "bits" in $bx - $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc - $bx =~ s/-?0x//; - $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - else - { - $bx = $x->as_hex(); # get binary representation - $bx =~ s/-?0x//; - $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - if ($sy == -1) # if y is negative - { - # two's complement: inc and flip all "bits" in $by - $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc - $by =~ s/-?0x//; - $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - else - { - $by = $y->as_hex(); # get binary representation - $by =~ s/-?0x//; - $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - # now we have bit-strings from X and Y, reverse them for padding - $bx = reverse $bx; - $by = reverse $by; - - # padd the shorter string - my $xx = "\x00"; $xx = "\x0f" if $sx == -1; - my $yy = "\x00"; $yy = "\x0f" if $sy == -1; - my $diff = CORE::length($bx) - CORE::length($by); - if ($diff > 0) - { - $by .= $yy x $diff; - } - elsif ($diff < 0) - { - $bx .= $xx x abs($diff); - } - - # or the strings together - my $r = $bx | $by; - - # and reverse the result again - $bx = reverse $r; - - # one of $x or $y was negative, so need to flip bits in the result - # in both cases (one or two of them negative, or both positive) we need - # to get the characters back. - if ($sign == 1) - { - $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/; - } - else - { - $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/; - } - - # leading zeros will be stripped by _from_hex() - $bx = '0x' . $bx; - $x->{value} = $CALC_EMU->_from_hex( $bx ); - - # calculate sign of result - $x->{sign} = '+'; - $x->{sign} = '-' if $sign == 1 && !$x->is_zero(); - - # if one of X or Y was negative, we need to decrement result - $x->bdec() if $sign == 1; - - $x->round(@r); - } - -sub __emu_bxor - { - my ($self,$x,$y,$sx,$sy, @ r) = @_; - - return $x->round(@r) if $y->is_zero(); - - my $sign = 0; # sign of result - $sign = 1 if $x->{sign} ne $y->{sign}; - - my ($bx,$by); - - if ($sx == -1) # if x is negative - { - # two's complement: inc and flip all "bits" in $bx - $bx = $x->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc - $bx =~ s/-?0x//; - $bx =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - else - { - $bx = $x->as_hex(); # get binary representation - $bx =~ s/-?0x//; - $bx =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - if ($sy == -1) # if y is negative - { - # two's complement: inc and flip all "bits" in $by - $by = $y->copy()->binc()->as_hex(); # -1 => 0, -2 => 1, -3 => 2 etc - $by =~ s/-?0x//; - $by =~ tr/0123456789abcdef/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - else - { - $by = $y->as_hex(); # get binary representation - $by =~ s/-?0x//; - $by =~ tr/fedcba9876543210/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/; - } - # now we have bit-strings from X and Y, reverse them for padding - $bx = reverse $bx; - $by = reverse $by; - - # padd the shorter string - my $xx = "\x00"; $xx = "\x0f" if $sx == -1; - my $yy = "\x00"; $yy = "\x0f" if $sy == -1; - my $diff = CORE::length($bx) - CORE::length($by); - if ($diff > 0) - { - $by .= $yy x $diff; - } - elsif ($diff < 0) - { - $bx .= $xx x abs($diff); - } - - # xor the strings together - my $r = $bx ^ $by; - - # and reverse the result again - $bx = reverse $r; - - # one of $x or $y was negative, so need to flip bits in the result - # in both cases (one or two of them negative, or both positive) we need - # to get the characters back. - if ($sign == 1) - { - $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/0123456789abcdef/; - } - else - { - $bx =~ tr/\x0f\x0e\x0d\x0c\x0b\x0a\x09\x08\x07\x06\x05\x04\x03\x02\x01\x00/fedcba9876543210/; - } - - # leading zeros will be stripped by _from_hex() - $bx = '0x' . $bx; - $x->{value} = $CALC_EMU->_from_hex( $bx ); - - # calculate sign of result - $x->{sign} = '+'; - $x->{sign} = '-' if $sx != $sy && !$x->is_zero(); - - $x->bdec() if $sign == 1; - - $x->round(@r); - } - -############################################################################## -############################################################################## - -1; -__END__ - -=head1 NAME - -Math::BigInt::CalcEmu - Emulate low-level math with BigInt code - -=head1 SYNOPSIS - - use Math::BigInt::CalcEmu; - -=head1 DESCRIPTION - -Contains routines that emulate low-level math functions in BigInt, e.g. -optional routines the low-level math package does not provide on it's own. - -Will be loaded on demand and called automatically by BigInt. - -Stuff here is really low-priority to optimize, since it is far better to -implement the operation in the low-level math libary directly, possible even -using a call to the native lib. - -=head1 METHODS - -=head2 __emu_bxor - -=head2 __emu_band - -=head2 __emu_bior - -=head1 LICENSE - -This program is free software; you may redistribute it and/or modify it under -the same terms as Perl itself. - -=head1 AUTHORS - -(c) Tels http://bloodgate.com 2003, 2004 - based on BigInt code by -Tels from 2001-2003. - -=head1 SEE ALSO - -L, L, L, -L and L. - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Trace.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Trace.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Trace.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Trace.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Math/BigInt/Trace.pm Tue Oct 25 04:20:51 2005 @@ -1,47 +0,0 @@ -#!/usr/bin/perl -w - -package Math::BigInt::Trace; - -require 5.005_02; -use strict; - -use Exporter; -use Math::BigInt; -use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK - $accuracy $precision $round_mode $div_scale); - - @ ISA = qw(Exporter Math::BigInt); - -$VERSION = 0.01; - -use overload; # inherit overload from BigInt - -# Globals -$accuracy = $precision = undef; -$round_mode = 'even'; -$div_scale = 40; - -sub new -{ - my $proto = shift; - my $class = ref($proto) || $proto; - - my $value = shift; - my $a = $accuracy; $a = $_[0] if defined $_[0]; - my $p = $precision; $p = $_[1] if defined $_[1]; - my $self = Math::BigInt->new($value,$a,$p,$round_mode); - bless $self,$class; - print "MBI new '$value' => '$self' (",ref($self),")"; - return $self; -} - -sub import - { - print "MBI import ",join(' ', @ _); - my $self = shift; - Math::BigInt::import($self, @ _); # need it for subclasses -# $self->export_to_level(1,$self, @ _); # need this ? - @_ = (); - } - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:52 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:52 +0900 Subject: [Affelio-cvs 667] CVS update: affelio_farm/admin/skelton/affelio/extlib/XML Message-ID: <20051024192052.254B02AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/XML/RSS.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XML/RSS.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XML/RSS.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XML/RSS.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XML/RSS.pm Tue Oct 25 04:20:52 2005 @@ -1,2223 +0,0 @@ -# $Id: RSS.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -package XML::RSS; - -use strict; -use Carp; -use XML::Parser; -use vars qw($VERSION $AUTOLOAD @ISA $modules $AUTO_ADD); - -$VERSION = '1.05'; - @ ISA = qw(XML::Parser); - -$AUTO_ADD = 0; - -my %v0_9_ok_fields = ( - channel => { - title => '', - description => '', - link => '', - }, - image => { - title => '', - url => '', - link => '' - }, - textinput => { - title => '', - description => '', - name => '', - link => '' - }, - items => [], - num_items => 0, - version => '', - encoding => '' -); - -my %v0_9_1_ok_fields = ( - channel => { - title => '', - copyright => '', - description => '', - docs => '', - language => '', - lastBuildDate => '', - 'link' => '', - managingEditor => '', - pubDate => '', - rating => '', - webMaster => '' - }, - image => { - title => '', - url => '', - 'link' => '', - width => '', - height => '', - description => '' - }, - skipDays => { - day => '' - }, - skipHours => { - hour => '' - }, - textinput => { - title => '', - description => '', - name => '', - 'link' => '' - }, - items => [], - num_items => 0, - version => '', - encoding => '', - category => '' -); - -my %v1_0_ok_fields = ( - channel => { - title => '', - description => '', - link => '', - }, - image => { - title => '', - url => '', - link => '' - }, - textinput => { - title => '', - description => '', - name => '', - link => '' - }, - skipDays => { - day => '' - }, - skipHours => { - hour => '' - }, - items => [], - num_items => 0, - version => '', - encoding => '', - output => '', -); - -my %v2_0_ok_fields = ( - channel => { - title => '', - 'link' => '', - description => '', - language => '', - copyright => '', - managingEditor => '', - webMaster => '', - pubDate => '', - lastBuildDate => '', - category => '', - generator => '', - docs => '', - cloud => '', - ttl => '', - image => '', - textinput => '', - skipHours => '', - skipDays => '', - }, - image => { - title => '', - url => '', - 'link' => '', - width => '', - height => '', - description => '' - }, - skipDays => { - day => '' - }, - skipHours => { - hour => '' - }, - textinput => { - title => '', - description => '', - name => '', - 'link' => '' - }, - items => [], - num_items => 0, - version => '', - encoding => '', - category => '', - cloud => '', - ttl => '' -); - -my %languages = ( - 'af' => 'Afrikaans', - 'sq' => 'Albanian', - 'eu' => 'Basque', - 'be' => 'Belarusian', - 'bg' => 'Bulgarian', - 'ca' => 'Catalan', - 'zh-cn' => 'Chinese (Simplified)', - 'zh-tw' => 'Chinese (Traditional)', - 'hr' => 'Croatian', - 'cs' => 'Czech', - 'da' => 'Danish', - 'nl' => 'Dutch', - 'nl-be' => 'Dutch (Belgium)', - 'nl-nl' => 'Dutch (Netherlands)', - 'en' => 'English', - 'en-au' => 'English (Australia)', - 'en-bz' => 'English (Belize)', - 'en-ca' => 'English (Canada)', - 'en-ie' => 'English (Ireland)', - 'en-jm' => 'English (Jamaica)', - 'en-nz' => 'English (New Zealand)', - 'en-ph' => 'English (Phillipines)', - 'en-za' => 'English (South Africa)', - 'en-tt' => 'English (Trinidad)', - 'en-gb' => 'English (United Kingdom)', - 'en-us' => 'English (United States)', - 'en-zw' => 'English (Zimbabwe)', - 'fo' => 'Faeroese', - 'fi' => 'Finnish', - 'fr' => 'French', - 'fr-be' => 'French (Belgium)', - 'fr-ca' => 'French (Canada)', - 'fr-fr' => 'French (France)', - 'fr-lu' => 'French (Luxembourg)', - 'fr-mc' => 'French (Monaco)', - 'fr-ch' => 'French (Switzerland)', - 'gl' => 'Galician', - 'gd' => 'Gaelic', - 'de' => 'German', - 'de-at' => 'German (Austria)', - 'de-de' => 'German (Germany)', - 'de-li' => 'German (Liechtenstein)', - 'de-lu' => 'German (Luxembourg)', - 'el' => 'Greek', - 'hu' => 'Hungarian', - 'is' => 'Icelandic', - 'in' => 'Indonesian', - 'ga' => 'Irish', - 'it' => 'Italian', - 'it-it' => 'Italian (Italy)', - 'it-ch' => 'Italian (Switzerland)', - 'ja' => 'Japanese', - 'ko' => 'Korean', - 'mk' => 'Macedonian', - 'no' => 'Norwegian', - 'pl' => 'Polish', - 'pt' => 'Portuguese', - 'pt-br' => 'Portuguese (Brazil)', - 'pt-pt' => 'Portuguese (Portugal)', - 'ro' => 'Romanian', - 'ro-mo' => 'Romanian (Moldova)', - 'ro-ro' => 'Romanian (Romania)', - 'ru' => 'Russian', - 'ru-mo' => 'Russian (Moldova)', - 'ru-ru' => 'Russian (Russia)', - 'sr' => 'Serbian', - 'sk' => 'Slovak', - 'sl' => 'Slovenian', - 'es' => 'Spanish', - 'es-ar' => 'Spanish (Argentina)', - 'es-bo' => 'Spanish (Bolivia)', - 'es-cl' => 'Spanish (Chile)', - 'es-co' => 'Spanish (Colombia)', - 'es-cr' => 'Spanish (Costa Rica)', - 'es-do' => 'Spanish (Dominican Republic)', - 'es-ec' => 'Spanish (Ecuador)', - 'es-sv' => 'Spanish (El Salvador)', - 'es-gt' => 'Spanish (Guatemala)', - 'es-hn' => 'Spanish (Honduras)', - 'es-mx' => 'Spanish (Mexico)', - 'es-ni' => 'Spanish (Nicaragua)', - 'es-pa' => 'Spanish (Panama)', - 'es-py' => 'Spanish (Paraguay)', - 'es-pe' => 'Spanish (Peru)', - 'es-pr' => 'Spanish (Puerto Rico)', - 'es-es' => 'Spanish (Spain)', - 'es-uy' => 'Spanish (Uruguay)', - 'es-ve' => 'Spanish (Venezuela)', - 'sv' => 'Swedish', - 'sv-fi' => 'Swedish (Finland)', - 'sv-se' => 'Swedish (Sweden)', - 'tr' => 'Turkish', - 'uk' => 'Ukranian' - ); - -# define required elements for RSS 0.9 -my $_REQ_v0_9 = { - channel => { - "title" => [1,40], - "description" => [1,500], - "link" => [1,500] - }, - image => { - "title" => [1,40], - "url" => [1,500], - "link" => [1,500] - }, - item => { - "title" => [1,100], - "link" => [1,500] - }, - textinput => { - "title" => [1,40], - "description" => [1,100], - "name" => [1,500], - "link" => [1,500] - } -}; - -# define required elements for RSS 0.91 -my $_REQ_v0_9_1 = { - channel => { - "title" => [1,100], - "description" => [1,500], - "link" => [1,500], - "language" => [1,5], - "rating" => [0,500], - "copyright" => [0,100], - "pubDate" => [0,100], - "lastBuildDate" => [0,100], - "docs" => [0,500], - "managingEditor" => [0,100], - "webMaster" => [0,100], - }, - image => { - "title" => [1,100], - "url" => [1,500], - "link" => [0,500], - "width" => [0,144], - "height" => [0,400], - "description" => [0,500] - }, - item => { - "title" => [1,100], - "link" => [1,500], - "description" => [0,500] - }, - textinput => { - "title" => [1,100], - "description" => [1,500], - "name" => [1,20], - "link" => [1,500] - }, - skipHours => { - "hour" => [1,23] - }, - skipDays => { - "day" => [1,10] - } -}; - -# define required elements for RSS 2.0 -my $_REQ_v2_0 = { - channel => { - "title" => [1,100], - "description" => [1,500], - "link" => [1,500], - "language" => [0,5], - "rating" => [0,500], - "copyright" => [0,100], - "pubDate" => [0,100], - "lastBuildDate" => [0,100], - "docs" => [0,500], - "managingEditor" => [0,100], - "webMaster" => [0,100], - }, - image => { - "title" => [1,100], - "url" => [1,500], - "link" => [0,500], - "width" => [0,144], - "height" => [0,400], - "description" => [0,500] - }, - item => { - "title" => [1,100], - "link" => [1,500], - "description" => [0,500] - }, - textinput => { - "title" => [1,100], - "description" => [1,500], - "name" => [1,20], - "link" => [1,500] - }, - skipHours => { - "hour" => [1,23] - }, - skipDays => { - "day" => [1,10] - } -}; - -my $namespace_map = { - rss10 => 'http://purl.org/rss/1.0/', - rss09 => 'http://my.netscape.com/rdf/simple/0.9/', -# rss091 => 'http://purl.org/rss/1.0/modules/rss091/', - rss20 => 'http://backend.userland.com/blogChannelModule', -}; - -my $modules = { - 'http://purl.org/rss/1.0/modules/syndication/' => 'syn', - 'http://purl.org/dc/elements/1.1/' => 'dc', - 'http://purl.org/rss/1.0/modules/taxonomy/' => 'taxo', - 'http://webns.net/mvcb/' => 'admin' -}; - -my %syn_ok_fields = ( - 'updateBase' => '', - 'updateFrequency' => '', - 'updatePeriod' => '', -); - -my %dc_ok_fields = ( - 'title' => '', - 'creator' => '', - 'subject' => '', - 'description' => '', - 'publisher' => '', - 'contributor' => '', - 'date' => '', - 'type' => '', - 'format' => '', - 'identifier' => '', - 'source' => '', - 'language' => '', - 'relation' => '', - 'coverage' => '', - 'rights' => '', -); - -my %rdf_resource_fields = ( - 'http://webns.net/mvcb/' => { - 'generatorAgent' => 1, - 'errorReportsTo' => 1 - }, - 'http://purl.org/rss/1.0/modules/annotate/' => { - 'reference' => 1 - }, - 'http://my.theinfo.org/changed/1.0/rss/' => { - 'server' => 1 - } -); - -sub new { - my $class = shift; - - my $self = $class->SUPER::new( - Namespaces => 1, - NoExpand => 1, - ParseParamEnt => 0, - Handlers => { - Char => \&handle_char, - XMLDecl => \&handle_dec, - Start => \&handle_start - }); - - bless $self, $class; - - $self->_initialize(@_); - - return $self; -} - -sub _initialize { - my $self = shift; - my %hash = @_; - - # internal hash - $self->{_internal} = {}; - - # init num of items to 0 - $self->{num_items} = 0; - - # adhere to Netscape limits; no by default - $self->{'strict'} = 0; - - # initialize items - $self->{items} = []; - - # namespaces - $self->{namespaces} = {}; - $self->{rss_namespace} = ''; - - # modules - $self->{modules} = $modules; - - # encode output from as_string? - (exists($hash{encode_output})) - ? ($self->{encode_output} = $hash{encode_output}) - : ($self->{encode_output} = 1); - - #get version info - (exists($hash{version})) - ? ($self->{version} = $hash{version}) - : ($self->{version} = '1.0'); - - # set default output - (exists($hash{output})) - ? ($self->{output} = $hash{output}) - : ($self->{output} = ""); - - # encoding - (exists($hash{encoding})) - ? ($self->{encoding} = $hash{encoding}) - : ($self->{encoding} = 'UTF-8'); - - # initialize RSS data structure - # RSS version 0.9 - if ($self->{version} eq '0.9') { - # Copy the hashes instead of using them directly to avoid - # problems with multiple XML::RSS objects being used concurrently - foreach my $i (qw(channel image textinput)) { - my %template=%{$v0_9_ok_fields{$i}}; - $self->{$i} = \%template; - } - - # RSS version 0.91 - } elsif ($self->{version} eq '0.91') { - foreach my $i (qw(channel image textinput skipDays skipHours)) { - my %template=%{$v0_9_1_ok_fields{$i}}; - $self->{$i} = \%template; - } - - # RSS version 2.0 - } elsif ($self->{version} eq '2.0') { - $self->{namespaces}->{'blogChannel'} = "http://backend.userland.com/blogChannelModule"; - foreach my $i (qw(channel image textinput skipDays skipHours)) { - my %template=%{ $v2_0_ok_fields{$i} }; - $self->{$i} = \%template; - } - - # RSS version 1.0 - #} elsif ($self->{version} eq '1.0') { - } else { - foreach my $i (qw(channel image textinput)) { - #foreach my $i (keys(%v1_0_ok_fields)) { - my %template=%{$v1_0_ok_fields{$i}}; - $self->{$i} = \%template; - } - } -} - -sub add_module { - my $self = shift; - my $hash = {@_}; - - $hash->{prefix} =~ /^[a-z_][a-z0-9.-_]*$/ or - croak "a namespace prefix should look like [a-z_][a-z0-9.-_]*"; - - $hash->{uri} or - croak "a URI must be provided in a namespace declaration"; - - $self->{modules}->{$hash->{uri}} = $hash->{prefix}; -} - -sub add_item { - my $self = shift; - my $hash = {@_}; - - # strict Netscape Netcenter length checks - if ($self->{'strict'}) { - # make sure we have a title and link - croak "title and link elements are required" - unless ($hash->{title} && $hash->{'link'}); - - # check string lengths - croak "title cannot exceed 100 characters in length" - if (length($hash->{title}) > 100); - croak "link cannot exceed 500 characters in length" - if (length($hash->{'link'}) > 500); - croak "description cannot exceed 500 characters in length" - if (exists($hash->{description}) - && length($hash->{description}) > 500); - - # make sure there aren't already 15 items - croak "total items cannot exceed 15 " if (@{$self->{items}} >= 15); - } - - # add the item to the list - if (defined($hash->{mode}) && $hash->{mode} eq 'insert') { - unshift (@{$self->{items}}, $hash); - } else { - push (@{$self->{items}}, $hash); - } - - # return reference to the list of items - return $self->{items}; -} - -sub as_rss_0_9 { - my $self = shift; - my $output; - - # XML declaration - my $encoding = exists $$self{encoding} ? qq| encoding="$$self{encoding}"| : ''; - $output .= qq|\n\n|; - - # RDF root element - $output .= 'encode($self->{channel}->{title}) .''."\n"; - $output .= ''. $self->encode($self->{channel}->{'link'}) .''."\n"; - $output .= ''. $self->encode($self->{channel}->{description}) .''."\n"; - $output .= ''."\n\n"; - - ################# - # image element # - ################# - if ($self->{image}->{url}) { - $output .= ''."\n"; - - # title - $output .= ''. $self->encode($self->{image}->{title}) .''."\n"; - - # url - $output .= ''. $self->encode($self->{image}->{url}) .''."\n"; - - # link - $output .= ''. $self->encode($self->{image}->{'link'}) .''."\n" - if $self->{image}->{link}; - - # end image element - $output .= ''."\n\n"; - } - - ################ - # item element # - ################ - foreach my $item (@{$self->{items}}) { - if ($item->{title}) { - $output .= ''."\n"; - $output .= ''. $self->encode($item->{title}) .''."\n"; - $output .= ''. $self->encode($item->{'link'}) .''."\n"; - - # end image element - $output .= ''."\n\n"; - } - } - - ##################### - # textinput element # - ##################### - if ($self->{textinput}->{'link'}) { - $output .= ''."\n"; - $output .= ''. $self->encode($self->{textinput}->{title}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{description}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{name}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{'link'}) .''."\n"; - $output .= ''."\n\n"; - } - - $output .= ''; - - return $output; -} - -sub as_rss_0_9_1 { - my $self = shift; - my $output; - - # XML declaration - $output .= '{encoding}.'"?>'."\n\n"; - - # DOCTYPE - $output .= ''."\n\n"; - - # RSS root element - $output .= ''."\n\n"; - - ################### - # Channel Element # - ################### - $output .= ''."\n"; - $output .= ''. $self->encode($self->{channel}->{title}) .''."\n"; - $output .= ''. $self->encode($self->{channel}->{'link'}) .''."\n"; - $output .= ''. $self->encode($self->{channel}->{description}) .''."\n"; - - # language - if ($self->{channel}->{'dc'}->{'language'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'language'}) .''."\n"; - } elsif ($self->{channel}->{language}) { - $output .= ''. $self->encode($self->{channel}->{language}).''."\n"; - } - - # PICS rating - $output .= ''. $self->encode($self->{channel}->{rating}) .''."\n" - if $self->{channel}->{rating}; - - # copyright - if ($self->{channel}->{'dc'}->{'rights'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'rights'}) .''."\n"; - } elsif ($self->{channel}->{copyright}) { - $output .= ''. $self->encode($self->{channel}->{copyright}) .''."\n"; - } - - # publication date - if ($self->{channel}->{pubDate}) { - $output .= ''. $self->encode($self->{channel}->{pubDate}) .''."\n"; - } elsif ($self->{channel}->{'dc'}->{'date'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'date'}) .''."\n"; - } - - # last build date - if ($self->{channel}->{lastBuildDate}) { - $output .= ''. $self->encode($self->{channel}->{lastBuildDate}) .''."\n"; - } elsif ($self->{channel}->{'dc'}->{'date'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'date'}) .''."\n"; - } - - # external CDF URL - $output .= ''. $self->encode($self->{channel}->{docs}) .''."\n" - if $self->{channel}->{docs}; - - # managing editor - if ($self->{channel}->{'dc'}->{'publisher'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'publisher'}) .''."\n"; - } elsif ($self->{channel}->{managingEditor}) { - $output .= ''. $self->encode($self->{channel}->{managingEditor}) .''."\n"; - } - - # webmaster - if ($self->{channel}->{'dc'}->{'creator'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'creator'}) .''."\n"; - } elsif ($self->{channel}->{webMaster}) { - $output .= ''. $self->encode($self->{channel}->{webMaster}) .''."\n"; - } - - $output .= "\n"; - - ################# - # image element # - ################# - if ($self->{image}->{url}) { - $output .= ''."\n"; - - # title - $output .= ''. $self->encode($self->{image}->{title}) .''."\n"; - - # url - $output .= ''. $self->encode($self->{image}->{url}) .''."\n"; - - # link - $output .= ''. $self->encode($self->{image}->{'link'}) .''."\n" - if $self->{image}->{link}; - - # image width - $output .= ''. $self->encode($self->{image}->{width}) .''."\n" - if $self->{image}->{width}; - - # image height - $output .= ''. $self->encode($self->{image}->{height}) .''."\n" - if $self->{image}->{height}; - - # description - $output .= ''. $self->encode($self->{image}->{description}) .''."\n" - if $self->{image}->{description}; - - # end image element - $output .= ''."\n\n"; - } - - ################ - # item element # - ################ - foreach my $item (@{$self->{items}}) { - if ($item->{title}) { - $output .= ''."\n"; - $output .= ''. $self->encode($item->{title}) .''."\n"; - $output .= ''. $self->encode($item->{'link'}) .''."\n"; - - $output .= ''. $self->encode($item->{description}) .''."\n" - if $item->{description}; - - # end image element - $output .= ''."\n\n"; - } - } - - ##################### - # textinput element # - ##################### - if ($self->{textinput}->{'link'}) { - $output .= ''."\n"; - $output .= ''. $self->encode($self->{textinput}->{title}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{description}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{name}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{'link'}) .''."\n"; - $output .= ''."\n\n"; - } - - ##################### - # skipHours element # - ##################### - if ($self->{skipHours}->{hour}) { - $output .= ''."\n"; - $output .= ''. $self->encode($self->{skipHours}->{hour}) .''."\n"; - $output .= ''."\n\n"; - } - - #################### - # skipDays element # - #################### - if ($self->{skipDays}->{day}) { - $output .= ''."\n"; - $output .= ''. $self->encode($self->{skipDays}->{day}) .''."\n"; - $output .= ''."\n\n"; - } - - # end channel element - $output .= ''."\n"; - $output .= ''; - - return $output; -} - -sub as_rss_1_0 { - my $self = shift; - my $output; - - # XML declaration - $output .= '{encoding}.'"?>'."\n\n"; - - # RDF namespaces declaration - $output .="{modules}}) { - $output.=" xmlns:$v=\"$k\"\n"; - } - - $output .=">"."\n\n"; - - ################### - # Channel Element # - ################### - unless ( defined($self->{channel}->{'about'}) ) { - $output .= ''."\n"; - } else { - $output .= ''."\n"; - } - # title - $output .= ''. $self->encode($self->{channel}->{title}) .''."\n"; - - # link - $output .= ''. $self->encode($self->{channel}->{'link'}) .''."\n"; - - # description - $output .= ''. $self->encode($self->{channel}->{description}) .''."\n"; - - # additional elements for RSS 0.91 - # language - if ($self->{channel}->{'dc'}->{'language'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'language'}) .''."\n"; - } elsif ($self->{channel}->{language}) { - $output .= ''. $self->encode($self->{channel}->{language}) .''."\n"; - } - - # PICS rating - Dublin Core has not decided how to incorporate PICS ratings yet - #$$output .= ''.$self->{channel}->{rating}.''."\n" - #$if $self->{channel}->{rating}; - - # copyright - if ($self->{channel}->{'dc'}->{'rights'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'rights'}) .''."\n"; - } elsif ($self->{channel}->{copyright}) { - $output .= ''. $self->encode($self->{channel}->{copyright}) .''."\n"; - } - - # publication date - if ($self->{channel}->{'dc'}->{'date'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'date'}) .''."\n"; - } elsif ($self->{channel}->{pubDate}) { - $output .= ''. $self->encode($self->{channel}->{pubDate}) .''."\n"; - } elsif ($self->{channel}->{lastBuildDate}) { - $output .= ''. $self->encode($self->{channel}->{lastBuildDate}) .''."\n"; - } - - # external CDF URL - #$output .= ''.$self->{channel}->{docs}.''."\n" - #if $self->{channel}->{docs}; - - # managing editor - if ($self->{channel}->{'dc'}->{'publisher'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'publisher'}) .''."\n"; - } elsif ($self->{channel}->{managingEditor}) { - $output .= ''. $self->encode($self->{channel}->{managingEditor}) .''."\n"; - } - - # webmaster - if ($self->{channel}->{'dc'}->{'creator'}) { - $output .= ''. $self->encode($self->{channel}->{'dc'}->{'creator'}) .''."\n"; - } elsif ($self->{channel}->{webMaster}) { - $output .= ''. $self->encode($self->{channel}->{webMaster}) .''."\n"; - } - - # Dublin Core module - foreach my $dc ( keys %dc_ok_fields ) { - next if ($dc eq 'language' - || $dc eq 'creator' - || $dc eq 'publisher' - || $dc eq 'rights' - || $dc eq 'date'); - $self->{channel}->{dc}->{$dc} and $output .= "". $self->encode($self->{channel}->{dc}->{$dc}) ."\n"; - } - - # Syndication module - foreach my $syn ( keys %syn_ok_fields ) { - $self->{channel}->{syn}->{$syn} and $output .= "". $self->encode($self->{channel}->{syn}->{$syn}) ."\n"; - } - - # Taxonomy module - if (exists($self->{'channel'}->{'taxo'}) && $self->{'channel'}->{'taxo'}) { - $output .= "\n \n"; - foreach my $taxo (@{$self->{'channel'}->{'taxo'}}) { - $output.= " encode($taxo) . "\" />\n"; - } - $output .= " \n\n"; - } - - # Ad-hoc modules - while ( my($url, $prefix) = each %{$self->{modules}} ) { - next if $prefix =~ /^(dc|syn|taxo)$/; - while ( my($el, $value) = each %{$self->{channel}->{$prefix}} ) { - if ( exists( $rdf_resource_fields{ $url } ) and - exists( $rdf_resource_fields{ $url }{ $el }) ) - { - $output .= qq!<$prefix:$el rdf:resource="! . - $self->encode($value) . - qq!" />\n!; - } - else { - $output .= "<$prefix:$el>". $self->encode($value) ."\n"; - } - } - } - - # Seq items - $output .= "\n \n"; - - foreach my $item (@{$self->{items}}) { - my $about = ( defined($item->{'about'}) ) ? $item->{'about'} : $item->{'link'}; - $output .= ' '."\n"; - } - - $output .= " \n\n"; - - $self->{image}->{url} and - $output .= ''."\n"; - - $self->{textinput}->{'link'} and - $output .= ''."\n"; - - # end channel element - $output .= ''."\n\n"; - - ################# - # image element # - ################# - if ($self->{image}->{url}) { - $output .= ''."\n"; - - # title - $output .= ''. $self->encode($self->{image}->{title}) .''."\n"; - - # url - $output .= ''. $self->encode($self->{image}->{url}) .''."\n"; - - # link - $output .= ''. $self->encode($self->{image}->{'link'}) .''."\n" - if $self->{image}->{link}; - - # image width - #$output .= ''.$self->{image}->{width}.''."\n" - # if $self->{image}->{width}; - - # image height - #$output .= ''.$self->{image}->{height}.''."\n" - # if $self->{image}->{height}; - - # description - #$output .= ''.$self->{image}->{description}.''."\n" - # if $self->{image}->{description}; - - # Dublin Core Modules - foreach my $dc ( keys %dc_ok_fields ) { - $self->{image}->{dc}->{$dc} and - $output .= "". $self->encode($self->{image}->{dc}->{$dc}) ."\n"; - } - - # Ad-hoc modules for images - while ( my($url, $prefix) = each %{$self->{modules}} ) { - next if $prefix =~ /^(dc|syn|taxo)$/; - while ( my($el, $value) = each %{$self->{image}->{$prefix}} ) { - if ( exists( $rdf_resource_fields{ $url } ) and - exists( $rdf_resource_fields{ $url }{ $el }) ) - { - $output .= qq!<$prefix:$el rdf:resource="! . - $self->encode($value) . - qq!" />\n!; - } - else { - $output .= "<$prefix:$el>". $self->encode($value) ."\n"; - } - } - } - # end image element - $output .= ''."\n\n"; - } # end if ($self->{image}->{url}) { - - ################ - # item element # - ################ - foreach my $item (@{$self->{items}}) { - if ($item->{title}) { - my $about = ( defined($item->{'about'}) ) ? $item->{'about'} : $item->{'link'}; - $output .= 'encode($item->{title}) .''."\n"; - $output .= ''. $self->encode($item->{'link'}) .''."\n"; - $item->{description} and $output .= ''. $self->encode($item->{description}) .''."\n"; - - # Dublin Core module - foreach my $dc ( keys %dc_ok_fields ) { - $item->{dc}->{$dc} and $output .= "". $self->encode($item->{dc}->{$dc}) ."\n"; - } - - # Taxonomy module - if (exists($item->{'taxo'}) && $item->{'taxo'}) { - $output .= "\n \n"; - foreach my $taxo (@{$item->{'taxo'}}) { - $output.= " \n"; - } - $output .= " \n\n"; - } - - # Ad-hoc modules - while ( my($url, $prefix) = each %{$self->{modules}} ) { - next if $prefix =~ /^(dc|syn|taxo)$/; - while ( my($el, $value) = each %{$item->{$prefix}} ) { - if ( exists( $rdf_resource_fields{ $url } ) and - exists( $rdf_resource_fields{ $url }{ $el }) ) - { - $output .= qq!<$prefix:$el rdf:resource="! . - $self->encode($value) . - qq!" />\n!; - } - else { - $output .= "<$prefix:$el>". $self->encode($value) ."\n"; - } - } - } - # end item element - $output .= ''."\n\n"; - } - } # end foreach my $item (@{$self->{items}}) { - - ##################### - # textinput element # - ##################### - if ($self->{textinput}->{'link'}) { - $output .= ''."\n"; - $output .= ''. $self->encode($self->{textinput}->{title}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{description}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{name}) .''."\n"; - $output .= ''. $self->encode($self->{textinput}->{'link'}) .''."\n"; - - # Dublin Core module - foreach my $dc ( keys %dc_ok_fields ) { - $self->{textinput}->{dc}->{$dc} - and $output .= "". $self->encode($self->{textinput}->{dc}->{$dc}) ."\n"; - } - - # Ad-hoc modules - while ( my($url, $prefix) = each %{$self->{modules}} ) { - next if $prefix =~ /^(dc|syn|taxo)$/; - while ( my($el, $value) = each %{$self->{textinput}->{$prefix}} ) { - $output .= "<$prefix:$el>". $self->encode($value) ."\n"; - } - } - - $output .= ''."\n\n"; - } - - $output .= ''; -} - -sub as_rss_2_0 { - my $self = shift; - my $output; - - # XML declaration - $output .= '{encoding}.'"?>'."\n\n"; - - # DOCTYPE - # $output .= ''."\n\n"; - - # RSS root element - # $output .= ''."\n\n"; - $output .= '' . "\n\n"; - - ################### - # Channel Element # - ################### - $output .= ''."\n"; - $output .= ''.$self->encode($self->{channel}->{title}).''."\n"; - $output .= ''.$self->encode($self->{channel}->{'link'}).''."\n"; - $output .= ''.$self->encode($self->{channel}->{description}).''."\n"; - - # language - if ($self->{channel}->{'dc'}->{'language'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'language'}).''."\n"; - } elsif ($self->{channel}->{language}) { - $output .= ''.$self->encode($self->{channel}->{language}).''."\n"; - } - - # PICS rating - # Not supported by RSS 2.0 - # $output .= ''.$self->{channel}->{rating}.''."\n" - # if $self->{channel}->{rating}; - - # copyright - if ($self->{channel}->{'dc'}->{'rights'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'rights'}).''."\n"; - } elsif ($self->{channel}->{copyright}) { - $output .= ''.$self->encode($self->{channel}->{copyright}).''."\n"; - } - - # publication date - if ($self->{channel}->{pubDate}) { - $output .= ''.$self->encode($self->{channel}->{pubDate}).''."\n"; - } elsif ($self->{channel}->{'dc'}->{'date'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'date'}).''."\n"; - } - - # last build date - if ($self->{channel}->{'dc'}->{'date'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{lastBuildDate}).''."\n"; - } elsif ($self->{channel}->{lastBuildDate}) { - $output .= ''.$self->encode($self->{channel}->{lastBuildDate}).''."\n"; - } - - # external CDF URL - $output .= ''.$self->encode($self->{channel}->{docs}).''."\n" - if $self->{channel}->{docs}; - - # managing editor - if ($self->{channel}->{'dc'}->{'publisher'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'publisher'}).''."\n"; - } elsif ($self->{channel}->{managingEditor}) { - $output .= ''.$self->encode($self->{channel}->{managingEditor}).''."\n"; - } - - # webmaster - if ($self->{channel}->{'dc'}->{'creator'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'creator'}).''."\n"; - } elsif ($self->{channel}->{webMaster}) { - $output .= ''.$self->encode($self->{channel}->{webMaster}).''."\n"; - } - - # category - if ($self->{channel}->{'dc'}->{'category'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'category'}).''."\n"; - } elsif ($self->{channel}->{category}) { - $output .= ''.$self->encode($self->{channel}->{generator}).''."\n"; - } - - # generator - if ($self->{channel}->{'dc'}->{'generator'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'generator'}).''."\n"; - } elsif ($self->{channel}->{generator}) { - $output .= ''.$self->encode($self->{channel}->{generator}).''."\n"; - } - - # Insert cloud support here - - # ttl - if ($self->{channel}->{'dc'}->{'ttl'}) { - $output .= ''.$self->encode($self->{channel}->{'dc'}->{'ttl'}).''."\n"; - } elsif ($self->{channel}->{ttl}) { - $output .= ''.$self->encode($self->{channel}->{ttl}).''."\n"; - } - - - - $output .= "\n"; - - ################# - # image element # - ################# - if ($self->{image}->{url}) { - $output .= ''."\n"; - - # title - $output .= ''.$self->encode($self->{image}->{title}).''."\n"; - - # url - $output .= ''.$self->encode($self->{image}->{url}).''."\n"; - - # link - $output .= ''.$self->encode($self->{image}->{'link'}).''."\n" - if $self->{image}->{link}; - - # image width - $output .= ''.$self->encode($self->{image}->{width}).''."\n" - if $self->{image}->{width}; - - # image height - $output .= ''.$self->encode($self->{image}->{height}).''."\n" - if $self->{image}->{height}; - - # description - $output .= ''.$self->encode($self->{image}->{description}).''."\n" - if $self->{image}->{description}; - - # end image element - $output .= ''."\n\n"; - } - - ################ - # item element # - ################ - foreach my $item (@{$self->{items}}) { - if ($item->{title}) { - $output .= ''."\n"; - $output .= ''.$self->encode($item->{title}).''."\n" - if $item->{title}; - $output .= ''.$self->encode($item->{'link'}).''."\n" - if $item->{link}; - $output .= ''.$self->encode($item->{description}).''."\n" - if $item->{description}; - - $output .= ''.$self->encode($item->{author}).''."\n" - if $item->{author}; - - $output .= ''.$self->encode($item->{category}).''."\n" - if $item->{category}; - - $output .= ''.$self->encode($item->{comments}).''."\n" - if $item->{comments}; - - # The unique identifier. Use 'permaLink' for an external - # identifier, or 'guid' for a internal string. - # (I call it permaLink in the hash for purposes of clarity.) - if ($item->{permaLink}) - { - $output .= ''.$self->encode($item->{permaLink}).''."\n"; - } - elsif ($item->{guid}) - { - $output .= ''.$self->encode($item->{guid}).''."\n"; - } - - $output .= ''.$self->encode($item->{pubDate}).''."\n" - if $item->{pubDate}; - - $output .= ''.$item->{source}.''."\n" - if $item->{source} && $item->{sourceUrl}; - - if (my $e = $item->{enclosure}) - { - $output .= "' . "\n"; - } - - # end image element - $output .= ''."\n\n"; - } - } - - ##################### - # textinput element # - ##################### - if ($self->{textinput}->{'link'}) { - $output .= ''."\n"; - $output .= ''.$self->encode($self->{textinput}->{title}).''."\n"; - $output .= ''.$self->encode($self->{textinput}->{description}).''."\n"; - $output .= ''.$self->encode($self->{textinput}->{name}).''."\n"; - $output .= ''.$self->encode($self->{textinput}->{'link'}).''."\n"; - $output .= ''."\n\n"; - } - - ##################### - # skipHours element # - ##################### - if ($self->{skipHours}->{hour}) { - $output .= ''."\n"; - $output .= ''.$self->encode($self->{skipHours}->{hour}).''."\n"; - $output .= ''."\n\n"; - } - - #################### - # skipDays element # - #################### - if ($self->{skipDays}->{day}) { - $output .= ''."\n"; - $output .= ''.$self->encode($self->{skipDays}->{day}).''."\n"; - $output .= ''."\n\n"; - } - - # end channel element - $output .= ''."\n"; - $output .= ''; - - return $output; -} - -sub as_string { - my $self = shift; - my $version = ($self->{output} =~ /\d/) ? $self->{output} : $self->{version}; - my $output; - - ########### - # RSS 0.9 # - ########### - if ($version eq '0.9') { - $output = &as_rss_0_9($self); - - ############ - # RSS 0.91 # - ############ - } elsif ($version eq '0.91') { - $output = &as_rss_0_9_1($self); - - ########### - # RSS 2.0 # - ########### - } elsif ($version eq '2.0') { - $output = &as_rss_2_0($self); - - ########### - # RSS 1.0 # - ########### - } else { - $output = &as_rss_1_0($self); - } - - return $output; -} - -sub handle_char { - # removed assumption that RSS is the default namespace - kellan, 11/5/02 - - my ($self,$cdata) = (@_); - - # image element - if ( - $self->within_element("image") || - $self->within_element($self->generate_ns_name("image",$self->{rss_namespace})) - ) { - my $ns = $self->namespace($self->current_element); - # If it's in the default namespace - if ( - (!$ns && !$self->{rss_namespace}) || - ($ns eq $self->{rss_namespace}) - ) { - $self->{'image'}->{$self->current_element} .= $cdata; - } - else { - # If it's in another namespace - $self->{'image'}->{$ns}->{$self->current_element} .= $cdata; - - # If it's in a module namespace, provide a friendlier prefix duplicate - $modules->{$ns} and $self->{'image'}->{$modules->{$ns}}->{$self->current_element} .= $cdata; - } - - # item element - } - elsif ( - $self->within_element("item") - || $self->within_element($self->generate_ns_name("item",$self->{rss_namespace})) - - ) { - return if $self->within_element($self->generate_ns_name("topics",'http://purl.org/rss/1.0/modules/taxonomy/')); - - my $ns = $self->namespace($self->current_element); - - # If it's in the default RSS 1.0 namespace - if ( - (!$ns && !$self->{rss_namespace}) || - ($ns eq $self->{rss_namespace}) - ) { - $self->{'items'}->[$self->{num_items}-1]->{$self->current_element} .= $cdata; - } else { - # If it's in another namespace - $self->{'items'}->[$self->{num_items}-1]->{$ns}->{$self->current_element} .= $cdata; - - # If it's in a module namespace, provide a friendlier prefix duplicate - $modules->{$ns} and - $self->{'items'}->[$self->{num_items}-1]->{$modules->{$ns}}->{$self->current_element} .= $cdata; - } - - # textinput element - } elsif ( - $self->within_element("textinput") - || $self->within_element($self->generate_ns_name("textinput",$self->{rss_namespace})) - ) { - my $ns = $self->namespace($self->current_element); - - # If it's in the default namespace - if ( - (!$ns && !$self->{rss_namespace}) || - ($ns eq $self->{rss_namespace}) - ) { - $self->{'textinput'}->{$self->current_element} .= $cdata; - } - else { - # If it's in another namespace - $self->{'textinput'}->{$ns}->{$self->current_element} .= $cdata; - - # If it's in a module namespace, provide a friendlier prefix duplicate - $modules->{$ns} and $self->{'textinput'}->{$modules->{$ns}}->{$self->current_element} .= $cdata; - } - - # skipHours element - } elsif ( - $self->within_element("skipHours") || - $self->within_element($self->generate_ns_name("skipHours",$self->{rss_namespace})) - ) { - $self->{'skipHours'}->{$self->current_element} .= $cdata; - - # skipDays element - } elsif ( - $self->within_element("skipDays") || - $self->within_element($self->generate_ns_name("skipDays",$self->{rss_namespace})) - ) { - $self->{'skipDays'}->{$self->current_element} .= $cdata; - - # channel element - } elsif ( - $self->within_element("channel") || - $self->within_element($self->generate_ns_name("channel",$self->{rss_namespace})) - ) { - return if $self->within_element($self->generate_ns_name("topics",'http://purl.org/rss/1.0/modules/taxonomy/')); - - my $ns = $self->namespace($self->current_element); - - # If it's in the default namespace - if ( - (!$ns && !$self->{rss_namespace}) || - ($ns eq $self->{rss_namespace}) - ) { - $self->{'channel'}->{$self->current_element} .= $cdata; - } else { - # If it's in another namespace - $self->{'channel'}->{$ns}->{$self->current_element} .= $cdata; - - # If it's in a module namespace, provide a friendlier prefix duplicate - $modules->{$ns} and $self->{'channel'}->{$modules->{$ns}}->{$self->current_element} .= $cdata; - } - } -} - -sub handle_dec { - my ($self,$version,$encoding,$standalone) = (@_); - $self->{encoding} = $encoding; - #print "ENCODING: $encoding\n"; -} - -sub handle_start { - my $self = shift; - my $el = shift; - my %attribs = @_; - - # beginning of RSS 0.91 - if ($el eq 'rss') { - if (exists($attribs{version})) { - $self->{_internal}->{version} = $attribs{version}; - } else { - croak "Malformed RSS: invalid version\n"; - } - - # beginning of RSS 1.0 or RSS 0.9 - } elsif ($el eq 'RDF') { - my @prefixes = $self->new_ns_prefixes; - foreach my $prefix (@prefixes) { - my $uri = $self->expand_ns_prefix($prefix); - $self->{namespaces}->{$prefix} = $uri; - #print "$prefix = $uri\n"; - } - - # removed assumption that RSS is the default namespace - kellan, 11/5/02 - # - foreach my $uri ( values %{ $self->{namespaces} } ) { - if ( $namespace_map->{'rss10'} eq $uri ) { - $self->{_internal}->{version} = '1.0'; - $self->{rss_namespace} = $uri; - last; - } - elsif ( $namespace_map->{'rss09'} eq $uri ) { - $self->{_internal}->{version} = '0.9'; - $self->{rss_namespace} = $uri; - last; - } - } - - # failed to match a namespace - if ( !defined($self->{_internal}->{version}) ) { - croak "Malformed RSS: invalid version\n" - } - #if ($self->expand_ns_prefix('#default') =~ /\/1.0\//) { - # $self->{_internal}->{version} = '1.0'; - #} elsif ($self->expand_ns_prefix('#default') =~ /\/0.9\//) { - # $self->{_internal}->{version} = '0.9'; - #} else { - # croak "Malformed RSS: invalid version\n"; - #} - - # beginning of item element - } elsif ($el eq 'item') { - # deal with trouble makers who use mod_content :) - my $ns = $self->namespace( $el ); - - if ( - (!$ns && !$self->{rss_namespace}) || - ($ns eq $self->{rss_namespace}) - ) { - # increment item count - $self->{num_items}++; - } - # beginning of taxo li element in item element - #'http://purl.org/rss/1.0/modules/taxonomy/' => 'taxo' - } elsif ($self->within_element($self->generate_ns_name("topics",'http://purl.org/rss/1.0/modules/taxonomy/')) - && $self->within_element($self->generate_ns_name("item",$self->{namespace_map}->{'rss10'})) - && $self->current_element eq 'Bag' - && $el eq 'li') { - #print "taxo: ", $attribs{'resource'},"\n"; - push(@{$self->{'items'}->[$self->{num_items}-1]->{'taxo'}},$attribs{'resource'}); - $self->{'modules'}->{'http://purl.org/rss/1.0/modules/taxonomy/'} = 'taxo'; - - # beginning of taxo li in channel element - } elsif ($self->within_element($self->generate_ns_name("topics",'http://purl.org/rss/1.0/modules/taxonomy/')) - && $self->within_element($self->generate_ns_name("channel",$self->{namespace_map}->{'rss10'})) - && $self->current_element eq 'Bag' - && $el eq 'li') { - push(@{$self->{'channel'}->{'taxo'}},$attribs{'resource'}); - $self->{'modules'}->{'http://purl.org/rss/1.0/modules/taxonomy/'} = 'taxo'; - } - # beginning of a channel element that stores its info in rdf:resource - elsif ( $self->namespace($el) and - exists( $rdf_resource_fields{ $self->namespace($el) } ) and - exists( $rdf_resource_fields{ $self->namespace($el) }{ $el } ) and - $self->current_element eq 'channel' ) - { - my $ns = $self->namespace( $el ); - - if ( $ns eq $self->{rss_namespace} ) { - $self->{channel}->{$el} = $attribs{resource}; - } - else { - $self->{channel}->{$ns}->{$el} = $attribs{resource}; - # add short cut - # - if ( exists( $modules->{ $ns } ) ) { - $ns = $modules->{ $ns }; - $self->{channel}->{$ns}->{$el} = $attribs{resource}; - } - } - } - # beginning of an item element that stores its info in rdf:resource - elsif ( $self->namespace($el) and - exists( $rdf_resource_fields{ $self->namespace($el) } ) and - exists( $rdf_resource_fields{ $self->namespace($el) }{ $el } ) and - $self->current_element eq 'item' ) - { - my $ns = $self->namespace( $el ); - - if ( $ns eq $self->{rss_namespace} ) { - $self->{'items'}->[$self->{num_items}-1]->{ $el } = $attribs{resource}; - } else { - $self->{'items'}->[$self->{num_items}-1]->{$ns}->{ $el } = $attribs{resource}; - - # add short cut - # - if ( exists( $modules->{ $ns } ) ) { - $ns = $modules->{ $ns }; - $self->{'items'}->[$self->{num_items}-1]->{$ns}->{ $el } = $attribs{resource}; - } - } - } -} - -sub append { - my($self, $inside, $cdata) = @_; - - my $ns = $self->namespace($self->current_element); - - # If it's in the default RSS 1.0 namespace - if ($ns eq 'http://purl.org/rss/1.0/') { - #$self->{'items'}->[$self->{num_items}-1]->{$self->current_element} .= $cdata; - $inside->{$self->current_element} .= $cdata; - } - - # If it's in another namespace - #$self->{'items'}->[$self->{num_items}-1]->{$ns}->{$self->current_element} .= $cdata; - $inside->{$ns}->{$self->current_element} .= $cdata; - - # If it's in a module namespace, provide a friendlier prefix duplicate - #$modules->{$ns} and $self->{'items'}->[$self->{num_items}-1]->{$modules->{$ns}}->{$self->current_element} .= $cdata; - $modules->{$ns} and $inside->{$modules->{$ns}}->{$self->current_element} .= $cdata; - - return $inside; -} - -sub _auto_add_modules { - my $self = shift; - - for my $ns (keys %{$self->{namespaces}}) { - # skip default namespaces - next if $ns eq "rdf" || $ns eq "#default" - || exists $self->{modules}{ $self->{namespaces}{$ns} }; - $self->add_module(prefix => $ns, uri => $self->{namespaces}{$ns}) - } - - $self; -} - -sub parse { - my $self = shift; - $self->_initialize((%$self)); - $self->SUPER::parse(shift); - $self->_auto_add_modules if $AUTO_ADD; - $self->{version} = $self->{_internal}->{version}; -} - -sub parsefile { - my $self = shift; - $self->_initialize((%$self)); - $self->SUPER::parsefile(shift); - $self->_auto_add_modules if $AUTO_ADD; - $self->{version} = $self->{_internal}->{version}; -} - -sub save { - my ($self,$file) = @_; - open(OUT,">$file") || croak "Cannot open file $file for write: $!"; - print OUT $self->as_string; - close OUT; -} - -sub strict { - my ($self,$value) = @_; - $self->{'strict'} = $value; -} - -sub AUTOLOAD { - my $self = shift; - my $type = ref($self) || croak "$self is not an object\n"; - my $name = $AUTOLOAD; - $name =~ s/.*://; - return if $name eq 'DESTROY'; - - croak "Unregistered entity: Can't access $name field in object of class $type" - unless (exists $self->{$name}); - - # return reference to RSS structure - if (@_ == 1) { - return $self->{$name}->{$_[0]} if defined $self->{$name}->{$_[0]}; - - # we're going to set values here - } elsif (@_ > 1) { - my %hash = @_; - my $_REQ; - - # make sure we have required elements and correct lengths - if ($self->{'strict'}) { - ($self->{version} eq '0.9') - ? ($_REQ = $_REQ_v0_9) - : ($_REQ = $_REQ_v0_9_1); - } - - # store data in object - foreach my $key (keys(%hash)) { - if ($self->{'strict'}) { - my $req_element = $_REQ->{$name}->{$key}; - confess "$key cannot exceed " . $req_element->[1] . " characters in length" - if defined $req_element->[1] && length($hash{$key}) > $req_element->[1]; - } - $self->{$name}->{$key} = $hash{$key}; - } - - # return value - return $self->{$name}; - - # otherwise, just return a reference to the whole thing - } else { - return $self->{$name}; - } - return 0; - - # make sure we have all required elements - #foreach my $key (keys(%{$_REQ->{$name}})) { - #my $element = $_REQ->{$name}->{$key}; - #croak "$key is required in $name" - #if ($element->[0] == 1) && (!defined($hash{$key})); - #croak "$key cannot exceed ".$element->[1]." characters in length" - #unless length($hash{$key}) <= $element->[1]; - #} -} - -# the code here is a minorly tweaked version of code from -# Matts' rssmirror.pl script -# -my %entity = ( - nbsp => " ", - iexcl => "¡", - cent => "¢", - pound => "£", - curren => "¤", - yen => "¥", - brvbar => "¦", - sect => "§", - uml => "¨", - copy => "©", - ordf => "ª", - laquo => "«", - not => "¬", - shy => "­", - reg => "®", - macr => "¯", - deg => "°", - plusmn => "±", - sup2 => "²", - sup3 => "³", - acute => "´", - micro => "µ", - para => "¶", - middot => "·", - cedil => "¸", - sup1 => "¹", - ordm => "º", - raquo => "»", - frac14 => "¼", - frac12 => "½", - frac34 => "¾", - iquest => "¿", - Agrave => "À", - Aacute => "Á", - Acirc => "Â", - Atilde => "Ã", - Auml => "Ä", - Aring => "Å", - AElig => "Æ", - Ccedil => "Ç", - Egrave => "È", - Eacute => "É", - Ecirc => "Ê", - Euml => "Ë", - Igrave => "Ì", - Iacute => "Í", - Icirc => "Î", - Iuml => "Ï", - ETH => "Ð", - Ntilde => "Ñ", - Ograve => "Ò", - Oacute => "Ó", - Ocirc => "Ô", - Otilde => "Õ", - Ouml => "Ö", - times => "×", - Oslash => "Ø", - Ugrave => "Ù", - Uacute => "Ú", - Ucirc => "Û", - Uuml => "Ü", - Yacute => "Ý", - THORN => "Þ", - szlig => "ß", - agrave => "à", - aacute => "á", - acirc => "â", - atilde => "ã", - auml => "ä", - aring => "å", - aelig => "æ", - ccedil => "ç", - egrave => "è", - eacute => "é", - ecirc => "ê", - euml => "ë", - igrave => "ì", - iacute => "í", - icirc => "î", - iuml => "ï", - eth => "ð", - ntilde => "ñ", - ograve => "ò", - oacute => "ó", - ocirc => "ô", - otilde => "õ", - ouml => "ö", - divide => "÷", - oslash => "ø", - ugrave => "ù", - uacute => "ú", - ucirc => "û", - uuml => "ü", - yacute => "ý", - thorn => "þ", - yuml => "ÿ", - ); - -my $entities = join('|', keys %entity); - -sub encode { - my ($self, $text) = @_; - return $text unless $self->{'encode_output'}; - - my $encoded_text = ''; - - while ( $text =~ s/(.*?)(\<\!\[CDATA\[.*?\]\]\>)//s ) { - $encoded_text .= encode_text($1) . $2; - } - $encoded_text .= encode_text($text); - - return $encoded_text; -} - -sub encode_text { - my $text = shift; - - $text =~ s/&(?!(#[0-9]+|#x[0-9a-fA-F]+|\w+);)/&/g; - $text =~ s/&($entities);/$entity{$1}/g; - $text =~ s/ '1.0'); - $rss->channel( - title => "freshmeat.net", - link => "http://freshmeat.net", - description => "the one-stop-shop for all your Linux software needs", - dc => { - date => '2000-08-23T07:00+00:00', - subject => "Linux Software", - creator => 'scoop @ freshmeat.net', - publisher => 'scoop @ freshmeat.net', - rights => 'Copyright 1999, Freshmeat.net', - language => 'en-us', - }, - syn => { - updatePeriod => "hourly", - updateFrequency => "1", - updateBase => "1901-01-01T00:00+00:00", - }, - taxo => [ - 'http://dmoz.org/Computers/Internet', - 'http://dmoz.org/Computers/PC' - ] - ); - - $rss->image( - title => "freshmeat.net", - url => "http://freshmeat.net/images/fm.mini.jpg", - link => "http://freshmeat.net", - dc => { - creator => "G. Raphics (graphics at freshmeat.net)", - }, - ); - - $rss->add_item( - title => "GTKeyboard 0.85", - link => "http://freshmeat.net/news/1999/06/21/930003829.html", - description => "GTKeyboard is a graphical keyboard that ...", - dc => { - subject => "X11/Utilities", - creator => "David Allen (s2mdalle at titan.vcu.edu)", - }, - taxo => [ - 'http://dmoz.org/Computers/Internet', - 'http://dmoz.org/Computers/PC' - ] - ); - - $rss->textinput( - title => "quick finder", - description => "Use the text input below to search freshmeat", - name => "query", - link => "http://core.freshmeat.net/search.php3", - ); - - # Optionally mixing in elements of a non-standard module/namespace - - $rss->add_module(prefix=>'my', uri=>'http://purl.org/my/rss/module/'); - - $rss->add_item( - title => "xIrc 2.4pre2", - link => "http://freshmeat.net/projects/xirc/", - description => "xIrc is an X11-based IRC client which ...", - my => { - rating => "A+", - category => "X11/IRC", - }, - ); - - $rss->add_item (title=>$title, link=>$link, slash=>{ topic=>$topic }); - - # create an RSS 2.0 file - use XML::RSS; - my $rss = new XML::RSS (version => '2.0'); - $rss->channel(title => 'freshmeat.net', - link => 'http://freshmeat.net', - language => 'en', - description => 'the one-stop-shop for all your Linux software needs', - rating => '(PICS-1.1 "http://www.classify.org/safesurf/" 1 r (SS~~000 1))', - copyright => 'Copyright 1999, Freshmeat.net', - pubDate => 'Thu, 23 Aug 1999 07:00:00 GMT', - lastBuildDate => 'Thu, 23 Aug 1999 16:20:26 GMT', - docs => 'http://www.blahblah.org/fm.cdf', - managingEditor => 'scoop @ freshmeat.net', - webMaster => 'scoop @ freshmeat.net' - ); - - $rss->image(title => 'freshmeat.net', - url => 'http://freshmeat.net/images/fm.mini.jpg', - link => 'http://freshmeat.net', - width => 88, - height => 31, - description => 'This is the Freshmeat image stupid' - ); - - $rss->add_item(title => "GTKeyboard 0.85", - # creates a guid field with permaLink=true - permaLink => "http://freshmeat.net/news/1999/06/21/930003829.html", - # alternately creates a guid field with permaLink=false - # guid => "gtkeyboard-0.85 - enclosure => { url=>$url, type=>"application/x-bittorrent" }, - description => 'blah blah' -); - - $rss->textinput(title => "quick finder", - description => "Use the text input below to search freshmeat", - name => "query", - link => "http://core.freshmeat.net/search.php3" - ); - - # create an RSS 0.9 file - use XML::RSS; - my $rss = new XML::RSS (version => '0.9'); - $rss->channel(title => "freshmeat.net", - link => "http://freshmeat.net", - description => "the one-stop-shop for all your Linux software needs", - ); - - $rss->image(title => "freshmeat.net", - url => "http://freshmeat.net/images/fm.mini.jpg", - link => "http://freshmeat.net" - ); - - $rss->add_item(title => "GTKeyboard 0.85", - link => "http://freshmeat.net/news/1999/06/21/930003829.html" - ); - - $rss->textinput(title => "quick finder", - description => "Use the text input below to search freshmeat", - name => "query", - link => "http://core.freshmeat.net/search.php3" - ); - - # print the RSS as a string - print $rss->as_string; - - # or save it to a file - $rss->save("fm.rdf"); - - # insert an item into an RSS file and removes the oldest item if - # there are already 15 items - my $rss = new XML::RSS; - $rss->parsefile("fm.rdf"); - pop(@{$rss->{'items'}}) if (@{$rss->{'items'}} == 15); - $rss->add_item(title => "MpegTV Player (mtv) 1.0.9.7", - link => "http://freshmeat.net/news/1999/06/21/930003958.html", - mode => 'insert' - ); - - # parse a string instead of a file - $rss->parse($string); - - # print the title and link of each RSS item - foreach my $item (@{$rss->{'items'}}) { - print "title: $item->{'title'}\n"; - print "link: $item->{'link'}\n\n"; - } - - # output the RSS 0.9 or 0.91 file as RSS 1.0 - $rss->{output} = '1.0'; - print $rss->as_string; - -=head1 DESCRIPTION - -This module provides a basic framework for creating and maintaining -RDF Site Summary (RSS) files. This distribution also contains many -examples that allow you to generate HTML from an RSS, convert between -0.9, 0.91, and 1.0 version, and other nifty things. -This might be helpful if you want to include news feeds on your Web -site from sources like Slashot and Freshmeat or if you want to syndicate -your own content. - -XML::RSS currently supports 0.9, 0.91, and 1.0 versions of RSS. -See http://my.netscape.com/publish/help/mnn20/quickstart.html -for information on RSS 0.91. See http://my.netscape.com/publish/help/ -for RSS 0.9. See http://purl.org/rss/1.0/ for RSS 1.0. - -RSS was originally developed by Netscape as the format for -Netscape Netcenter channels, however, many Web sites have since -adopted it as a simple syndication format. With the advent of RSS 1.0, -users are now able to syndication many different kinds of content -including news headlines, threaded measages, products catalogs, etc. - -=head1 METHODS - -=over 4 - -=item new XML::RSS (version=>$version, encoding=>$encoding, -output=>$output) - -Constructor for XML::RSS. It returns a reference to an XML::RSS object. -You may also pass the RSS version and the XML encoding to use. The default -B is 1.0. The default B is UTF-8. You may also specify -the B format regarless of the input version. This comes in handy -when you want to convert RSS between versions. The XML::RSS modules -will convert between any of the formats. If you set XML::RSS -will make sure to encode any entities in generated RSS. This is now on by default. - -=item add_item (title=>$title, link=>$link, description=>$desc, mode=>$mode) - -Adds an item to the XML::RSS object. B and B are optional. -The default B -is append, which adds the item to the end of the list. To insert an item, set the mode -to B. - -The items are stored in the array @{$obj->{'items'}} where -B<$obj> is a reference to an XML::RSS object. - -=item as_string; - -Returns a string containing the RSS for the XML::RSS object. This -method will also encode special characters along the way. - -=item channel (title=>$title, link=>$link, description=>$desc, -language=>$language, rating=>$rating, copyright=>$copyright, -pubDate=>$pubDate, lastBuildDate=>$lastBuild, docs=>$docs, -managingEditor=>$editor, webMaster=>$webMaster) - - -Channel information is required in RSS. The B cannot -be more the 40 characters, the B<link> 500, and the B<description> -500 when outputting RSS 0.9. B<title>, B<link>, and B<description>, -are required for RSS 1.0. B<language> is required for RSS 0.91. -The other parameters are optional for RSS 0.91 and 1.0. - -To retreive the values of the channel, pass the name of the value -(title, link, or description) as the first and only argument -like so: - -$title = channel('title'); - -=item image (title=>$title, url=>$url, link=>$link, width=>$width, -height=>$height, description=>$desc) - -Adding an image is not required. B<url> is the URL of the -image, B<link> is the URL the image is linked to. B<title>, B<url>, -and B<link> parameters are required if you are going to -use an image in your RSS file. The remaining image elements are used -in RSS 0.91 or optionally imported into RSS 1.0 via the rss091 namespace. - -The method for retrieving the values for the image is the same as it -is for B<channel()>. - -=item parse ($string) - -Parses an RDF Site Summary which is passed into B<parse()> as the first parameter. - -See the add_module() method for instructions on automatically adding -modules as a string is parsed. - -=item parsefile ($file) - -Same as B<parse()> except it parses a file rather than a string. - -See the add_module() method for instructions on automatically adding -modules as a string is parsed. - -=item save ($file) - -Saves the RSS to a specified file. - -=item strict ($boolean) - -If it's set to 1, it will adhere to the lengths as specified -by Netscape Netcenter requirements. It's set to 0 by default. -Use it if the RSS file you're generating is for Netcenter. -strict will only work for RSS 0.9 and 0.91. Do not use it for -RSS 1.0. - -=item textinput (title=>$title, description=>$desc, name=>$name, link=>$link); - -This RSS element is also optional. Using it allows users to submit a Query -to a program on a Web server via an HTML form. B<name> is the HTML form name -and B<link> is the URL to the program. Content is submitted using the GET -method. - -Access to the B<textinput> values is the the same as B<channel()> and -B<image()>. - -=item add_module(prefix=>$prefix, uri=>$uri) - -Adds a module namespace declaration to the XML::RSS object, allowing you -to add modularity outside of the the standard RSS 1.0 modules. At present, -the standard modules Dublin Core (dc) and Syndication (syn) are predefined -for your convenience. The Taxonomy (taxo) module is also internally supported. - -The modules are stored in the hash %{$obj->{'modules'}} where -B<$obj> is a reference to an XML::RSS object. - -If you want to automatically add modules that the parser finds in -namespaces, set the $XML::RSS::AUTO_ADD variable to a true value. By -default the value is false. (N.B. AUTO_ADD only updates the -%{$obj->{'modules'}} hash. It does not provide the other benefits -of using add_module.) - - - -=back - -=head2 RSS 1.0 MODULES - -XML-Namespace-based modularization affords RSS 1.0 compartmentalized -extensibility. The only modules that ship "in the box" with RSS 1.0 -are Dublin Core (http://purl.org/rss/1.0/modules/dc/), Syndication -(http://purl.org/rss/1.0/modules/syndication/), and Taxonomy -(http://purl.org/rss/1.0/modules/taxonomy/). Consult the appropriate -module's documentation for further information. - -Adding items from these modules in XML::RSS is as simple as adding other -attributes such as title, link, and description. The only difference -is the compartmentalization of their key/value paris in a second-level -hash. - - $rss->add_item (title=>$title, link=>$link, dc=>{ subject=>$subject, creator=>$creator }); - -For elements of the Dublin Core module, use the key 'dc'. For elements -of the Syndication module, 'syn'. For elements of the Taxonomy module, -'taxo'. These are the prefixes used in the RSS XML document itself. -They are associated with appropriate URI-based namespaces: - - syn: http://purl.org/rss/1.0/modules/syndication/ - dc: http://purl.org/dc/elements/1.1/ - taxo: http://purl.org/rss/1.0/modules/taxonomy/ - -Dublin Core elements may occur in channel, image, item(s), and textinput --- albeit uncomming to find them under image and textinput. Syndication -elements are limited to the channel element. Taxonomy elements can occur -in the channel or item elements. - -Access to module elements after parsing an RSS 1.0 document using -XML::RSS is via either the prefix or namespace URI for your convenience. - - print $rss->{items}->[0]->{dc}->{subject}; - - or - - print $rss->{items}->[0]->{'http://purl.org/dc/elements/1.1/'}->{subject}; - -XML::RSS also has support for "non-standard" RSS 1.0 modularization at -the channel, image, item, and textinput levels. Parsing an RSS document -grabs any elements of other namespaces which might appear. XML::RSS -also allows the inclusion of arbitrary namespaces and associated elements -when building RSS documents. - -For example, to add elements of a made-up "My" module, first declare the -namespace by associating a prefix with a URI: - - $rss->add_module(prefix=>'my', uri=>'http://purl.org/my/rss/module/'); - -Then proceed as usual: - - $rss->add_item (title=>$title, link=>$link, my=>{ rating=>$rating }); - -Non-standard namespaces are not, however, currently accessible via a simple -prefix; access them via their namespace URL like so: - - print $rss->{items}->[0]->{'http://purl.org/my/rss/module/'}->{rating}; - -XML::RSS will continue to provide built-in support for standard RSS 1.0 -modules as they appear. - -=head1 SOURCE AVAILABILITY - -This source is part of a SourceForge project which always has the -latest sources in CVS, as well as all of the previous releases. - - https://sourceforge.net/projects/perl-rss/ - http://perl-rss.sourceforge.net - -If, for some reason, I disappear from the world, one of the other -members of the project can shepherd this module appropriately. - -=head1 AUTHOR - - Original code: Jonathan Eisenzopf <eisen @ pobox.com> - Further changes: Rael Dornfest <rael @ oreilly.com> - - Currently: perl-rss project (http://perl-rss.sourceforge.net) - - -=head1 COPYRIGHT - -Copyright (c) 2001 Jonathan Eisenzopf <eisen @ pobox.com> -and Rael Dornfest <rael @ oreilly.com> - -XML::RSS is free software. You can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 CREDITS - - Wojciech Zwiefka <wojtekz @ cnt.pl> - Chris Nandor <pudge @ pobox.com> - Jim Hebert <jim @ cosource.com> - Randal Schwartz <merlyn @ stonehenge.com> - rjp @ browser.org - Kellan <kellan @ protest.net> - Rafe Colburn <rafe @ rafe.us> - Adam Trickett <adam.trickett @ btinternet.com> - Aaron Straup Cope <asc @ vineyard.net> - Ian Davis <iand @ internetalchemy.org> - rayg @ varchars.com - -=head1 SEE ALSO - -perl(1), XML::Parser(3). - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:52 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:52 +0900 Subject: [Affelio-cvs 668] CVS update: affelio_farm/admin/skelton/affelio/extlib/XML/Parser Message-ID: <20051024192052.4E52E2AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/XML/Parser/Lite.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XML/Parser/Lite.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XML/Parser/Lite.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XML/Parser/Lite.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XML/Parser/Lite.pm Tue Oct 25 04:20:52 2005 @@ -1,202 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: Lite.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package XML::Parser::Lite; - -use strict; -use vars qw($VERSION); -$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: $ =~ /-(\d+)_([\d_]+)/); - -sub new { - my $self = shift; - my $class = ref($self) || $self; - return $self if ref $self; - - $self = bless {} => $class; - my %parameters = @_; - $self->setHandlers(); # clear first - $self->setHandlers(%{$parameters{Handlers} || {}}); - return $self; -} - -sub setHandlers { - my $self = shift; - no strict 'refs'; local $^W; - # clear all handlers if called without parameters - unless (@_) { foreach (qw(Start End Char Final Init)) { *$_ = sub {} } } - while (@_) { my($name => $func) = splice(@_, 0, 2); *$name = defined $func ? $func : sub {} } - return $self; -} - -sub regexp { - my $patch = shift || ''; - my $package = __PACKAGE__; - - # This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html - - # Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions", - # Technical Report TR 1998-17, School of Computing Science, Simon Fraser University, November, 1998. - # Copyright (c) 1998, Robert D. Cameron. - # The following code may be freely used and distributed provided that - # this copyright and citation notice remains intact and that modifications - # or additions are clearly identified. - - my $TextSE = "[^<]+"; - my $UntilHyphen = "[^-]*-"; - my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-"; - my $CommentCE = "$Until2Hyphens>?"; - my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+"; - my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>"; - my $S = "[ \\n\\t\\r]+"; - my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]"; - my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]"; - my $Name = "(?:$NameStrt)(?:$NameChar)*"; - my $QuoteSE = "\"[^\"]*\"|'[^']*'"; - my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*"; - my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>"; - my $S1 = "[\\n\\r\\t ]"; - my $UntilQMs = "[^?]*\\?+"; - my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>"; - my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S"; - my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?"; - my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?"; - my $PI_CE = "$Name(?:$PI_Tail)?"; - - # these expressions were modified for backtracking and events - my $EndTagCE = "($Name)(?{${package}::end(\$2)})(?:$S)?>"; - my $AttValSE = "\"([^<\"]*)\"|'([^<']*)'"; - my $ElemTagCE = "($Name)(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)(?{[\@{\$^R||[]},\$4=>defined\$5?\$5:\$6]}))*(?:$S)?(/)?>(?{${package}::start(\$3,\@{\$^R||[]})})(?{\${7} and ${package}::end(\$3)})"; - my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)"; - - # Next expression is under "black magic". - # Ideally it should be '($TextSE)(?{${package}::char(\$1)})|$MarkupSPE', - # but it doesn't work under Perl 5.005 and only magic with - # (?:....)?? solved the problem. - # I would appreciate if someone let me know what is the right thing to do - # and what's the reason for all this magic. - # Seems like a problem related to (?:....)? rather than to ?{} feature. - # Tests are in t/31-xmlparserlite.t if you decide to play with it. - "(?:($TextSE)(?{${package}::char(\$1)}))$patch|$MarkupSPE"; -} - -sub compile { local $^W; - # try regexp as it should be, apply patch if doesn't work - foreach (regexp(), regexp('??')) { - eval qq{sub parse_re { use re "eval"; 1 while \$_[0] =~ m{$_}go }; 1} or die; - last if eval { parse_re('<foo>bar</foo>'); 1 } - }; - - *compile = sub {}; -} - -setHandlers(); -compile(); - -sub parse { - init(); - parse_re($_[1]); - final(); -} - -my(@stack, $level); - -sub init { - @stack = (); $level = 0; - Init(__PACKAGE__, @_); -} - -sub final { - die "not properly closed tag '$stack[-1]'\n" if @stack; - die "no element found\n" unless $level; - Final(__PACKAGE__, @_) -} - -sub start { - die "multiple roots, wrong element '$_[0]'\n" if $level++ && !@stack; - push(@stack, $_[0]); - Start(__PACKAGE__, @_); -} - -sub char { - Char(__PACKAGE__, $_[0]), return if @stack; - - # check for junk before or after element - # can't use split or regexp due to limitations in ?{} implementation, - # will iterate with loop, but we'll do it no more than two times, so - # it shouldn't affect performance - for (my $i=0; $i < length $_[0]; $i++) { - die "junk '$_[0]' @{[$level ? 'after' : 'before']} XML element\n" - if index("\n\r\t ", substr($_[0],$i,1)) < 0; # or should '< $[' be there - } -} - -sub end { - pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n"; - End(__PACKAGE__, $_[0]); -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -XML::Parser::Lite - Lightweight regexp-based XML parser - -=head1 SYNOPSIS - - use XML::Parser::Lite; - - $p1 = new XML::Parser::Lite; - $p1->setHandlers( - Start => sub { shift; print "start: @_\n" }, - Char => sub { shift; print "char: @_\n" }, - End => sub { shift; print "end: @_\n" }, - ); - $p1->parse('<foo id="me">Hello World!</foo>'); - - $p2 = new XML::Parser::Lite - Handlers => { - Start => sub { shift; print "start: @_\n" }, - Char => sub { shift; print "char: @_\n" }, - End => sub { shift; print "end: @_\n" }, - } - ; - $p2->parse('<foo id="me">Hello <bar>cruel</bar> World!</foo>'); - -=head1 DESCRIPTION - -This Perl module gives you access to XML parser with interface similar to -XML::Parser interface. Though only basic calls are supported (init, final, -start, char, and end) you should be able to use it in the same way you use -XML::Parser. Due to using experimantal regexp features it'll work only on -Perl 5.6 and may behave differently on different platforms. - -=head1 SEE ALSO - - XML::Parser - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html -Copyright (c) 1998, Robert D. Cameron. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:52 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:52 +0900 Subject: [Affelio-cvs 669] CVS update: affelio_farm/admin/skelton/affelio/extlib/XMLRPC Message-ID: <20051024192052.746042AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Lite.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Lite.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Lite.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Lite.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Lite.pm Tue Oct 25 04:20:52 2005 @@ -1,420 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: Lite.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package XMLRPC::Lite; - -use SOAP::Lite; -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -# ====================================================================== - -package XMLRPC::Constants; - -BEGIN { - no strict 'refs'; - for (qw( - FAULT_CLIENT FAULT_SERVER - HTTP_ON_SUCCESS_CODE HTTP_ON_FAULT_CODE - DO_NOT_USE_XML_PARSER DO_NOT_USE_CHARSET - DO_NOT_USE_LWP_LENGTH_HACK DO_NOT_CHECK_CONTENT_TYPE - )) { - *$_ = \${'SOAP::Constants::' . $_} - } - # XML-RPC spec requires content-type to be "text/xml" - $XMLRPC::Constants::DO_NOT_USE_CHARSET = 1; -} - -# ====================================================================== - -package XMLRPC::Data; - - @ XMLRPC::Data::ISA = qw(SOAP::Data); - -# ====================================================================== - -package XMLRPC::Serializer; - - @ XMLRPC::Serializer::ISA = qw(SOAP::Serializer); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new( - typelookup => { - base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'], - int => [20, sub {$_[0] =~ /^[+-]?\d+$/}, 'as_int'], - double => [30, sub {$_[0] =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/}, 'as_double'], - dateTime => [35, sub {$_[0] =~ /^\d{8}T\d\d:\d\d:\d\d$/}, 'as_dateTime'], - string => [40, sub {1}, 'as_string'], - }, - attr => {}, - namespaces => {}, - @_, - ); - } - return $self; -} - -sub envelope { - my $self = shift->new; - my $type = shift; - - my($body); - if ($type eq 'method' || $type eq 'response') { - my $method = shift or die "Unspecified method for XMLRPC call\n"; - if ($type eq 'response') { - $body = XMLRPC::Data->name(methodResponse => \XMLRPC::Data->value( - XMLRPC::Data->type(params => [@_]) - )); - } else { - $body = XMLRPC::Data->name(methodCall => \XMLRPC::Data->value( - XMLRPC::Data->type(methodName => UNIVERSAL::isa($method => 'XMLRPC::Data') ? $method->name : $method), - XMLRPC::Data->type(params => [@_]) - )); - } - } elsif ($type eq 'fault') { - $body = XMLRPC::Data->name(methodResponse => - \XMLRPC::Data->type(fault => {faultCode => $_[0], faultString => $_[1]}), - ); - } else { - die "Wrong type of envelope ($type) for XMLRPC call\n"; - } - - $self->xmlize($self->encode_object($body)); -} - -sub encode_object { - my $self = shift; - my @encoded = $self->SUPER::encode_object(@_); - return $encoded[0]->[0] =~ /^(?:array|struct|i4|int|boolean|string|double|dateTime\.iso8601|base64)$/o - ? ['value', {}, [@encoded]] : @encoded; -} - -sub encode_scalar { - my $self = shift; - return ['value', {}] unless defined $_[0]; - return $self->SUPER::encode_scalar(@_); -} - -sub encode_array { - my($self, $array) = @_; - - return ['array', {}, [ - ['data', {}, [map {$self->encode_object($_)} @$array]] - ]]; -} - -sub encode_hash { - my($self, $hash) = @_; - - return ['struct', {}, [ - map { - ['member', {}, [['name', {}, $_], $self->encode_object($hash->{$_})]] - } keys %$hash - ]]; -} - -sub as_methodName { - my $self = shift; - my($value, $name, $type, $attr) = @_; - return ['methodName', $attr, $value]; -} - -sub as_params { - my $self = shift; - my($params, $name, $type, $attr) = @_; - - return ['params', $attr, [ - map { - ['param', {}, [$self->encode_object($_)]] - } @$params - ]]; -} - -sub as_fault { - my($self, $fault) = @_; - - return ['fault', {}, [$self->encode_object($fault)]]; -} - -sub BEGIN { - no strict 'refs'; - for my $type (qw(double i4 int)) { - my $method = 'as_' . $type; - *$method = sub { - my($self, $value) = @_; - return [$type, {}, $value]; - } - } -} - -sub as_base64 { - my $self = shift; - my $value = shift; - require MIME::Base64; - return ['base64', {}, MIME::Base64::encode_base64($value,'')]; -} - -sub as_string { - my $self = shift; - my $value = shift; - return ['string', {}, SOAP::Utils::encode_data($value)]; -} - -sub as_dateTime { - my $self = shift; - my $value = shift; - return ['dateTime.iso8601', {}, $value]; -} - -sub as_boolean { - my $self = shift; - my $value = shift; - return ['boolean', {}, $value ? 1 : 0]; -} - -sub typecast { - my $self = shift; - my($value, $name, $type, $attr) = @_; - - die "Wrong/unsupported datatype '$type' specified\n" if defined $type; - - $self->SUPER::typecast(@_); -} - -# ====================================================================== - -package XMLRPC::SOM; - - @ XMLRPC::SOM::ISA = qw(SOAP::SOM); - -sub BEGIN { - no strict 'refs'; - my %path = ( - root => '/', - envelope => '/[1]', - method => '/methodCall/methodName', - fault => '/methodResponse/fault', - ); - for my $method (keys %path) { - *$method = sub { - my $self = shift; - ref $self or return $path{$method}; - Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; - $self->valueof($path{$method}); - }; - } - my %fault = ( - faultcode => 'faultCode', - faultstring => 'faultString', - ); - for my $method (keys %fault) { - *$method = sub { - my $self = shift; - ref $self or Carp::croak "Method '$method' doesn't have shortcut"; - Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; - defined $self->fault ? $self->fault->{$fault{$method}} : undef; - }; - } - my %results = ( - result => '/methodResponse/params/[1]', - paramsin => '/methodCall/params/param', - paramsall => '/methodResponse/params/param', - ); - for my $method (keys %results) { - *$method = sub { - my $self = shift; - ref $self or return $results{$method}; - Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_; - defined $self->fault ? undef : $self->valueof($results{$method}); - }; - } -} - -# ====================================================================== - -package XMLRPC::Deserializer; - - @ XMLRPC::Deserializer::ISA = qw(SOAP::Deserializer); - -BEGIN { - no strict 'refs'; - for my $method (qw(o_child o_qname o_chars)) { # import from SOAP::Utils - *$method = \&{'SOAP::Utils::'.$method}; - } -} - -sub deserialize { - bless shift->SUPER::deserialize(@_) => 'XMLRPC::SOM'; -} - -sub decode_value { - my $self = shift; - my $ref = shift; - my($name, $attrs, $children, $value) = @$ref; - - if ($name eq 'value') { - $children ? scalar(($self->decode_object($children->[0]))[1]) : $value; - } elsif ($name eq 'array') { - return [map {scalar(($self->decode_object($_))[1])} @{o_child($children->[0]) || []}]; - } elsif ($name eq 'struct') { - return {map { - my %hash = map {o_qname($_) => $_} @{o_child($_) || []}; - # v----- scalar is required here, because 5.005 evaluates 'undef' in list context as empty array - (o_chars($hash{name}) => scalar(($self->decode_object($hash{value}))[1])); - } @{$children || []}}; - } elsif ($name eq 'base64') { - require MIME::Base64; - MIME::Base64::decode_base64($value); - } elsif ($name =~ /^(?:int|i4|boolean|string|double|dateTime\.iso8601|methodName)$/) { - return $value; - } elsif ($name =~ /^(?:params)$/) { - return [map {scalar(($self->decode_object($_))[1])} @{$children || []}]; - } elsif ($name =~ /^(?:methodResponse|methodCall)$/) { - return +{map {$self->decode_object($_)} @{$children || []}}; - } elsif ($name =~ /^(?:param|fault)$/) { - return scalar(($self->decode_object($children->[0]))[1]); - } else { - die "wrong element '$name'\n"; - } -} - -# ====================================================================== - -package XMLRPC::Server; - - @ XMLRPC::Server::ISA = qw(SOAP::Server); - -sub initialize { - return ( - deserializer => XMLRPC::Deserializer->new, - serializer => XMLRPC::Serializer->new, - on_action => sub {}, - on_dispatch => sub { return map {s!\.!/!g; $_} shift->method =~ /^(?:(.*)\.)?(\w+)$/ }, - ); -} - -# ====================================================================== - -package XMLRPC::Server::Parameters; - - @ XMLRPC::Server::Parameters::ISA = qw(SOAP::Server::Parameters); - -# ====================================================================== - -package XMLRPC; - - @ XMLRPC::ISA = qw(SOAP); - -# ====================================================================== - -package XMLRPC::Lite; - - @ XMLRPC::Lite::ISA = qw(SOAP::Lite); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new( - serializer => XMLRPC::Serializer->new, - deserializer => XMLRPC::Deserializer->new, - on_action => sub {return}, - uri => 'http://unspecified/', - @_ - ); - } - return $self; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -XMLRPC::Lite - client and server implementation of XML-RPC protocol - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use XMLRPC::Lite; - print XMLRPC::Lite - -> proxy('http://betty.userland.com/RPC2') - -> call('examples.getStateStruct', {state1 => 12, state2 => 28}) - -> result; - -=item CGI server - - use XMLRPC::Transport::HTTP; - - my $server = XMLRPC::Transport::HTTP::CGI - -> dispatch_to('methodName') - -> handle - ; - -=item Daemon server - - use XMLRPC::Transport::HTTP; - - my $daemon = XMLRPC::Transport::HTTP::Daemon - -> new (LocalPort => 80) - -> dispatch_to('methodName') - ; - print "Contact to XMLRPC server at ", $daemon->url, "\n"; - $daemon->handle; - -=back - -=head1 DESCRIPTION - -XMLRPC::Lite is a Perl modules which provides a simple nterface to the -XML-RPC protocol both on client and server side. Based on SOAP::Lite module, -it gives you access to all features and transports available in that module. - -See F<t/26-xmlrpc.t> for client examples and F<examples/XMLRPC/*> for server -implementations. - -=head1 DEPENDENCIES - - SOAP::Lite - -=head1 SEE ALSO - - SOAP::Lite - -=head1 CREDITS - -The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc. -See <http://www.xmlrpc.com> for more information about the B<XML-RPC> -specification. - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Test.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Test.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Test.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Test.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Test.pm Tue Oct 25 04:20:52 2005 @@ -1,190 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: Test.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package XMLRPC::Test; - -use 5.004; -use vars qw($VERSION $TIMEOUT); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -$TIMEOUT = 5; - -# ====================================================================== - -package My::PingPong; # we'll use this package in our tests - -sub new { - my $self = shift; - my $class = ref($self) || $self; - bless {_num=>shift} => $class; -} - -sub next { - my $self = shift; - $self->{_num}++; -} - -sub value { - my $self = shift; - $self->{_num}; -} - -# ====================================================================== - -package XMLRPC::Test::Server; - -use strict; -use Test; -use XMLRPC::Lite; - -sub run_for { - my $proxy = shift or die "Proxy/endpoint is not specified"; - - # ------------------------------------------------------ - my $s = XMLRPC::Lite->proxy($proxy)->on_fault(sub{}); - eval { $s->transport->timeout($XMLRPC::Test::TIMEOUT) }; - my $r = $s->test_connection; - - unless (defined $r && defined $r->envelope) { - print "1..0 # Skip: ", $s->transport->status, "\n"; - exit; - } - # ------------------------------------------------------ - - plan tests => 17; - - eval q!use XMLRPC::Lite on_fault => sub{ref $_[1] ? $_[1] : new XMLRPC::SOM}; 1! or die; - - print "Perl XMLRPC server test(s)...\n"; - - $s = XMLRPC::Lite - -> proxy($proxy) - ; - - ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); - ok($s->call('My.Examples.getStateNames', 1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/); - - $r = $s->call('My.Examples.getStateList', [1,2,3,4])->result; - ok(ref $r && $r->[0] eq 'Alabama'); - - $r = $s->call('My.Examples.getStateStruct', {item1 => 1, item2 => 4})->result; - ok(ref $r && $r->{item2} eq 'Arkansas'); - - print "dispatch_from test(s)...\n"; - eval "use XMLRPC::Lite - dispatch_from => ['A', 'B'], - proxy => '$proxy', - ; 1" or die; - - eval { C->c }; - ok($@ =~ /Can't locate object method "c"/); - - print "Object autobinding and XMLRPC:: prefix test(s)...\n"; - - eval "use XMLRPC::Lite +autodispatch => - proxy => '$proxy'; 1" or die; - - ok(XMLRPC::Lite->autodispatched); - - # forget everything - XMLRPC::Lite->self(undef); - - { - my $on_fault_was_called = 0; - print "Die in server method test(s)...\n"; - my $s = XMLRPC::Lite - -> proxy($proxy) - -> on_fault(sub{$on_fault_was_called++;return}) - ; - ok($s->call('My.Parameters.die_simply')->faultstring =~ /Something bad/); - ok($on_fault_was_called > 0); - - # get Fault as hash of subelements - my $fault = $s->call('My.Parameters.die_with_fault'); - ok($fault->faultcode =~ 'Server\.Custom'); - ok($fault->faultstring eq 'Died in server method'); - } - - print "Number of parameters test(s)...\n"; - - $s = XMLRPC::Lite - -> proxy($proxy) - ; - { my @all = $s->call('My.Parameters.echo')->paramsall; ok(@all == 0) } - { my @all = $s->call('My.Parameters.echo', 1)->paramsall; ok(@all == 1) } - { my @all = $s->call('My.Parameters.echo', (1) x 10)->paramsall; ok(@all == 10) } - - print "Memory refresh test(s)...\n"; - - # Funny test. - # Let's forget about ALL settings we did before with 'use XMLRPC::Lite...' - XMLRPC::Lite->self(undef); - ok(!defined XMLRPC::Lite->self); - - eval "use XMLRPC::Lite - proxy => '$proxy'; 1" or die; - - print "Global settings test(s)...\n"; - $s = new XMLRPC::Lite; - - ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); - - SOAP::Trace->import(transport => - sub {$_[0]->content_type('something/wrong') if UNIVERSAL::isa($_[0] => 'HTTP::Request')} - ); - - if ($proxy =~ /^tcp:/) { - skip('No Content-Type checks for tcp: protocol on server side' => undef); - } else { - ok($s->call('My.Examples.getStateName', 1)->faultstring =~ /Content-Type must be/); - } - - # check status for fault messages - if ($proxy =~ /^http/) { - ok($s->transport->status =~ /^200/); - } else { - skip('No Status checks for non http protocols on server side' => undef); - } -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -XMLRPC::Test - Test framework for XMLRPC::Lite - -=head1 SYNOPSIS - - use XMLRPC::Test; - - XMLRPC::Test::Server::run_for('http://localhost/cgi-bin/XMLRPC.cgi'); - -=head1 DESCRIPTION - -XMLRPC::Test provides simple framework for testing server implementations. -Specify your address (endpoint) and run provided tests against your server. -See t/1*.t for examples. - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:52 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:52 +0900 Subject: [Affelio-cvs 670] CVS update: affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport Message-ID: <20051024192052.96C772AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/HTTP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/HTTP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/HTTP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/HTTP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/HTTP.pm Tue Oct 25 04:20:52 2005 @@ -1,195 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: HTTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package XMLRPC::Transport::HTTP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use XMLRPC::Lite; -use SOAP::Transport::HTTP; - -# ====================================================================== - -package XMLRPC::Transport::HTTP::CGI; - - @ XMLRPC::Transport::HTTP::CGI::ISA = qw(SOAP::Transport::HTTP::CGI); - -sub initialize; *initialize = \&XMLRPC::Server::initialize; - -sub make_fault { - local $SOAP::Constants::HTTP_ON_FAULT_CODE = 200; - shift->SUPER::make_fault(@_); -} - -sub make_response { - local $SOAP::Constants::DO_NOT_USE_CHARSET = 1; - shift->SUPER::make_response(@_); -} - -# ====================================================================== - -package XMLRPC::Transport::HTTP::Daemon; - - @ XMLRPC::Transport::HTTP::Daemon::ISA = qw(SOAP::Transport::HTTP::Daemon); - -sub initialize; *initialize = \&XMLRPC::Server::initialize; -sub make_fault; *make_fault = \&XMLRPC::Transport::HTTP::CGI::make_fault; -sub make_response; *make_response = \&XMLRPC::Transport::HTTP::CGI::make_response; - -# ====================================================================== - -package XMLRPC::Transport::HTTP::Apache; - - @ XMLRPC::Transport::HTTP::Apache::ISA = qw(SOAP::Transport::HTTP::Apache); - -sub initialize; *initialize = \&XMLRPC::Server::initialize; -sub make_fault; *make_fault = \&XMLRPC::Transport::HTTP::CGI::make_fault; -sub make_response; *make_response = \&XMLRPC::Transport::HTTP::CGI::make_response; - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -XMLRPC::Transport::HTTP - Server/Client side HTTP support for XMLRPC::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use XMLRPC::Lite - proxy => 'http://localhost/', - # proxy => 'http://localhost/cgi-bin/xmlrpc.cgi', # local CGI server - # proxy => 'http://localhost/', # local daemon server - # proxy => 'http://login:password @ localhost/cgi-bin/xmlrpc.cgi', # local CGI server with authentication - ; - - print getStateName(1); - -=item CGI server - - use XMLRPC::Transport::HTTP; - - my $server = XMLRPC::Transport::HTTP::CGI - -> dispatch_to('methodName') - -> handle - ; - -=item Daemon server - - use XMLRPC::Transport::HTTP; - - my $daemon = XMLRPC::Transport::HTTP::Daemon - -> new (LocalPort => 80) - -> dispatch_to('methodName') - ; - print "Contact to XMLRPC server at ", $daemon->url, "\n"; - $daemon->handle; - -=back - -=head1 DESCRIPTION - -This class encapsulates all HTTP related logic for a XMLRPC server, -independent of what web server it's attached to. -If you want to use this class you should follow simple guideline -mentioned above. - -=head2 PROXY SETTINGS - -You can use any proxy setting you use with LWP::UserAgent modules: - - XMLRPC::Lite->proxy('http://endpoint.server/', - proxy => ['http' => 'http://my.proxy.server']); - -or - - $xmlrpc->transport->proxy('http' => 'http://my.proxy.server'); - -should specify proxy server for you. And if you use C<HTTP_proxy_user> -and C<HTTP_proxy_pass> for proxy authorization SOAP::Lite should know -how to handle it properly. - -=head2 COOKIE-BASED AUTHENTICATION - - use HTTP::Cookies; - - my $cookies = HTTP::Cookies->new(ignore_discard => 1); - # you may also add 'file' if you want to keep them between sessions - - my $xmlrpc = XMLRPC::Lite->proxy('http://localhost/'); - $xmlrpc->transport->cookie_jar($cookies); - -Cookies will be taken from response and provided for request. You may -always add another cookie (or extract what you need after response) -with HTTP::Cookies interface. - -You may also do it in one line: - - $xmlrpc->proxy('http://localhost/', - cookie_jar => HTTP::Cookies->new(ignore_discard => 1)); - -=head2 COMPRESSION - -XMLRPC::Lite provides you option for enabling compression on wire (for HTTP -transport only). Both server and client should support this capability, -but this logic should be absolutely transparent for your application. -Server will respond with encoded message only if client can accept it -(client sends Accept-Encoding with 'deflate' or '*' values) and client -has fallback logic, so if server doesn't understand specified encoding -(Content-Encoding: deflate) and returns proper error code -(415 NOT ACCEPTABLE) client will repeat the same request not encoded and -will store this server in per-session cache, so all other requests will -go there without encoding. - -Having options on client and server side that let you specify threshold -for compression you can safely enable this feature on both client and -server side. - -Compression will be enabled on client side IF: threshold is specified AND -size of current message is bigger than threshold AND module Compress::Zlib -is available. Client will send header 'Accept-Encoding' with value 'deflate' -if threshold is specified AND module Compress::Zlib is available. - -Server will accept compressed message if module Compress::Zlib is available, -and will respond with compressed message ONLY IF: threshold is specified AND -size of current message is bigger than threshold AND module Compress::Zlib -is available AND header 'Accept-Encoding' is presented in request. - -=head1 DEPENDENCIES - - Crypt::SSLeay for HTTPS/SSL - HTTP::Daemon for XMLRPC::Transport::HTTP::Daemon - Apache, Apache::Constants for XMLRPC::Transport::HTTP::Apache - -=head1 SEE ALSO - - See ::CGI, ::Daemon and ::Apache for implementation details. - See examples/XMLRPC/* for examples. - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/POP3.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/POP3.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/POP3.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/POP3.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/POP3.pm Tue Oct 25 04:20:52 2005 @@ -1,73 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: POP3.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package XMLRPC::Transport::POP3; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use XMLRPC::Lite; -use SOAP::Transport::POP3; - -# ====================================================================== - -package XMLRPC::Transport::POP3::Server; - - @ XMLRPC::Transport::POP3::Server::ISA = qw(SOAP::Transport::POP3::Server); - -sub initialize; *initialize = \&XMLRPC::Server::initialize; - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -XMLRPC::Transport::POP3 - Server side POP3 support for XMLRPC::Lite - -=head1 SYNOPSIS - - use XMLRPC::Transport::POP3; - - my $server = XMLRPC::Transport::POP3::Server - -> new('pop://pop.mail.server') - # if you want to have all in one place - # -> new('pop://user:password @ pop.mail.server') - # or, if you have server that supports MD5 protected passwords - # -> new('pop://user:password;AUTH=+APOP @ pop.mail.server') - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - # you don't need to use next line if you specified your password in new() - $server->login('user' => 'password') or die "Can't authenticate to POP3 server\n"; - - # handle will return number of processed mails - # you can organize loop if you want - do { $server->handle } while sleep 10; - - # you may also call $server->quit explicitly to purge deleted messages - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/TCP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/TCP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/TCP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/TCP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/XMLRPC/Transport/TCP.pm Tue Oct 25 04:20:52 2005 @@ -1,63 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger @ yahoo.com) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: TCP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package XMLRPC::Transport::TCP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use XMLRPC::Lite; -use SOAP::Transport::TCP; - -# ====================================================================== - -package XMLRPC::Transport::TCP::Server; - - @ XMLRPC::Transport::TCP::Server::ISA = qw(SOAP::Transport::TCP::Server); - -sub initialize; *initialize = \&XMLRPC::Server::initialize; - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -XMLRPC::Transport::TCP - Server/Client side TCP support for XMLRPC::Lite - -=head1 SYNOPSIS - - use XMLRPC::Transport::TCP; - - my $daemon = XMLRPC::Transport::TCP::Server - -> new (LocalAddr => 'localhost', LocalPort => 82, Listen => 5, Reuse => 1) - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to XMLRPC server at ", join(':', $daemon->sockhost, $daemon->sockport), "\n"; - $daemon->handle; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulclinger @ yahoo.com) - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:52 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:52 +0900 Subject: [Affelio-cvs 671] CVS update: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session Message-ID: <20051024192052.D3CBD2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/_time_alias.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/_time_alias.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/_time_alias.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/_time_alias.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/_time_alias.al Tue Oct 25 04:20:52 2005 @@ -1,34 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1159 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/_time_alias.al)" -# parses such strings as '+1M', '+3w', accepted by expire() -sub _time_alias { - my ($str) = @_; - - # If $str consists of just digits, return them as they are - if ( $str =~ m/^\d+$/ ) { - return $str; - } - - my %time_map = ( - s => 1, - m => 60, - h => 3600, - d => 86400, - w => 604800, - M => 2592000, - y => 31536000 - ); - - my ($koef, $d) = $str =~ m/^([+-]?\d+)(\w)$/; - - if ( defined($koef) && defined($d) ) { - return $koef * $time_map{$d}; - } -} - -# end of CGI::Session::_time_alias -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/atime.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/atime.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/atime.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/atime.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/atime.al Tue Oct 25 04:20:52 2005 @@ -1,19 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1099 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/atime.al)" -# atime() - rerturns session last access time -sub atime { - my $self = shift; - - if ( @_ ) { - confess "_SESSION_ATIME - read-only value"; - } - - return $self->{_DATA}->{_SESSION_ATIME}; -} - -# end of CGI::Session::atime -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/autosplit.ix diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/autosplit.ix:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/autosplit.ix:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/autosplit.ix:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/autosplit.ix Tue Oct 25 04:20:52 2005 @@ -1,24 +0,0 @@ -# Index created by AutoSplit for blib/lib/CGI/Session.pm -# (file acts as timestamp) -package CGI::Session; -sub dump ; -sub version ; -sub delete ; -sub clear ; -sub save_param ; -sub load_param ; -sub close ; -sub error ; -sub errstr ; -sub atime ; -sub ctime ; -sub expire ; -sub expires ; -sub _time_alias ; -sub remote_addr ; -sub param_hashref ; -sub name ; -sub header ; -sub sync_param ; -sub is_new ; -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/clear.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/clear.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/clear.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/clear.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/clear.al Tue Oct 25 04:20:52 2005 @@ -1,40 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 950 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/clear.al)" -# clear() - clears a list of parameters off the session's '_DATA' table -sub clear { - my $self = shift; - $class = ref($self); - - my @params = (); - - # if there was at least one argument, we take it as a list - # of params to delete - if ( @_ ) { - @params = ref($_[0]) ? @{ $_[0] } : ($_[0]); - } else { - @params = $self->param(); - } - - my $n = 0; - for ( @params ) { - /^_SESSION_/ and next; - # If this particular parameter has an expiration ticker, - # remove it. - if ( $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$_} ) { - delete ( $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$_} ); - } - delete ($self->{_DATA}->{$_}) && ++$n; - } - - # Set the session '_STATUS' flag to MODIFIED - $self->{_STATUS} = MODIFIED; - - return $n; -} - -# end of CGI::Session::clear -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/close.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/close.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/close.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/close.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/close.al Tue Oct 25 04:20:52 2005 @@ -1,16 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1068 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/close.al)" -# another, but a less efficient alternative to undefining -# the object -sub close { - my $self = shift; - - $self->DESTROY(); -} - -# end of CGI::Session::close -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/ctime.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/ctime.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/ctime.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/ctime.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/ctime.al Tue Oct 25 04:20:52 2005 @@ -1,19 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1111 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/ctime.al)" -# ctime() - returns session creation time -sub ctime { - my $self = shift; - - if ( @_ ) { - confess "_SESSION_ATIME - read-only value"; - } - - return $self->{_DATA}->{_SESSION_CTIME}; -} - -# end of CGI::Session::ctime -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/delete.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/delete.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/delete.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/delete.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/delete.al Tue Oct 25 04:20:52 2005 @@ -1,19 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 935 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/delete.al)" -sub delete { - my $self = shift; - - # If it was already deleted, make a confession! - if ( $self->{_STATUS} == DELETED ) { - confess "delete attempt on deleted session"; - } - - $self->{_STATUS} = DELETED; -} - -# end of CGI::Session::delete -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/dump.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/dump.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/dump.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/dump.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/dump.al Tue Oct 25 04:20:52 2005 @@ -1,37 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 899 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/dump.al)" -# $Id: dump.al,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - - -# dump() - dumps the session object using Data::Dumper. -# during development it defines global dump(). -sub dump { - my ($self, $file, $indent) = @_; - - require Data::Dumper; - local $Data::Dumper::Indent = $indent || 2; - - my $d = new Data::Dumper([$self], [ref $self]); - - if ( defined $file ) { - unless ( open(FH, '<' . $file) ) { - unless(open(FH, '>' . $file)) { - $self->error("Couldn't open $file: $!"); - return undef; - } - print FH $d->Dump(); - unless ( CORE::close(FH) ) { - $self->error("Couldn't dump into $file: $!"); - return undef; - } - } - } - return $d->Dump(); -} - -# end of CGI::Session::dump -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/error.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/error.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/error.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/error.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/error.al Tue Oct 25 04:20:52 2005 @@ -1,19 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1078 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/error.al)" -# error() returns/sets error message -sub error { - my ($self, $msg) = @_; - - if ( defined $msg ) { - $errstr = $msg; - } - - return $errstr; -} - -# end of CGI::Session::error -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/errstr.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/errstr.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/errstr.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/errstr.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/errstr.al Tue Oct 25 04:20:52 2005 @@ -1,15 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1090 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/errstr.al)" -# errstr() - alias to error() -sub errstr { - my $self = shift; - - return $self->error(@_); -} - -# end of CGI::Session::errstr -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expire.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expire.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expire.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expire.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expire.al Tue Oct 25 04:20:52 2005 @@ -1,37 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1123 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/expire.al)" -# expire() - sets/returns session/parameter expiration ticker -sub expire { - my $self = shift; - - unless ( @_ ) { - return $self->{_DATA}->{_SESSION_ETIME}; - } - - if ( @_ == 1 ) { - return $self->{_DATA}->{_SESSION_ETIME} = _time_alias( $_[0] ); - } - - # If we came this far, we'll simply assume user is trying - # to set an expiration date for a single session parameter. - my ($param, $etime) = @_; - - # Let's check if that particular session parameter exists - # in the '_DATA' table. Otherwise, return now! - defined ($self->{_DATA}->{$param} ) || return; - - if ( $etime eq '-1' ) { - delete $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$param}; - $self->{_STATUS} = MODIFIED; - return; - } - - $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$param} = _time_alias( $etime ); -} - -# end of CGI::Session::expire -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expires.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expires.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expires.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expires.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/expires.al Tue Oct 25 04:20:52 2005 @@ -1,13 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1153 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/expires.al)" -# expires() - alias to expire(). For backward compatibility -sub expires { - return expire(@_); -} - -# end of CGI::Session::expires -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/header.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/header.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/header.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/header.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/header.al Tue Oct 25 04:20:52 2005 @@ -1,28 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1214 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/header.al)" -# header() - replacement for CGI::header() method -sub header { - my $self = shift; - - my $cgi = $self->{_SESSION_OBJ}; - unless ( defined $cgi ) { - require CGI; - $self->{_SESSION_OBJ} = CGI->new(); - return $self->header(); - } - - my $cookie = $cgi->cookie($self->name(), $self->id() ); - - return $cgi->header( - -type => 'text/html', - -cookie => $cookie, - @_ - ); -} - -# end of CGI::Session::header -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/is_new.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/is_new.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/is_new.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/is_new.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/is_new.al Tue Oct 25 04:20:52 2005 @@ -1,16 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1256 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/is_new.al)" -# to Chris Dolan's request -sub is_new { - my $self = shift; - - return $self->{_IS_NEW}; -} - -# $Id: is_new.al,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -1; -# end of CGI::Session::is_new Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/load_param.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/load_param.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/load_param.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/load_param.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/load_param.al Tue Oct 25 04:20:52 2005 @@ -1,41 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1032 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/load_param.al)" -# load_param() - loads a list of third party object parameters -# such as CGI, into CGI::Session's '_DATA' table -sub load_param { - my ($self, $cgi, $list) = @_; - - unless ( ref($cgi) ) { - confess "save_param(): first argument must be an object"; - - } - unless ( $cgi->can('param') ) { - my $class = ref($cgi); - confess "save_param(): Cannot call method param() on the object $class"; - } - - my @params = (); - if ( defined $list ) { - unless ( ref($list) eq 'ARRAY' ) { - confess "save_param(): second argument must be an arrayref"; - } - @params = @{ $list }; - - } else { - @params = $self->param(); - - } - - my $n = 0; - for ( @params ) { - $cgi->param(-name=>$_, -value=>$self->_get_param($_)); - } - return $n; -} - -# end of CGI::Session::load_param -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/name.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/name.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/name.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/name.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/name.al Tue Oct 25 04:20:52 2005 @@ -1,19 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1202 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/name.al)" -# name() - returns the cookie name associated with the session id -sub name { - my ($class, $name) = @_; - - if ( defined $name ) { - $CGI::Session::NAME = $name; - } - - return $CGI::Session::NAME; -} - -# end of CGI::Session::name -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/param_hashref.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/param_hashref.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/param_hashref.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/param_hashref.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/param_hashref.al Tue Oct 25 04:20:52 2005 @@ -1,15 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1194 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/param_hashref.al)" -# param_hashref() - returns parameters as a reference to a hash -sub param_hashref { - my $self = shift; - - return $self->{_DATA}; -} - -# end of CGI::Session::param_hashref -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/remote_addr.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/remote_addr.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/remote_addr.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/remote_addr.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/remote_addr.al Tue Oct 25 04:20:52 2005 @@ -1,15 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1186 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/remote_addr.al)" -# remote_addr() - returns ip address of the session -sub remote_addr { - my $self = shift; - - return $self->{_DATA}->{_SESSION_REMOTE_ADDR}; -} - -# end of CGI::Session::remote_addr -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/save_param.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/save_param.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/save_param.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/save_param.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/save_param.al Tue Oct 25 04:20:52 2005 @@ -1,56 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 983 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/save_param.al)" -# save_param() - copies a list of third party object parameters -# into CGI::Session object's '_DATA' table -sub save_param { - my ($self, $cgi, $list) = @_; - - unless ( ref($cgi) ) { - confess "save_param(): first argument should be an object"; - - } - unless ( $cgi->can('param') ) { - confess "save_param(): Cannot call method param() on the object"; - } - - my @params = (); - if ( defined $list ) { - unless ( ref($list) eq 'ARRAY' ) { - confess "save_param(): second argument must be an arrayref"; - } - - @params = @{ $list }; - - } else { - @params = $cgi->param(); - - } - - my $n = 0; - for ( @params ) { - # It's imporatnt to note that CGI.pm's param() returns array - # if a parameter has more values associated with it (checkboxes - # and crolling lists). So we should access its parameters in - # array context not to miss anything - my @values = $cgi->param($_); - - if ( defined $values[1] ) { - $self->_set_param($_ => \@values); - - } else { - $self->_set_param($_ => $values[0] ); - - } - - ++$n; - } - - return $n; -} - -# end of CGI::Session::save_param -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/sync_param.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/sync_param.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/sync_param.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/sync_param.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/sync_param.al Tue Oct 25 04:20:52 2005 @@ -1,28 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 1235 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/sync_param.al)" -# sync_param() - synchronizes CGI and Session parameters. -sub sync_param { - my ($self, $cgi, $list) = @_; - - unless ( ref($cgi) ) { - confess("$cgi doesn't look like an object"); - } - - unless ( $cgi->UNIVERSAL::can('param') ) { - confess(ref($cgi) . " doesn't support param() method"); - } - - # we first need to save all the available CGI parameters to the - # object - $self->save_param($cgi, $list); - - # we now need to load all the parameters back to the CGI object - return $self->load_param($cgi, $list); -} - -# end of CGI::Session::sync_param -1; Index: affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/version.al diff -u affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/version.al:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/version.al:removed --- affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/version.al:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/auto/CGI/Session/version.al Tue Oct 25 04:20:52 2005 @@ -1,13 +0,0 @@ -# NOTE: Derived from blib/lib/CGI/Session.pm. -# Changes made here will be lost when autosplit is run again. -# See AutoSplit.pm. -package CGI::Session; - -#line 930 "blib/lib/CGI/Session.pm (autosplit into blib/lib/auto/CGI/Session/version.al)" -sub version { return $VERSION } - - -# delete() - sets the '_STATUS' session flag to DELETED, -# which flush() uses to decide to call remove() method on driver. -# end of CGI::Session::version -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:53 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:53 +0900 Subject: [Affelio-cvs 672] CVS update: affelio_farm/admin/skelton/affelio/icons Message-ID: <20051024192053.109C02AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/icons/affelio_normal.jpg Index: affelio_farm/admin/skelton/affelio/icons/affelio_over.jpg Index: affelio_farm/admin/skelton/affelio/icons/guest_normal.jpg Index: affelio_farm/admin/skelton/affelio/icons/guest_over.jpg Index: affelio_farm/admin/skelton/affelio/icons/owner_normal.jpg Index: affelio_farm/admin/skelton/affelio/icons/owner_over.jpg From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:53 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:53 +0900 Subject: [Affelio-cvs 673] CVS update: affelio_farm/admin/skelton/affelio/images Message-ID: <20051024192053.33BC92AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/images/README diff -u affelio_farm/admin/skelton/affelio/images/README:1.1.1.1 affelio_farm/admin/skelton/affelio/images/README:removed --- affelio_farm/admin/skelton/affelio/images/README:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/images/README Tue Oct 25 04:20:53 2005 @@ -1 +0,0 @@ -Image files related to any skin should NOT be here! Index: affelio_farm/admin/skelton/affelio/images/friends.png Index: affelio_farm/admin/skelton/affelio/images/friendsoffriends.png Index: affelio_farm/admin/skelton/affelio/images/templates.png From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:53 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:53 +0900 Subject: [Affelio-cvs 674] CVS update: affelio_farm/admin/skelton/affelio/java Message-ID: <20051024192053.585BB2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/java/Edge.class Index: affelio_farm/admin/skelton/affelio/java/Graph.class Index: affelio_farm/admin/skelton/affelio/java/Graph.java diff -u affelio_farm/admin/skelton/affelio/java/Graph.java:1.1.1.1 affelio_farm/admin/skelton/affelio/java/Graph.java:removed --- affelio_farm/admin/skelton/affelio/java/Graph.java:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/java/Graph.java Tue Oct 25 04:20:53 2005 @@ -1,437 +0,0 @@ -/* - * Copyright (c) 2003 Sun Microsystems, Inc. All Rights Reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * - * -Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * - * -Redistribution in binary form must reproduct the above copyright - * notice, this list of conditions and the following disclaimer in - * the documentation and/or other materials provided with the distribution. - * - * Neither the name of Sun Microsystems, Inc. or the names of contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * This software is provided "AS IS," without a warranty of any kind. ALL - * EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, INCLUDING - * ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE - * OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN AND ITS LICENSORS SHALL NOT - * BE LIABLE FOR ANY DAMAGES OR LIABILITIES SUFFERED BY LICENSEE AS A RESULT - * OF OR RELATING TO USE, MODIFICATION OR DISTRIBUTION OF THE SOFTWARE OR ITS - * DERIVATIVES. IN NO EVENT WILL SUN OR ITS LICENSORS BE LIABLE FOR ANY LOST - * REVENUE, PROFIT OR DATA, OR FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, - * INCIDENTAL OR PUNITIVE DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY - * OF LIABILITY, ARISING OUT OF THE USE OF OR INABILITY TO USE SOFTWARE, EVEN - * IF SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. - * - * You acknowledge that Software is not designed, licensed or intended for - * use in the design, construction, operation or maintenance of any nuclear - * facility. - */ - -/* - * @(#)Graph.java 1.13 03/01/23 - */ - -import java.util.*; -import java.awt.*; -import java.applet.Applet; -import java.awt.event.*; - - -class Node { - double x; - double y; - - double dx; - double dy; - - boolean fixed; - - String lbl; -} - - -class Edge { - int from; - int to; - - double len; -} - - -class GraphPanel extends Panel - implements Runnable, MouseListener, MouseMotionListener { - Graph graph; - int nnodes; - Node nodes[] = new Node[100]; - - int nedges; - Edge edges[] = new Edge[200]; - - Thread relaxer; - boolean stress; - boolean random; - - GraphPanel(Graph graph) { - this.graph = graph; - addMouseListener(this); - } - - int findNode(String lbl) { - for (int i = 0 ; i < nnodes ; i++) { - if (nodes[i].lbl.equals(lbl)) { - return i; - } - } - return addNode(lbl); - } - int addNode(String lbl) { - Node n = new Node(); - n.x = 10 + 380*Math.random(); - n.y = 10 + 380*Math.random(); - n.lbl = lbl; - nodes[nnodes] = n; - return nnodes++; - } - void addEdge(String from, String to, int len) { - Edge e = new Edge(); - e.from = findNode(from); - e.to = findNode(to); - e.len = len; - edges[nedges++] = e; - } - - public void run() { - Thread me = Thread.currentThread(); - while (relaxer == me) { - relax(); - if (random && (Math.random() < 0.03)) { - Node n = nodes[(int)(Math.random() * nnodes)]; - if (!n.fixed) { - n.x += 100*Math.random() - 50; - n.y += 100*Math.random() - 50; - } - graph.play(graph.getCodeBase(), "audio/drip.au"); - } - try { - Thread.sleep(100); - } catch (InterruptedException e) { - break; - } - } - } - - synchronized void relax() { - for (int i = 0 ; i < nedges ; i++) { - Edge e = edges[i]; - double vx = nodes[e.to].x - nodes[e.from].x; - double vy = nodes[e.to].y - nodes[e.from].y; - double len = Math.sqrt(vx * vx + vy * vy); - len = (len == 0) ? .0001 : len; - double f = (edges[i].len - len) / (len * 3); - double dx = f * vx; - double dy = f * vy; - - nodes[e.to].dx += dx; - nodes[e.to].dy += dy; - nodes[e.from].dx += -dx; - nodes[e.from].dy += -dy; - } - - for (int i = 0 ; i < nnodes ; i++) { - Node n1 = nodes[i]; - double dx = 0; - double dy = 0; - - for (int j = 0 ; j < nnodes ; j++) { - if (i == j) { - continue; - } - Node n2 = nodes[j]; - double vx = n1.x - n2.x; - double vy = n1.y - n2.y; - double len = vx * vx + vy * vy; - if (len == 0) { - dx += Math.random(); - dy += Math.random(); - } else if (len < 100*100) { - dx += vx / len; - dy += vy / len; - } - } - double dlen = dx * dx + dy * dy; - if (dlen > 0) { - dlen = Math.sqrt(dlen) / 2; - n1.dx += dx / dlen; - n1.dy += dy / dlen; - } - } - - Dimension d = getSize(); - for (int i = 0 ; i < nnodes ; i++) { - Node n = nodes[i]; - if (!n.fixed) { - n.x += Math.max(-5, Math.min(5, n.dx)); - n.y += Math.max(-5, Math.min(5, n.dy)); - } - if (n.x < 0) { - n.x = 0; - } else if (n.x > d.width) { - n.x = d.width; - } - if (n.y < 0) { - n.y = 0; - } else if (n.y > d.height) { - n.y = d.height; - } - n.dx /= 2; - n.dy /= 2; - } - repaint(); - } - - Node pick; - boolean pickfixed; - Image offscreen; - Dimension offscreensize; - Graphics offgraphics; - - final Color fixedColor = Color.red; - final Color selectColor = Color.pink; - final Color edgeColor = Color.black; - final Color nodeColor = new Color(250, 220, 100); - final Color stressColor = Color.darkGray; - final Color arcColor1 = Color.black; - final Color arcColor2 = Color.pink; - final Color arcColor3 = Color.red; - - public void paintNode(Graphics g, Node n, FontMetrics fm) { - int x = (int)n.x; - int y = (int)n.y; - g.setColor((n == pick) ? selectColor : (n.fixed ? fixedColor : nodeColor)); - int w = fm.stringWidth(n.lbl) + 10; - int h = fm.getHeight() + 4; - g.fillRect(x - w/2, y - h / 2, w, h); - g.setColor(Color.black); - g.drawRect(x - w/2, y - h / 2, w-1, h-1); - g.drawString(n.lbl, x - (w-10)/2, (y - (h-4)/2) + fm.getAscent()); - } - - public synchronized void update(Graphics g) { - Dimension d = getSize(); - if ((offscreen == null) || (d.width != offscreensize.width) || (d.height != offscreensize.height)) { - offscreen = createImage(d.width, d.height); - offscreensize = d; - if (offgraphics != null) { - offgraphics.dispose(); - } - offgraphics = offscreen.getGraphics(); - offgraphics.setFont(getFont()); - } - - offgraphics.setColor(getBackground()); - offgraphics.fillRect(0, 0, d.width, d.height); - for (int i = 0 ; i < nedges ; i++) { - Edge e = edges[i]; - int x1 = (int)nodes[e.from].x; - int y1 = (int)nodes[e.from].y; - int x2 = (int)nodes[e.to].x; - int y2 = (int)nodes[e.to].y; - int len = (int)Math.abs(Math.sqrt((x1-x2)*(x1-x2) + (y1-y2)*(y1-y2)) - e.len); - offgraphics.setColor((len < 10) ? arcColor1 : (len < 20 ? arcColor2 : arcColor3)) ; - offgraphics.drawLine(x1, y1, x2, y2); - if (stress) { - String lbl = String.valueOf(len); - offgraphics.setColor(stressColor); - offgraphics.drawString(lbl, x1 + (x2-x1)/2, y1 + (y2-y1)/2); - offgraphics.setColor(edgeColor); - } - } - - FontMetrics fm = offgraphics.getFontMetrics(); - for (int i = 0 ; i < nnodes ; i++) { - paintNode(offgraphics, nodes[i], fm); - } - g.drawImage(offscreen, 0, 0, null); - } - - //1.1 event handling - public void mouseClicked(MouseEvent e) { - } - - public void mousePressed(MouseEvent e) { - addMouseMotionListener(this); - double bestdist = Double.MAX_VALUE; - int x = e.getX(); - int y = e.getY(); - for (int i = 0 ; i < nnodes ; i++) { - Node n = nodes[i]; - double dist = (n.x - x) * (n.x - x) + (n.y - y) * (n.y - y); - if (dist < bestdist) { - pick = n; - bestdist = dist; - } - } - pickfixed = pick.fixed; - pick.fixed = true; - pick.x = x; - pick.y = y; - repaint(); - e.consume(); - } - - public void mouseReleased(MouseEvent e) { - removeMouseMotionListener(this); - if (pick != null) { - pick.x = e.getX(); - pick.y = e.getY(); - pick.fixed = pickfixed; - pick = null; - } - repaint(); - e.consume(); - } - - public void mouseEntered(MouseEvent e) { - } - - public void mouseExited(MouseEvent e) { - } - - public void mouseDragged(MouseEvent e) { - pick.x = e.getX(); - pick.y = e.getY(); - repaint(); - e.consume(); - } - - public void mouseMoved(MouseEvent e) { - } - - public void start() { - relaxer = new Thread(this); - relaxer.start(); - } - - public void stop() { - relaxer = null; - } - -} - - -public class Graph extends Applet implements ActionListener, ItemListener { - - GraphPanel panel; - Panel controlPanel; - - Button scramble = new Button("Scramble"); - Button shake = new Button("Shake"); - Checkbox stress = new Checkbox("Stress"); - Checkbox random = new Checkbox("Random"); - - public void init() { - setLayout(new BorderLayout()); - - panel = new GraphPanel(this); - add("Center", panel); - controlPanel = new Panel(); - add("South", controlPanel); - - controlPanel.add(scramble); scramble.addActionListener(this); - controlPanel.add(shake); shake.addActionListener(this); - controlPanel.add(stress); stress.addItemListener(this); - controlPanel.add(random); random.addItemListener(this); - - String edges = getParameter("edges"); - for (StringTokenizer t = new StringTokenizer(edges, ",") ; t.hasMoreTokens() ; ) { - String str = t.nextToken(); - int i = str.indexOf('-'); - if (i > 0) { - int len = 50; - int j = str.indexOf('/'); - if (j > 0) { - len = Integer.valueOf(str.substring(j+1)).intValue(); - str = str.substring(0, j); - } - panel.addEdge(str.substring(0,i), str.substring(i+1), len); - } - } - Dimension d = getSize(); - String center = getParameter("center"); - if (center != null){ - Node n = panel.nodes[panel.findNode(center)]; - n.x = d.width / 2; - n.y = d.height / 2; - n.fixed = true; - } - } - - public void destroy() { - remove(panel); - remove(controlPanel); - } - - public void start() { - panel.start(); - } - - public void stop() { - panel.stop(); - } - - public void actionPerformed(ActionEvent e) { - Object src = e.getSource(); - - if (src == scramble) { - play(getCodeBase(), "audio/computer.au"); - Dimension d = getSize(); - for (int i = 0 ; i < panel.nnodes ; i++) { - Node n = panel.nodes[i]; - if (!n.fixed) { - n.x = 10 + (d.width-20)*Math.random(); - n.y = 10 + (d.height-20)*Math.random(); - } - } - return; - } - - if (src == shake) { - play(getCodeBase(), "audio/gong.au"); - Dimension d = getSize(); - for (int i = 0 ; i < panel.nnodes ; i++) { - Node n = panel.nodes[i]; - if (!n.fixed) { - n.x += 80*Math.random() - 40; - n.y += 80*Math.random() - 40; - } - } - } - - } - - public void itemStateChanged(ItemEvent e) { - Object src = e.getSource(); - boolean on = e.getStateChange() == ItemEvent.SELECTED; - if (src == stress) panel.stress = on; - else if (src == random) panel.random = on; - } - - public String getAppletInfo() { - return "Title: GraphLayout \nAuthor: <unknown>"; - } - - public String[][] getParameterInfo() { - String[][] info = { - {"edges", "delimited string", "A comma-delimited list of all the edges. It takes the form of 'C-N1,C-N2,C-N3,C-NX,N1-N2/M12,N2-N3/M23,N3-NX/M3X,...' where C is the name of center node (see 'center' parameter) and NX is a node attached to the center node. For the edges connecting nodes to eachother (and not to the center node) you may (optionally) specify a length MXY separated from the edge name by a forward slash."}, - {"center", "string", "The name of the center node."} - }; - return info; - } - -} Index: affelio_farm/admin/skelton/affelio/java/GraphPanel.class Index: affelio_farm/admin/skelton/affelio/java/Node.class From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:53 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:53 +0900 Subject: [Affelio-cvs 675] CVS update: affelio_farm/admin/skelton/affelio/java/audio Message-ID: <20051024192053.7D8202AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/java/audio/computer.au Index: affelio_farm/admin/skelton/affelio/java/audio/drip.au Index: affelio_farm/admin/skelton/affelio/java/audio/gong.au From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:53 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:53 +0900 Subject: [Affelio-cvs 676] CVS update: affelio_farm/admin/skelton/affelio/lib Message-ID: <20051024192053.9F39C2AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio.pm:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio.pm Tue Oct 25 04:20:53 2005 @@ -1,824 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Affelio.pm,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -package Affelio; -{ - use strict; - use lib("../extlib"); - use lib("../../extlib"); - use DBI; - use Config::Tiny; - use Config::IniFiles; - use Error qw(:try); - use lib("../lib"); - use Affelio::SNS::FriendManager; - use Affelio::Managing::ProfileManager; - use Affelio::Managing::GroupManager; - use Affelio::Managing::PermissionManager; - use Affelio::Managing::MessageManager; - use Affelio::Managing::ApplicationManager; - use Affelio::Managing::AccessLogManager; - use Affelio::misc::Debug; - use Affelio::misc::L10N; - use Affelio::misc::WebInput; - use Affelio::exception::TaintedInputException; - use Affelio::exception::DBException; - use Affelio::exception::SystemException; - - ###################################################################### - #Constructor - ###################################################################### - sub new{ - my $class = shift; - my %param = @_; - - debug_print("Affelio::new: start."); - - ################################### - #Config dir - ################################### - my $cfg_dir = $param{ConfigDir}; - my $cfg_path = $param{ConfigDir} . "/affelio.cfg"; - debug_print("Affelio::new: cfg_path= [$cfg_path]"); - #cfg_path Configuration file's path - #cfg_dir Configuration file's directory - - my $top_dir = $param{ConfigDir} . "/../"; - - ################################### - #Mode - ################################### - my $mode = $param{Mode}; - if(!defined($mode)){ - $mode =""; - } - #mode= "init" Setup mode - #mode= "" Normal execution - - ################################### - #Guest/Owner current status - ################################### - # How can we know if we are in owner mode? or guest mode? - my $guest_owner_switch = $param{GuestOwnerSwitch}; - #guest_owner_switch = "" guest - #guest_owner_switch = "owner" owner - - ################################### - #Caller - ################################### - my $caller = ""; - $caller = $param{Caller}; - if($caller){ - if($caller =~ /([\w]+)/){ - $caller =$1; - }else{ - throw Affelio::exception::TaintedInputException("Affelio caller"); - } - }else{ - $caller=""; - } - debug_print("Affelio::new: caller= [$caller] "); - #caller= "" ... if AffelioCore called me. - #caller= "install_name"... if application "install_name" called me. - - ################################### - #Managers - ################################### - my $lh = ""; - my $db = ""; - my $pm = ""; - my $fm = ""; - my $gm = ""; - my $perm = ""; - my $am = ""; - my $alm = ""; - my $farm_con = ""; - - ################################### - #Blessing - ################################### - my $self = {cfg_path => $cfg_path, - cfg_dir => $cfg_dir, - top_dir => $top_dir, - lh => $lh, - db => $db, - pm => $pm, - fm => $fm, - gm => $gm, - perm => $perm, - am => $am, - alm => $alm, - mode => $mode, - guest_owner_switch => $guest_owner_switch, - caller => $caller, - farm_con => $farm_con - }; - - bless $self, $class; - - ################################### - #Initialization - ################################### - #Read site config. and user preferences. - $self->read_site_config(); - $self->read_user_prefs(); - - #Connect to DB - $self->openDB(); - - #Load locale - $self->load_Locale(); - - #Load profile manager - $self->load_ProfileManager(); - - #Load friend manager - $self->load_FriendManager(); - - #Load group manager - $self->load_GroupManager(); - - #Load permission manager - $self->load_PermissionManager(); - - #Load permission manager - $self->load_MessageManager(); - - #Load permission manager - $self->load_AccessLogManager(); - - if($self->{mode} ne "init"){ - $self->load_ApplicationManager(); - } - - debug_print("Affelio::new: end."); - return $self; - } - - ###################################################################### - #Destructor - ###################################################################### - sub DESTROY{ - my $self = shift; - if(defined($self->{db})){ - try{ - $self->{db}->disconnect; - }catch Error with{ - }; - } - } - - ###################################################################### - #set_owner_mode: Flag this Affelio as "owner" mode. - ###################################################################### - sub set_owner_mode{ - my $self = shift; - debug_print("Affelio::set_owner_mode OK"); - $self->{guest_owner_switch} = "owner"; - } - - ###################################################################### - #openDB - ###################################################################### - sub openDB{ - my $self = shift; - - undef($self->{db}); - - #Load username and password - my $DBConfig = Config::Tiny->new(); - $DBConfig = Config::Tiny->read("$self->{site__user_dir}/db.cfg"); - my $rootproperty = $DBConfig->{_}->{rootproperty}; - my $db_type = $DBConfig->{db}->{type}; - my $db_dbname = $DBConfig->{db}->{dbname}; - my $db_username = $DBConfig->{db}->{username}; - my $db_password = $DBConfig->{db}->{password}; - my $db_hostname = $DBConfig->{db}->{hostname}; - my $db_port = $DBConfig->{db}->{port}; - - if($db_type eq "mysql"){ - - my $dsn = "DBI:mysql:$db_dbname:$db_hostname:$db_port"; - eval{ - $self->{db} = DBI->connect($dsn, $db_username, $db_password) or die("Cannot connect to MySQL: " . $DBI::errstr); - }; - if($@){ - throw Affelio::exception::DBException("MySQL open error"); - } - - }elsif ($db_type eq "sqlite"){ - eval{ - $self->{db} = DBI->connect("dbi:SQLite:dbname=$self->{site__user_dir}/DB.sqlite", "", "") or die("Cannot connect to SQLite: " . $DBI::errstr); - }; - if($@){ - throw Affelio::exception::DBException("SQLite open error"); - } - }else{ - throw Affelio::exception::SystemException("DB type not specified"); - } - - if(!defined($self->{db})){ - throw Affelio::exception::DBException("DB Handle not defined after open. very weird."); - } - - eval{ - $self->{db}->{RaiseError} = 1; - }; - if($@){ - throw Affelio::exception::DBException("DB Error Setting"); - } - - } - - ###################################################################### - #openAppDB - ###################################################################### - sub openAppDB{ - my $self = shift; - my $app_install_name = shift; - - #Load username and password - my $DBConfig = Config::Tiny->new(); - $DBConfig = Config::Tiny->read("$self->{site__user_dir}/db.cfg"); - my $rootproperty = $DBConfig->{_}->{rootproperty}; - my $db_type = $DBConfig->{appdb}->{type}; - my $db_dbname = $DBConfig->{appdb}->{dbname}; - my $db_username = $DBConfig->{appdb}->{username}; - my $db_password = $DBConfig->{appdb}->{password}; - my $db_hostname = $DBConfig->{appdb}->{hostname}; - my $db_port = $DBConfig->{appdb}->{port}; - - my $ret=""; - - ###MySQL - if($db_type eq "mysql"){ - my $dsn = "DBI:mysql:$db_dbname:$db_hostname:$db_port"; - - eval{ - $ret = DBI->connect($dsn, $db_username, $db_password); - }; - if($@){ - throw Affelio::exception::DBException("MySQL open error"); - } - } - ###SQLite - if($db_type eq "sqlite"){ - eval{ - $ret = DBI->connect("dbi:SQLite:dbname=$self->{site__user_dir}/appdata/$app_install_name/DB.sqlite", "", ""); - }; - if($@){ - throw Affelio::exception::DBException("SQLite open error"); - } - } - - eval{ - $ret->{RaiseError} = 1; - }; - if($@){ - throw Affelio::exception::DBException("DB Error Setting"); - } - - $ret->{RaiseError} = 1; - - return($ret); - } - - ###################################################################### - #load_Locale - ###################################################################### - sub load_Locale{ - my $self = shift; - $self->{lh} = Affelio::misc::L10N->get_handle(($self->{site__locale},"en_us")); - } - - ###################################################################### - #load_ProfileManager - ###################################################################### - sub load_ProfileManager{ - my $self = shift; - try{ - $self->{pm} = new Affelio::Managing::ProfileManager($self, - $self->{mode}); - } - catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load profilemanager: $ex"); - } - }; - } - - ###################################################################### - #load_FriendManager - ###################################################################### - sub load_FriendManager{ - my $self = shift; - try{ - $self->{fm} = new Affelio::SNS::FriendManager($self); - }catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load FriendManager: $ex"); - } - }; - } - - ###################################################################### - #load_GroupManager - ###################################################################### - sub load_GroupManager{ - my $self = shift; - try{ - $self->{gm} = new Affelio::Managing::GroupManager($self); - } - catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load GroupManager: $ex"); - } - }; - - } - - ###################################################################### - #load_PermissionManager - ###################################################################### - sub load_PermissionManager{ - my $self = shift; - try{ - $self->{perm} = new Affelio::Managing::PermissionManager($self); - } - catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load PermissionManager: $ex"); - } - }; - } - - ###################################################################### - #load_MessageManager - ###################################################################### - sub load_MessageManager{ - my $self = shift; - try{ - $self->{mesgm} = new Affelio::Managing::MessageManager($self); - } - catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load MessageManager: $ex"); - } - }; - - } - - ###################################################################### - #load_AccessLogManager - ###################################################################### - sub load_AccessLogManager{ - my $self = shift; - try{ - $self->{alm} = new Affelio::Managing::AccessLogManager($self); - } - catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load AccessLogManager: $ex"); - } - }; - - } - - ###################################################################### - #load_ApplicationManager - ###################################################################### - sub load_ApplicationManager{ - my $self = shift; - try{ - ########################### - #Start ApplicationManager - ########################### - $self->{am} = new Affelio::Managing::ApplicationManager($self); - - ########################### - #Configure "Top page" - ########################### - if(($self->{userpref__toppage_app_installname} ne "") - && ($self->{userpref__toppage_app_installname} ne "Affelio")){ - - $self->{userpref__toppage_app_path}= - "/apps/" . - $self->{userpref__toppage_app_installname} . "/" . - $self->{am}->{apps}->{"$self->{userpref__toppage_app_installname}"}->{guest_index}; - - }else{ - $self->{userpref__toppage_app_installname} = "Affelio"; - $self->{userpref__toppage_app_path}="index.cgi?mode=index"; - } - - }catch Error with { - my $ex = shift; - if($self->{mode} ne "init"){ - throw Affelio::exception::SystemException("Cannot load ApplicationManager: $ex"); - } - }; - - } - - ###################################################################### - #get_farm_connecter{ - # - ###################################################################### - sub get_farm_connecter{ - my $self = shift; - if( !($self->{farm_con}) ){ - my $Config = Config::Tiny->new(); - - $Config = Config::Tiny->read($self->{cfg_path}); - if($@ || !$Config){ - throw Affelio::exception::SystemException("affelio.cfg not found"); - } - - $self->{farm__connecter_path} = $Config->{affelio_farm}->{farm_connecter}; - if(($self->{farm__connecter_path} eq "" ) - || !($self->{farm__connecter_path}) ){ - return(""); - } - debug_print("Affelio::get_farm_con: [$self->{farm__connecter_path}]"); - - my ($con_type, $con_arg) = split(':', $self->{farm__connecter_path}); - my $con_class = "Affelio::Backplane::FarmConnecter::" . $con_type; - debug_print("Affelio::get_farm_con: [$con_class]"); - debug_print("Affelio::get_farm_con: [$con_arg]"); - - eval "use $con_class"; - if($@){ - debug_print("Affelio::get_farm_con: con=[$self->{farm_con}]1"); - } - - $self->{farm_con} = $con_class->new(path => $con_arg); - if($@){ - debug_print("$@"); - throw Affelio::exception::SystemException("Could not instantiate [$con_class]."); - } - debug_print("Affelio::get_farm_con: con=[$self->{farm_con}]"); - - } - - return($self->{farm_con}); - } - - ###################################################################### - #read_site_config - # read Affelio.cfg file - ###################################################################### - sub read_site_config{ - my $self = shift; - debug_print("Affelio::read_site_config: start."); - - my $wi = new Affelio::misc::WebInput(); - - my $Config = Config::Tiny->new(); - - $Config = Config::Tiny->read($self->{cfg_path}); - if($@ || !$Config){ - throw Affelio::exception::SystemException("affelio.cfg not found"); - } - - my $rootproperty = $Config->{_}->{rootproperty}; - $self->{site__fs_root} = $Config->{site_config}->{fs_root}; - $self->{site__web_root} = $Config->{site_config}->{web_root}; - - #Oh well, this config parameter has been "char_set" for a while.. - #For now, locale = char_set - $self->{site__locale} = $Config->{site_config}->{char_set}; - if($self->{site__locale} eq ""){ - $self->{site__locale} = "ja"; - } - - $self->{site__template} = $Config->{site_config}->{template}; - if($self->{site__template} eq ""){ - $self->{site__template} = "default"; - } - - #$self->{cmd__nkf} = $Config->{command}->{nkf}; - $self->{cmd__sendmail} = $Config->{command}->{sendmail}; - - #Determine userdata/..../ directory - my $dir; - eval{ - opendir(DIR, "$self->{top_dir}/userdata"); - while (defined($dir = readdir(DIR))) { - if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS') - && ($dir ne 'index.html')){ - $self->{site__user_dir} = - $wi->PTN_dirname("$self->{top_dir}/userdata/$dir"); - } - } - }; - if($@){ - throw Affelio::exception::SystemException("cannot open userdata directory."); - } - closedir(DIR); - - #Load username and password - my $Config2 = Config::Tiny->new(); - $Config2 = Config::Tiny->read("$self->{site__user_dir}/login.cfg"); - if($@ || !$Config2){ - throw Affelio::exception::SystemException("login.cfg not found"); - } - my $rootproperty2 = $Config2->{_}->{rootproperty}; - $self->{site__username} = $wi->PTN_nickname($Config2->{auth}->{username}); - $self->{site__password} = $Config2->{auth}->{password}; - - #Determine session/..../ directory - $self->{site__session_dir} = $wi->PTN_dirname("$self->{top_dir}/session"); - debug_print("Affelio::read_site_config: session_dir = [$self->{site__session_dir}]"); - debug_print("Affelio::read_site_config: end."); - } - - ###################################################################### - #write_user_prefs - ###################################################################### - sub write_user_prefs{ - my $self = shift; - debug_print("Affelio::write_user_prefs: start."); - - my $Config = Config::Tiny->new(); - $Config = Config::Tiny->read("$self->{site__user_dir}/preference.cfg"); - if($@ || !$Config){ - throw Affelio::exception::SystemException("preference.cfg not found"); - } - - my $rootproperty = $Config->{_}->{rootproperty}; - - #Write preferences - - $Config->{messaging}->{emailflg} = - $self->{userpref__mesging__emailflg}; - $Config->{preference}->{toppage_app_installname} = - $self->{userpref__toppage_app_installname}; - $Config->{preference}->{emailack_friendship_recv} = - $self->{userpref__emailack_fr_recv}; - $Config->{preference}->{preferred_hosting_service} = - $self->{userpref__preferred_hosting_service}; - $Config->{preference}->{skin}= - $self->{userpref__skin}; - - $Config->write("$self->{site__user_dir}/preference.cfg"); - if($@ || !$Config){ - throw Affelio::exception::SystemException("preference.cfg is not writable."); - } - - debug_print("Affelio::write_user_prefs: end."); - } - - ###################################################################### - #read_user_prefs - ###################################################################### - sub read_user_prefs{ - my $self = shift; - debug_print("Affelio::read_user_prefs: start."); - - my $wi = new Affelio::misc::WebInput; - - my $Config = Config::Tiny->new(); - $Config = Config::Tiny->read("$self->{site__user_dir}/preference.cfg"); - if($@ || !$Config){ - throw Affelio::exception::SystemException("Cannot open preference.cfg"); - } - - my $rootproperty = $Config->{_}->{rootproperty}; - - #Read preferences - $self->{userpref__toppage_app_installname} - = $wi->PTN_word($Config->{preference}->{toppage_app_installname}); - $self->{userpref__emailack_fr_recv} - = $wi->PTN_word($Config->{preference}->{emailack_friendship_recv}); - $self->{userpref__preferred_hosting_service} - = $wi->PTN_URL($Config->{preference}->{preferred_hosting_service}); - $self->{userpref__skin} - = $wi->PTN_word($Config->{preference}->{skin}); - - $self->{userpref__mesging__emailflg} - = $wi->PTN_word($Config->{messaging}->{emailflg}); - if($self->{userpref__mesging__emailflg} eq ""){ - $self->{userpref__mesging__emailflg} = "yes"; - } - - debug_print("Affelio::read_user_prefs: end."); - } - - ###################################################################### - #get_guest_owner_list - ###################################################################### - sub get_guest_owner_list{ - my $self = shift; - my $output_ref = shift; - - my @guest_owner_switch=(); - $output_ref->{'guest_owner_switch'} = \@guest_owner_switch; - - my $owner_mode_selected=""; - if($self->{guest_owner_switch} eq "owner"){ - $owner_mode_selected="true"; - }else{ - $owner_mode_selected=""; - } - - my $guest_mode_url=""; - my $owner_mode_url=""; - if($self->{caller}){ - $guest_mode_url - = $self->{am}->{apps}->{$self->{caller}}->{guest_index}; - $owner_mode_url - = $self->{am}->{apps}->{$self->{caller}}->{owner_index}; - }else{ - $guest_mode_url= $self->{site__web_root} . "/index.cgi?mode=index"; - $owner_mode_url= $self->{site__web_root} . "/admin.cgi"; - } - - if($owner_mode_selected){ - push(@guest_owner_switch, - {'selected' => $owner_mode_selected, - 'name' => "Owner", - 'url' => $guest_mode_url, - 'image_over' => "$self->{site__web_root}/icons/owner_over.jpg" - } - ); - - }else{ - push(@guest_owner_switch, - {'selected' => $owner_mode_selected, - 'name' => "Owner", - 'url' => $owner_mode_url, - 'image_normal' => "$self->{site__web_root}/icons/owner_normal.jpg", - } - ); - }#else - - }#method - - - ###################################################################### - #get_module_list - ###################################################################### - sub get_module_list{ - my $self = shift; - my $output_ref = shift; - my $visitor_afid =shift; - my $visitor_type =shift; - - my $selected =""; - my @modules=(); - $output_ref->{'modules'} = \@modules; - - ######################### - #Affelio core - ######################### - if($self->{caller}){ - #Affelio.pm is called by an application - $selected =""; - }else{ - $selected ="true"; - } - - my $dest_url; - if($self->{guest_owner_switch} eq "owner"){ - ####Owner - if($selected eq "true" ){ - $dest_url = $self->{site__web_root} . "/index.cgi?mode=index"; - }else{ - $dest_url = $self->{site__web_root} . "/admin.cgi"; - } - }else{ - ####Guest - if($selected eq "true" ){ - $dest_url = $self->{site__web_root} . "/admin.cgi"; - }else{ - $dest_url = $self->{site__web_root} . "/index.cgi?mode=index"; - } - } - push(@modules, - {'name' => "Affelio", - 'image_normal' => "$self->{site__web_root}/icons/affelio_normal.jpg", - 'image_over' => "$self->{site__web_root}/icons/affelio_over.jpg", - 'url' => $dest_url, - 'selected' => $selected} - ); - - ######################### - #Applications - ######################### - my $tmp_name; - my $this_app_ref; - while ( ($tmp_name, $this_app_ref) = each( %{$self->{am}->{apps}} ) ){ - my %this_app = %$this_app_ref; - - debug_print("Affelio::get_module_list: $this_app{'install_name'}"); - - #Is this application permmited to be printed at the tab?? - $self->{am}->prepare_app_perm_table($this_app{'install_name'}); - - my $perm_to_tab=0; - $perm_to_tab - = $self->{am}->get_summed_app_perm($visitor_afid, - $visitor_type, - $this_app{'install_name'}, - "DF_visibility"); - - if($perm_to_tab ==1 ){ - if($this_app{'install_name'} eq $self->{caller}){ - $selected = "true"; - }else{ - $selected = ""; - } - - my $dest_url = "$self->{site__web_root}/apps/$this_app{'install_name'}/"; - if($self->{guest_owner_switch} eq "owner"){ - #Owner - if($selected eq "true"){ - $dest_url .= $this_app{'guest_index'}; - }else{ - $dest_url .= $this_app{'owner_index'}; - } - }else{ - #Guest - if($selected eq "true"){ - $dest_url .= $this_app{'owner_index'}; - }else{ - $dest_url .= $this_app{'guest_index'}; - } - } - - push(@modules, - {'selected' => $selected, - 'name' => $this_app{'install_title'}, - 'url' => $dest_url, - 'image_normal' => "$self->{site__web_root}/apps/$this_app{'install_name'}/icons/normal.jpg", - 'image_over' => "$self->{site__web_root}/apps/$this_app{'install_name'}/icons/over.jpg" - } - ); - } - }#foreach - - }#method - - - ###################################################################### - #translate_templateL10N - ###################################################################### - sub translate_templateL10N{ - my $af=shift; - my $mesg = shift; - - my $tag_body =""; - my $text_value=""; - my $param_value=""; - - while( $mesg =~ /<AF_M ([^>]+)>/ ){ - $tag_body = $1; - - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["'](\s*)param(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - $param_value=$7; - if($text_value eq ""){ - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - } - - my $sbst = $af->{lh}->maketext($text_value, $param_value); - - debug_print("Affelio::translate tag_body = [$tag_body]\n"); - debug_print("Affelio::translate \t text=[$text_value]\n"); - debug_print("Affelio::translate \t param=[$param_value]\n"); - debug_print("Affelio::translate \t sbst=[$sbst]\n"); - - $mesg =~ s/\Q<AF_M $tag_body>\E/$sbst/g; - } - - return($mesg); - } - - -}#package -1; -########################################################################## - Index: affelio_farm/admin/skelton/affelio/lib/AffelioApp.pm diff -u affelio_farm/admin/skelton/affelio/lib/AffelioApp.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/AffelioApp.pm:removed --- affelio_farm/admin/skelton/affelio/lib/AffelioApp.pm:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/lib/AffelioApp.pm Tue Oct 25 04:20:53 2005 @@ -1,380 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: AffelioApp.pm,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -package AffelioApp; -{ - use strict; - use lib("../extlib"); - use Error qw(:try); - use lib("../../extlib"); - use HTML::Template; - use CGI::Session; - use CGI; - use lib("../lib"); - use Affelio; - use Affelio::misc::Debug; - use Affelio::exception::DBException; - - ###################################################################### - #Constructor - ###################################################################### - sub new{ - my $class = shift; - my %param = @_; - - debug_print("AffelioApp::new: start."); - - ############################ - #app__fs_root, cfg_path - ############################ - my $app__fs_root = $param{ConfigDir}; - my $cfg_path = "$app__fs_root/AF_app.cfg"; - debug_print("AffelioApp::new: ConfigDir =$app__fs_root"); - debug_print("AffelioApp::new: cfg_path =$cfg_path"); - - ############################ - #CGI - ############################ - my $cgi = $param{cgi}; - - ############################ - #Install name - ############################ - my $install_name = $app__fs_root; - $install_name =~ s|/(.*)/||g; - debug_print("AffelioApp::new: install_name=$install_name"); - - ############################ - #Load Affelio - ############################ - my $af = new Affelio(ConfigDir => "$app__fs_root/../../config/", - Caller => $install_name); - - ############################ - #app__web_root - ############################ - my $app__web_root = "$af->{site__web_root}/apps/$install_name"; - debug_print("AffelioApp::new: web_root=$app__web_root"); - debug_print("AffelioApp::new: fs_root =$app__fs_root"); - - ############################ - #create userdata directory as needed - ############################ - if(-e "$af->{site__user_dir}/appdata/$install_name"){ - }else{ - if (-d "$af->{site__user_dir}/appdata/"){ - if (-w "$af->{site__user_dir}/appdata/"){ - my $ret = - mkdir("$af->{site__user_dir}/appdata/$install_name", 0777); - if(!$ret){ - error("Cannot make userdata/appdata/$install_name!"); - } - }else{ - error("Cannot make userdata/appdata/ is NOT writable!"); - } - }else{ - my $ret = - mkdir("$af->{site__user_dir}/appdata/", 0777); - if(!$ret){ - error("Cannot make userdata/appdata/!"); - } - $ret = - mkdir("$af->{site__user_dir}/appdata/$install_name", 0777); - if(!$ret){ - error("Cannot make userdata/appdata/$install_name!"); - } - } - } - - ############################ - #Cookie check! - ############################ - my $sid = $cgi->cookie("affelio-$af->{user__nickname}"); - my $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - my $visitor_type="pb"; - my $visitor_nickname="anonymous"; - my $visitor_afid=""; - if($session){ - $visitor_type = $session->param("type"); - $visitor_nickname = $session->param("user_nickname"); - $visitor_afid = $session->param("user_afid"); - } - if($visitor_type eq ""){ - $visitor_type="pb"; - } - debug_print("AffelioApp::new: visitor_type= $visitor_type"); - debug_print("AffelioApp::new: visitor_nickname= $visitor_nickname"); - debug_print("AffelioApp::new: visitor_afid= $visitor_afid"); - - my $install_title = $af->{am}->{apps}->{$install_name}->{install_title}; - - my $dbh = $af->openAppDB($install_name); - - #bless - my $self = {cfg_path => $cfg_path, - app__fs_root => $app__fs_root, - app__web_root => $app__web_root, - install_name => $install_name, - install_title => $install_title, - af => $af, - cgi => $cgi, - session => $session, - visitor_type => $visitor_type, - visitor_nickname => $visitor_nickname, - visitor_afid => $visitor_afid, - userdata_dir => "$af->{site__user_dir}/appdata/$install_name/", - userdata_dbh => $dbh - }; - bless $self, $class; - - ############################ - #Am I in the owner mode? - ############################ - debug_print("AffelioApp::new: cfg_path =$cfg_path"); - my $Config = Config::Tiny->new(); - - try{ - $Config = Config::Tiny->read($cfg_path); - }catch Error with{ - throw Affelio::exception::SystemException("AFApp.cfg not found"); - } - my $rootproperty = $Config->{_}->{rootproperty}; - my $owner_index = $Config->{application}->{owner_index}; - debug_print("AffelioApp::new: owner_index =$owner_index"); - - if($cgi->self_url =~/$owner_index/){ - $self->set_owner_mode(); - } - - ############################ - debug_print("AffelioApp::new: end."); - return $self; - } - - ###################################################################### - #get_userdata_dir - ###################################################################### - sub get_userdata_dir{ - my $self = shift; - return($self->{userdata_dir}); - } - - ###################################################################### - #get_userdata_dbh - ###################################################################### - sub get_userdata_dbh{ - my $self = shift; - return($self->{userdata_dbh}); - } - - - ###################################################################### - #check_access - ###################################################################### - sub check_access{ - my $self = shift; - my $action_type = shift; - - my $ret=0; - try{ - $ret= - $self->{af}->{am}->get_summed_app_perm($self->{visitor_afid}, - $self->{visitor_type}, - $self->{install_name}, - $action_type); - }catch Affelio::exception::DBException with{ - - }; - - return($ret); - } - - ###################################################################### - #set_owner_mode: Flag this AffelioApp as "owner" mode. - ###################################################################### - sub set_owner_mode{ - my $self = shift; - $self->{af}->set_owner_mode(); - } - - ###################################################################### - #get_visitor_info - ###################################################################### - sub get_visitor_info{ - my $self = shift; - my $info_name = shift; - - if($info_name eq "nickname"){ - return($self->{visitor_nickname}); - }elsif($info_name eq "afid"){ - return($self->{visitor_afid}); - }elsif($info_name eq "type"){ - return($self->{visitor_type}); - } - return; - } - - ###################################################################### - #get_session_param - ###################################################################### - sub get_session_param{ - my $self = shift; - my $param_name = shift; - - return($self->{session}->param($param_name)); - } - - ###################################################################### - #set_session_param - ###################################################################### - sub set_session_param{ - my $self = shift; - my $param_name = shift; - my $param_val = shift; - - $self->{session}->param($param_name, $param_val); - return; - } - - ###################################################################### - #get_site_info - ###################################################################### - sub get_site_info{ - my $self = shift; - my $info_name = shift; - - if($info_name eq "web_root"){ - return($self->{af}->{site__web_root}); - } - if($info_name eq "locale"){ - return($self->{af}->{site__locale}); - } - - return; - } - - ###################################################################### - #get_owner_info - ###################################################################### - sub get_owner_info{ - my $self = shift; - my $info_name = shift; - - if($info_name eq "nickname"){ - return($self->{af}->{user__nickname}); - }elsif($info_name eq "afid"){ - return($self->{af}->{site__web_root}); - } - return; - } - - ###################################################################### - #get_HTML_header - ###################################################################### - sub get_HTML_header{ - my $self = shift; - my $app__page_title = shift; - - my $af = $self->{af}; - - #Set template file name - my $TMPL_FILE = "$af->{site__fs_root}/templates_dyn/Header.tmpl"; - #Set data for template - my %output_data = (); - $output_data{'app__css_path'} = $self->{app__web_root}; - $output_data{'app__page_title'} = $app__page_title; - $output_data{"site__skin_dir"} = $af->{site__web_root} . "/skins/" . $af->{userpref__skin}; - $output_data{'site__web_root'} = $af->{site__web_root}; - $output_data{'site__locale'} = $af->{site__locale}; - - $af->get_module_list(\%output_data, $self->{visitor_afid},$self->{visitor_type}); - $af->get_guest_owner_list(\%output_data); - - #Initiate Template - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - foreach my $data_key (keys(%output_data)) { - debug_print("$data_key = $output_data{$data_key}"); - $tmpl->param($data_key => $output_data{$data_key}); - } - - my $final_out = $af->translate_templateL10N($tmpl->output) - . '<div class="afPubMain">' . "\n"; - - return($final_out); - - } - - ###################################################################### - #get_HTML_footer - ###################################################################### - sub get_HTML_footer{ - my $self = shift; - my $af = $self->{af}; - - #Set template file name - my $TMPL_FILE = "$af->{site__fs_root}/templates_dyn/Footer.tmpl"; - my $tmpl = new HTML::Template(filename => $TMPL_FILE); - - my $final_out = "</div><!--afPubMain-->" - . $af->translate_templateL10N($tmpl->output); - - return($final_out); - } - - ###################################################################### - #get_app_info - ###################################################################### - sub get_app_info{ - my $self = shift; - my $info_name = shift; - - if($info_name eq "install_title"){ - return($self->{install_title}); - } - return; - } - - ###################################################################### - #get_URL - ###################################################################### - sub get_URL{ - my $self = shift; - my $af = $self->{af}; - my $name = shift; - - my $ret=""; - if(($name eq "access_control") && ($self->{visitor_type} eq "self")){ - $ret = $af->{site__web_root} . "/admin.cgi?mode=access_control_apps&mode2=show_app&app_name=" . $self->{install_name}; - } - - return($ret); - } - - ###################################################################### - #Destructor - ###################################################################### - sub DESTROY{ - my $self = shift; - } - -}#package -1; -########################################################################## From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:53 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:53 +0900 Subject: [Affelio-cvs 677] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/App Message-ID: <20051024192053.CE2FF2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/FriendRoutines.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/FriendRoutines.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/FriendRoutines.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/FriendRoutines.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/FriendRoutines.pm Tue Oct 25 04:20:53 2005 @@ -1,368 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: FriendRoutines.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::FriendRoutines; -{ - use strict; - - use lib("../../../extlib/"); - use lib("../../../lib"); - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - use Affelio::misc::Time qw(get_timestamp get_expire_stamp); - use Affelio::misc::NetMisc qw(get_remote_host); - - use Exporter; - @Affelio::App::FriendRoutines::ISA = "Exporter"; - @Affelio::App::FriendRoutines::EXPORT = qw (get_friends_list_IF get_friends_list generate_getcontentURL get_summed_permission_list); - - ##################################################################### - #get_summed_permission_list - ##################################################################### - sub get_summed_permission_list{ - my $af = shift; #arg(1) AF - my $visitor_id = shift; #arg(2) visitor_ID - my $visitor_mode = shift; #arg(3) visitor_mode - my @ret_list=(); - - debug_print("get_summed_permission_list: start."); - debug_print("get_summed_permission_list: visitor_id = $visitor_id"); - debug_print("get_summed_permission_list: visitor_mode= $visitor_mode"); - - if($visitor_mode eq "f2" || $visitor_mode eq "pb"){ - #################### - # f2 or PB - #################### - - my $SQL_ret = $af->{perm}->get_permission("f", $visitor_mode); - @ret_list = $SQL_ret->fetchrow_array; - # Now... - # $ret_list[0] = Permission ID - # $ret_list[1] = "f" - # $ret_list[2] = "f2" - # $ret_list[3] = perm for nickname ...aid=1 - # $ret_list[4] = perm for 1st element ...aid=2 - - shift(@ret_list); - shift(@ret_list); - shift(@ret_list); - # $ret_list[0] = perm for nickname ...aid=0 - # $ret_list[1] = perm for 1st element ...aid=1 - - }elsif($visitor_mode eq "self"){ - - #################### - # self - #################### - - #In case of "self" .... everything is 1. - my $attributes = $af->{pm}->get_attribute_table(); - - my @row=(); - while(@row = $attributes->fetchrow_array){ - push(@ret_list, 1) - } - - }else{ - #################### - # f1 - #################### - #We will make - # perm(f1) OR Vx(perm(G)) - - #Get permssion for F1 - my $SQL_ret1 = $af->{perm}->get_permission("f", $visitor_mode); - @ret_list = $SQL_ret1->fetchrow_array; - - #Get the visitor's UID - my ($t_uid, $t_afid, $t_nickname, $t_time, - $t_pass, $t_intro, $t_pid, $t_lastupdated, $t_f2list) - = $af->{fm}->get_friend_by_afid($visitor_id); - - #Get the visitor's groups - my $SQL_result = $af->{gm}->get_groups_by_uid($t_uid); - - #For each group... - my @g_data=(); - while(@g_data = $SQL_result->fetchrow_array) { - my $gid = $g_data[0]; - my $SQL_ret2 = $af->{perm}->get_permission("g", $gid); - my @list1 = $SQL_ret2->fetchrow_array; - - #For each value... - my $i=0; - for($i=0; $i <= $#list1; $i++){ - - $ret_list[$i] = $ret_list[$i] | $list1[$i] - } - } - - # Now... - # $ret_list[0] = Permission ID - # $ret_list[1] = "f" - # $ret_list[2] = "f2" - # $ret_list[3] = perm for nickname ...aid=1 - # $ret_list[4] = perm for 1st element ...aid=2 - - shift(@ret_list); - shift(@ret_list); - shift(@ret_list); - # Now... - # $ret_list[0] = perm for nickname ...aid=0 - # $ret_list[1] = perm for 1st element ...aid=1 - } - - - return(@ret_list); - } - - - - ##################################################################### - #get_friends_list - ##################################################################### - sub get_friends_list{ - my $af = shift; #arg(1) AF - my $visitor_id = shift; #arg(2) visitor_ID - my $visitor_type = shift; #arg(3) visitor_ID - my $max_friend_num = shift; #arg(4) max num - my @ret_list; - - if ($visitor_id eq ""){ - $visitor_id = "anonymous"; - } - - debug_print("FriendRoutines: visitor_id=$visitor_id"); - debug_print("FriendRoutines: visitor_type=$visitor_type"); - - ###################################### - #Get all friends' table from FriendManager - ###################################### - my $sth = $af->{fm}->get_all_friend_list(); - - ###################################### - #Build up a return array - ###################################### - my @person=(); - my $count = $max_friend_num; - - while((@person = $sth->fetchrow_array) - && (($count > 0) || ($count == -1)) - ) { - debug_print("FriendRoutines: friend=(@person)"); - #$person[0] uid - #$person[1] af_id - #$person[2] nickname - #$person[3] timestamp - #$person[4] password - #$person[5] intro - #$person[6] option_pid - #$person[7] lastupdated - #$person[8] f2list - - my $image_URL = generate_getcontentURL($af, - $visitor_id, - $visitor_type, - $person[1], - $person[4], - "core", - "/profile/profile_face.jpg"); - debug_print("FriendRoutines: image_URL= $image_URL\n"); - - my $mystatus_URL = generate_getcontentURL($af, - $visitor_id, - $visitor_type, - $person[1], - $person[4], - "core", - "/profile/mystatus"); - debug_print("FriendRoutines: mystatus_URL= $mystatus_URL\n"); - - #Generate Hyperlink target URL - my $dest_URL = $af->{site__web_root} . "/outgoing.cgi?dest_url=" . $person[1]; - - my $editurl=""; - if($visitor_type eq "self"){ - $editurl = $af->{site__web_root} . "/admin.cgi?mode=manage_friends&mode2=show_member&uid=" . $person[0]; - } - my $mailurl=""; - if($visitor_type eq "self"){ - $mailurl = $af->{site__web_root} . "/admin.cgi?mode=messages&action=compose&reply_to=" . $person[1]; - } - - push(@ret_list, {nickname => $person[2], - URL => $dest_URL, - image_URL => $image_URL, - editurl => $editurl, - mailurl => $editurl, - intro => $person[5], - mystatus_URL => $mystatus_URL - } - ); - - if($max_friend_num > 0){ - $count--; - } - }#while - - return(@ret_list); - - } - - - - ##################################################################### - #get_friends_list_IF - ##################################################################### - sub get_friends_list_IF{ - my $af = shift; #arg(1) AF - my $visitor_id = shift; #arg(2) visitor_ID - my $visitor_type = shift; #arg(3) visitor_ID - my $max_friend_num = shift; #arg(4) max num - my @ret_list; - - if ($visitor_id eq ""){ - $visitor_id = "anonymous"; - } - - ###################################### - #Get all friends' table from FriendManager - ###################################### - my $sth = $af->{fm}->get_all_friend_list(); - - ###################################### - #Build up a return array - ###################################### - my @person=(); - my $count = $max_friend_num; - - while((@person = $sth->fetchrow_array) - && (($count > 0) || ($count == -1)) - ) { - debug_print("FriendRoutines: friend=(@person)"); - #$person[0] uid - #$person[1] af_id - #$person[2] nickname - #$person[3] timestamp - #$person[4] password - #$person[5] intro - #$person[6] option_pid - #$person[7] lastupdated - #$person[8] f2list - - my $image_URL = generate_getcontentURL($af, - $visitor_id, - $visitor_type, - $person[1], - $person[4], - "core", - "/profile/profile_face.jpg"); - debug_print("FriendRoutines: image_URL= $image_URL\n"); - - my $mystatus_URL = generate_getcontentURL($af, - $visitor_id, - $visitor_type, - $person[1], - $person[4], - "core", - "/profile/mystatus_iframe"); - debug_print("FriendRoutines: mystatus_URL= $mystatus_URL\n"); - - #Generate Hyperlink target URL - my $dest_URL = $af->{site__web_root} . "/outgoing.cgi?dest_url=" . $person[1]; - - my $editurl=""; - if($visitor_type eq "self"){ - $editurl = $af->{site__web_root} . "/admin.cgi?mode=manage_friends&mode2=show_member&uid=" . $person[0]; - } - - my $mailurl=""; - if($visitor_type eq "self"){ - $mailurl = $af->{site__web_root} . "/admin.cgi?mode=messages&action=compose&reply_to=" . $person[1]; - } - - push(@ret_list, {nickname => $person[2], - URL => $dest_URL, - image_URL => $image_URL, - editurl => $editurl, - mailurl => $mailurl, - intro => $person[5], - mystatus_URL => $mystatus_URL - } - ); - - if($max_friend_num > 0){ - $count--; - } - }#while - - return(@ret_list); - - } - - - ###################################################################### - #generate_contentURL - # returns image_URL - # arg(1) af - # arg(2) visitor's ID - # arg(3) visitor's type - # arg(4) friend's AF_ID - # arg(5) friend's password - # arg(6) destination module "core" "app1" "app2" etc.. - # arg(7) content name - ###################################################################### - sub generate_getcontentURL{ - my $af = shift; - my $visitor_afid = shift; - my $visitor_type = shift; - my $f_af_id = shift; - my $f_password = shift; - my $module =shift; - my $content =shift; - - #1.PassAB(timestamp, - # expire, - # browser's IP, - # AF_ID, Who is accessing? - # type) - - my $plaintext = - get_timestamp() . "*" . - get_expire_stamp(0,0,15) . "*" . - get_remote_host(%ENV) . "*" . - $visitor_afid . '*' . - $visitor_type . '*'; - - debug_print("generate_getcontentURL: [$plaintext]\n"); - - my $getcontentURL = $f_af_id - . "/bin/get_content.cgi?module=$module&content=$content&cfid=" - . url_encode( msg_encrypt($plaintext, $f_password)) - . "&referrer=" . $af->{site__web_root}; - - return($getcontentURL); - - }#func - - - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/ShowProfile.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/ShowProfile.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/ShowProfile.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/ShowProfile.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/ShowProfile.pm Tue Oct 25 04:20:53 2005 @@ -1,85 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ShowProfile.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::ShowProfile; -{ - use strict; - - use lib("../../../extlib/"); - use lib("../../../lib"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::Time; qw( get_timestamp); - use Affelio::misc::NetMisc; qw( get_remote_host); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - use Affelio::App::FriendRoutines; - - use Exporter; - @Affelio::App::ShowProfile::ISA = "Exporter"; - @Affelio::App::ShowProfile::EXPORT = qw (show_profile); - - - ####################################################################### - #show_profile - ####################################################################### - sub show_profile{ - my $af = shift; - my $output_data_ref = shift; - my $viewers_mode = shift; - my $viewers_id = shift; - - debug_print("ShowProfile::show_profile: start view_mode=[$viewers_mode], viewer_id=[$viewers_id]"); - - #Get summarized permission list for the given user - my @list - = get_summed_permission_list($af, $viewers_id, $viewers_mode); - debug_print("ShowProfile::show_profile: Got summarized permission..."); - debug_print("ShowProfile::show_profile: \t[@list]"); - - #@list containts... - # $list[0] = perm for nickname ...aid=0 - # $list[1] = perm for 1st element ...aid=1 - # $list[2] = ... - - my $attributes = $af->{pm}->get_attribute_table(); - - my @row=(); - while(@row = $attributes->fetchrow_array){ - - debug_print("ShowProfile: aid[$row[0]] attr[$row[1]] show? =$list[$row[0]]"); - - if($list[$row[0]] eq "1"){ - $$output_data_ref{"flg_$row[1]"} - = "true"; - - $$output_data_ref{"profile_$row[1]"} - = $af->{'user__' . $row[1]}; - } - } - - $$output_data_ref{"profile_intromesg1"} =~ s/\n\n/<P>/g; - $$output_data_ref{"profile_intromesg1"} =~ s/\n/<BR>/g; - - $$output_data_ref{"profile_intromesg2"} =~ s/\n\n/<P>/g; - $$output_data_ref{"profile_intromesg2"} =~ s/\n/<BR>/g; - - } - -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:54 +0900 Subject: [Affelio-cvs 678] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks Message-ID: <20051024192054.4D2072AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/access_tab_h.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/access_tab_h.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/access_tab_h.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/access_tab_h.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/access_tab_h.aftag Tue Oct 25 04:20:54 2005 @@ -1,12 +0,0 @@ -<table> -<!--Core/App switch tab--> -<tr> -<TMPL_LOOP NAME="modules"> -<TMPL_IF NAME="selected"> - <th><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></th> -<TMPL_ELSE> - <td><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></td> -</TMPL_IF> -</TMPL_LOOP> -</tr> -</table> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5.aftag Tue Oct 25 04:20:54 2005 @@ -1,16 +0,0 @@ -<div class="aftag__friendlist_5"> -<TMPL_LOOP NAME="friendlist_5"> -<div class="aftag__friendlist_5__field"> -<div class="aftag__friendlist_5__name"> -<nobr><TMPL_VAR ESCAPE="HTML" NAME="nickname"></nobr> -</div><!--name--> -<div class="aftag__friendlist_5__status"> -<nobr><script language="JavaScript" src="<TMPL_VAR NAME="mystatus_URL">"></script></nobr> -</div><!--status--> -<BR> -<div class="aftag__friendlist_5__image"> -<A HREF="<TMPL_VAR ESCAPE="HTML" NAME="URL">"><IMG SRC="<TMPL_VAR ESCAPE="HTML" NAME="image_URL">" WIDTH="100" BORDER="0"></A> -</div><!--image--> -</div><!--field--> -</TMPL_LOOP> -</div> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5_IF.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5_IF.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5_IF.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5_IF.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_5_IF.aftag Tue Oct 25 04:20:54 2005 @@ -1,13 +0,0 @@ -<div class="aftag__friendlist_5"> -<TMPL_LOOP NAME="friendlist_5_IF"> -<div class="aftag__friendlist_5__field"> -<div class="aftag__friendlist_5__name"> -<nobr><TMPL_VAR ESCAPE="HTML" NAME="nickname"></nobr> -</div><!--name--> -<iframe frameborder="0" style="height: 20px;" class="aftag__friendlist_5__status" scrolling="no" src="<TMPL_VAR NAME="mystatus_URL">"></iframe> -<div class="aftag__friendlist_5__image"> -<A HREF="<TMPL_VAR ESCAPE="HTML" NAME="URL">"><IMG SRC="<TMPL_VAR ESCAPE="HTML" NAME="image_URL">" WIDTH="100" BORDER="0"></A> -</div><!--image--> -</div><!--field--> -</TMPL_LOOP> -</div> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag Tue Oct 25 04:20:54 2005 @@ -1,20 +0,0 @@ -<div class="aftag__friendlist_all"> -<TMPL_LOOP NAME="friendlist_all"> -<div class="aftag__friendlist_all__field"> -<div class="aftag__friendlist_all__name"> -<nobr><TMPL_VAR ESCAPE="HTML" NAME="nickname"></nobr> -</div><!--name--> -<div class="aftag__friendlist_all__status"> -<nobr><script language="JavaScript" src="<TMPL_VAR NAME="mystatus_URL">"></script></nobr> -</div><!--status--> -<BR> -<div class="aftag__friendlist_all__image"> -<A HREF="<TMPL_VAR ESCAPE="HTML" NAME="URL">"><IMG SRC="<TMPL_VAR ESCAPE="HTML" NAME="image_URL">" WIDTH=100 BORDER=0></A> -</div><!--image--> -<BR> -<div class="aftag__friendlist_all__intro"> -<TMPL_VAR ESCAPE="HTML" NAME="intro"> <TMPL_IF NAME="editurl"><A HREF="<TMPL_VAR NAME="editurl">" target="_blank">[edit]</A></TMPL_IF> <TMPL_IF NAME="mailurl"><A HREF="<TMPL_VAR NAME="mailurl">" target="_blank">[mail]</A></TMPL_IF> -</div><!--intro--> -</div><!--field--> -</TMPL_LOOP> -</div> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all_IF.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all_IF.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all_IF.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all_IF.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all_IF.aftag Tue Oct 25 04:20:54 2005 @@ -1,17 +0,0 @@ -<div class="aftag__friendlist_all"> -<TMPL_LOOP NAME="friendlist_all_IF"> -<div class="aftag__friendlist_all__field"> -<div class="aftag__friendlist_all__name"> -<nobr><TMPL_VAR ESCAPE="HTML" NAME="nickname"></nobr> -</div><!--name--> -<iframe frameborder="0" class="aftag__friendlist_all__status" style="height: 20px;" scrolling="no" src="<TMPL_VAR NAME="mystatus_URL">"></iframe> -<div class="aftag__friendlist_all__image"> -<A HREF="<TMPL_VAR ESCAPE="HTML" NAME="URL">"><IMG SRC="<TMPL_VAR ESCAPE="HTML" NAME="image_URL">" WIDTH=100 BORDER=0></A> -</div><!--image--> -<BR> -<div class="aftag__friendlist_all__intro"> -<TMPL_VAR ESCAPE="HTML" NAME="intro"> <TMPL_IF NAME="editurl"><A HREF="<TMPL_VAR NAME="editurl">" target="_blank">[edit]</A></TMPL_IF> <TMPL_IF NAME="mailurl"><A HREF="<TMPL_VAR NAME="mailurl">" target="_blank">[mail]</A></TMPL_IF> -</div><!--intro--> -</div><!--field--> -</TMPL_LOOP> -</div> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/guestowner_tab_v.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/guestowner_tab_v.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/guestowner_tab_v.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/guestowner_tab_v.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/guestowner_tab_v.aftag Tue Oct 25 04:20:54 2005 @@ -1,14 +0,0 @@ -<table> -<!--guest/owner tab--> -<TMPL_LOOP NAME="guest_owner_switch"> -<TMPL_IF NAME="selected"> - <tr> - <th><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></th> - </tr> -<TMPL_ELSE> - <tr> - <td><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></td> - </tr> -</TMPL_IF> -</TMPL_LOOP> -</table> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/profile_table.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/profile_table.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/profile_table.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/profile_table.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/profile_table.aftag Tue Oct 25 04:20:54 2005 @@ -1,93 +0,0 @@ -<div class="aftag__profile_table"> - -<TMPL_IF NAME="flg_n_family"> -<div class="aftag__profile_table__th"><AF_M text="Last">:</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_n_family"></div> -<div style="clear: both;" /> -</TMPL_IF> - -<TMPL_IF NAME="flg_n_other"> -<div class="aftag__profile_table__th"><AF_M text="Middle">:</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_n_other"> </div> -<div style="clear: both;" /> -</TMPL_IF> - -<TMPL_IF NAME="flg_n_given"> -<div class="aftag__profile_table__th"><AF_M text="Given">:</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_n_given"> </div> -<div style="clear: both;" /> -</TMPL_IF> - -<div class="aftag__profile_table__th"> </div><div class="aftag__profile_table__td"> </div> - -<TMPL_IF NAME="flg_bday"><TMPL_IF NAME="profile_bday"> -<div class="aftag__profile_table__th">Birthday:</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_bday"> </div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<div class="aftag__profile_table__th"> </div><div class="aftag__profile_table__td"> </div> - -<TMPL_IF NAME="flg_email1"><TMPL_IF NAME="profile_email1"> -<div class="aftag__profile_table__th">Email:<BR>(<TMPL_VAR NAME="profile_email1_desc">)</div> -<div class="aftag__profile_table__td"> -<A HREF="mailto:<TMPL_VAR NAME="profile_email1">"><TMPL_VAR NAME="profile_email1"></A> -</div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<TMPL_IF NAME="flg_email2"><TMPL_IF NAME="profile_email2"> -<div class="aftag__profile_table__th">Email:<BR>(<TMPL_VAR NAME="profile_email2_desc">)</div> -<div class="aftag__profile_table__td"> -<A HREF="mailto:<TMPL_VAR NAME="profile_email2">"><TMPL_VAR NAME="profile_email2"></A> -</div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<div class="aftag__profile_table__th"> </div><div class="aftag__profile_table__td"> </div> - -<TMPL_IF NAME="flg_url1"><TMPL_IF NAME="profile_url1"> -<div class="aftag__profile_table__th">URL:<BR>(<TMPL_VAR NAME="profile_url1_desc">)</div> -<div class="aftag__profile_table__td"> -<A HREF="<TMPL_VAR NAME="profile_url1">"><TMPL_VAR NAME="profile_url1"></A> -</div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<TMPL_IF NAME="flg_url2"><TMPL_IF NAME="profile_url2"> -<div class="aftag__profile_table__th">URL:<BR>(<TMPL_VAR NAME="profile_url2_desc">)</div> -<div class="aftag__profile_table__td"> -<A HREF="<TMPL_VAR NAME="profile_url2">"><TMPL_VAR NAME="profile_url2"></A> -</div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<div class="aftag__profile_table__th"> </div><div class="aftag__profile_table__td"> </div> - -<TMPL_IF NAME="flg_im1"><TMPL_IF NAME="profile_im1"> -<div class="aftag__profile_table__th">IM:<BR>(<TMPL_VAR NAME="profile_im1_desc">)</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_im1"> </div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<TMPL_IF NAME="flg_im2"><TMPL_IF NAME="profile_im2"> -<div class="aftag__profile_table__th">IM:<BR>(<TMPL_VAR NAME="profile_im2_desc">)</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_im2"> </div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<TMPL_IF NAME="flg_im3"><TMPL_IF NAME="profile_im3"> -<div class="aftag__profile_table__th">IM:<BR>(<TMPL_VAR NAME="profile_im3_desc">)</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_im3"> </div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -<div class="aftag__profile_table__th"> </div><div class="aftag__profile_table__td"> </div> - -<TMPL_IF NAME="flg_intromesg2"><TMPL_IF NAME="profile_intromesg2"> -<div class="aftag__profile_table__th"><AF_M text="Introduction2">:</div> -<div class="aftag__profile_table__td"><TMPL_VAR NAME="profile_intromesg2"> </div> -<div style="clear: both;" /> -</TMPL_IF></TMPL_IF> - -</div> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/unified_imgtab_h.aftag diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/unified_imgtab_h.aftag:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/unified_imgtab_h.aftag:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/unified_imgtab_h.aftag:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AFTemplateBlocks/unified_imgtab_h.aftag Tue Oct 25 04:20:54 2005 @@ -1,28 +0,0 @@ -<div class="aftag__unified_imgtab_h"> -<TMPL_LOOP NAME="guest_owner_switch"> -<div class="aftag__unified_imgtab_h__left_field" style="margin-right: 10px;"> -<TMPL_IF NAME="selected"> -<span class="aftag__unified_imgtab_h__icon"> -<A HREF="<TMPL_VAR NAME="url">"><img src="<TMPL_VAR NAME="image_over">" class="aftag__unified_imgtab_h__icon" border="0" title="<TMPL_VAR NAME="name">"></A></span> -<span class="aftag__unified_imgtab_h__text_selected"><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></span> -<TMPL_ELSE> -<span class="aftag__unified_imgtab_h__icon"> -<A HREF="<TMPL_VAR NAME="url">"><img src="<TMPL_VAR NAME="image_normal">" class="aftag__unified_imgtab_h__icon" border="0" title="<TMPL_VAR NAME="name">"></A></span> -<span class="aftag__unified_imgtab_h__text"><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></span> -</TMPL_IF> -</div> -</TMPL_LOOP> -<TMPL_LOOP NAME="modules"> -<div class="aftag__unified_imgtab_h__left_field"> -<TMPL_IF NAME="selected"> -<span class="aftag__unified_imgtab_h__icon"> -<A HREF="<TMPL_VAR NAME="url">"><img src="<TMPL_VAR NAME="image_over">" border="0" class="aftag__unified_imgtab_h__icon" title="<TMPL_VAR NAME="name">"></A></span> -<span class="aftag__unified_imgtab_h__text_selected"><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></span> -<TMPL_ELSE> -<span class="aftag__unified_imgtab_h__icon"> -<A HREF="<TMPL_VAR NAME="url">"><img src="<TMPL_VAR NAME="image_normal">" border="0" class="aftag__unified_imgtab_h__icon" title="<TMPL_VAR NAME="name">"></A></span> -<span class="aftag__unified_imgtab_h__text"><A HREF="<TMPL_VAR NAME="url">"><TMPL_VAR NAME="name"></A></span> -</TMPL_IF> -</div> -</TMPL_LOOP> -</div> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:54 +0900 Subject: [Affelio-cvs 679] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin Message-ID: <20051024192054.18B1E2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessControl.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessControl.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessControl.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessControl.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessControl.pm Tue Oct 25 04:20:53 2005 @@ -1,257 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: AccessControl.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::AccessControl; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../../lib/"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - - use Exporter; - @Affelio::App::Admin::AccessControl::ISA = "Exporter"; - @Affelio::App::Admin::AccessControl::EXPORT = qw (show_GroupAttribute_table save_GroupAttribute_table); - - ##################################################################### - #save_GroupAttribute_table - ##################################################################### - sub save_GroupAttribute_table{ - my $af = shift; #arg(1) AF - my $q = shift; #arg(2) CGI - - my @params = $q->param; - foreach my $i (@params){ - debug_print("save_GroupAttribute_tbl: [$i] =". $q->param($i)); - } - - ####################################################### - # Save F1, F2, and PB - { - my @gids = ("f1", "f2", "pb"); - my @group_names = ($af->{lh}->maketext("_VISITOR_TYPE_F1"), - $af->{lh}->maketext("_VISITOR_TYPE_F2"), - $af->{lh}->maketext("_VISITOR_TYPE_PB")); - my @option_pids = (1,2,3); - - for(my $i=0; $i<3; $i++){ - my $gid = $gids[$i]; - my $group_name = $group_names[$i]; - my $option_pid = $option_pids[$i]; - - debug_print("save_GroupAttribute_table: For group[$gid]..."); - - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - #Set values - my @g_perm=(); - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - if($q->param("f__" . $gid . "__" . $attr_name) eq "on"){ - $g_perm[$attr_id] = 1; - }else{ - $g_perm[$attr_id] = 0; - } - } - $g_perm[0] = 1; - debug_print("save_GroupAttribute_table: group_permission=[@g_perm]"); - $af->{perm}->update_permission($option_pid, \@g_perm); - - } #while - }#part - - - ####################################################### - # Save registered groups - { - my $groups_SQL = $af->{gm}->get_all_group_list(); - - #For each group returned... - while( (my ($gid, $group_name, $members, $option_pid) - = $groups_SQL->fetchrow_array)){ - - debug_print("save_GroupAttribute_table: For group[$gid] (pid=$option_pid)..."); - if($gid <1){last;} - - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - #Set values - my @g_perm=(); - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - if($q->param("g__" . $gid . "__" . $attr_name) eq "on"){ - $g_perm[$attr_id] = 1; - }else{ - $g_perm[$attr_id] = 0; - } - } - $g_perm[0] = 1; - debug_print("save_GroupAttribute_table: group_permission=[@g_perm]"); - $af->{perm}->update_permission($option_pid, \@g_perm); - - }#while - }#part - - ####################################################### - # Save newly added group - { - if($q->param("newg_group_name") ne ""){ - - my $gid = $af->{gm}->add_group($q->param("newg_group_name")); - - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - #Set values - my @g_perm=(); - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - if($q->param("newg_" . $attr_name) eq "on"){ - $g_perm[$attr_id] = 1; - }else{ - $g_perm[$attr_id] = 0; - } - } - $g_perm[1] = 1; - debug_print("save_GroupAttribute_table: newg group=[@g_perm]"); - $af->{perm}->add_permission("g", $gid, \@g_perm); - - } - } - } - - - ##################################################################### - #show_GroupAttribute_table - ##################################################################### - sub show_GroupAttribute_table{ - my $af = shift; #arg(1) AF - my $output_ref = shift; #arg(3) ref of %output_data; - - debug_print("show_GroupAttribute_table: start."); - my @groups_ret1=(); - my @groups_ret2=(); - - ####################################################### - # F1, F2, and PB - { - my @gids = ("f1", "f2", "pb"); - my @group_names = ($af->{lh}->maketext("_VISITOR_TYPE_F1"), - $af->{lh}->maketext("_VISITOR_TYPE_F2"), - $af->{lh}->maketext("_VISITOR_TYPE_PB")); - my @option_pids = (1,2,3); - - for(my $i=0; $i<3; $i++){ - my $gid = $gids[$i]; - my $group_name = $group_names[$i]; - my $option_pid = $option_pids[$i]; - - debug_print("show_GroupAttribute_table: For group[$gid]..."); - - #set group_name - my %this_group_ret =(); - $this_group_ret{"group_name"} = $group_name; - - #For each group, get the permission list. - my $g_perm_result = $af->{perm}->get_permission("f", "$gid"); - my @g_perm = $g_perm_result->fetchrow_array; - debug_print("show_GroupAttribute_table: group_permission=[@g_perm]"); - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - #Set values - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - - debug_print("show_GroupAttribute_table: attr_id=$attr_id ($attr_name)"); - - $this_group_ret{"chkbox_id__" . $attr_name} - = "f__" . $gid . "__" . $attr_name; - - if($g_perm[$attr_id+3] >= 1){ - $this_group_ret{"chkbox_chkd_flg__" . $attr_name} - ="checked"; - }else{ - $this_group_ret{"chkbox_chkd_flg__" . $attr_name} - =""; - } - } - - push(@groups_ret1, \%this_group_ret); - - - } #while - - }#part - - - ####################################################### - # Registered Groups - my $groups_SQL = $af->{gm}->get_all_group_list(); - - #For each group returned... - while( (my ($gid, $group_name, $members, $option_pid) - = $groups_SQL->fetchrow_array)){ - - debug_print("show_GroupAttribute_table: For group[$gid]..."); - - if($gid <1){last;} - - #set group_name - my %this_group_ret =(); - $this_group_ret{"group_name"} = $group_name; - - #For each group, get the permission list. - my $g_perm_result = $af->{perm}->get_permission("g", "$gid"); - my @g_perm = $g_perm_result->fetchrow_array; - debug_print("show_GroupAttribute_table: group_permission=[@g_perm]"); - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - #Set values - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - - $this_group_ret{"chkbox_id__" . $attr_name} - = "g__" . $gid . "__" . $attr_name; - - if($g_perm[$attr_id+3] >= 1){ - $this_group_ret{"chkbox_chkd_flg__" . $attr_name} - ="checked"; - }else{ - $this_group_ret{"chkbox_chkd_flg__" . $attr_name} - =""; - } - } - - push(@groups_ret2, \%this_group_ret); - }#while - - $output_ref->{"groups1"} = \@groups_ret1; - $output_ref->{"groups2"} = \@groups_ret2; - - } - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessLog.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessLog.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessLog.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessLog.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AccessLog.pm Tue Oct 25 04:20:53 2005 @@ -1,114 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: AccessLog.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::AccessLog; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Time; - use Affelio::misc::WebInput; - - use Exporter; - @Affelio::App::Admin::AccessLog::ISA = "Exporter"; - @Affelio::App::Admin::AccessLog::EXPORT = qw (show); - - - ####################################################################### - #show - ####################################################################### - sub show{ - my $af= shift; - my $q=shift; - my $output_ref = shift; - my $wi = new Affelio::misc::WebInput; - - debug_print("AccessLog::show start."); - - my @access_log=(); - $output_ref->{"access_log"} = \@access_log; - - ############################### - #start and end time - ############################### - #my $start_time = get_today(); - my $start_time = "20050620000000"; - my $cur_time = get_timestamp(); - - ############################### - #Today's date - ############################### - #my $t_year = substr ($start_time, 0, 4); - #my $t_mon = substr ($start_time, 4, 2); - #my $t_mday = substr ($start_time, 6, 2); - #$output_ref->{"log_date"} = "$t_year/$t_mon/$t_mday"; - - ############################### - #Access to AccessLog Manager - ############################### - my $result = $af->{alm}->get_log($start_time, $cur_time); - - ############################### - #Parse result - ############################### - while( my ($id, $id2, $time, $nickname, $afid, $type) = $result->fetchrow_array ){ - - my $true_name; - if($afid =~ /^http:\/\//){ - ########## - #Friend! - ########## - $true_name = '<A HREF="' . $af->{site__web_root} . "/outgoing.cgi?dest_url=" . $afid . '" target="_blank">' . $nickname . '</A>'; - }else{ - ########## - #Anonymous - #afid = remote host - ########## - my $len = length($afid); - if($len > 20){ - $true_name = '<SPAN TITLE="' . $afid . '">...' . substr($afid, $len-20, 20) . '</SPAN>'; - }else{ - $true_name = $afid; - } - } - - if($id2 ==0 ){ $id2="";} - - my $true_type; - if($type eq "pb") {$true_type='<AF_M text="_VISITOR_TYPE_PB">';} - if($type eq "f2") {$true_type='<AF_M text="_VISITOR_TYPE_F2">';} - if($type eq "f1") {$true_type='<AF_M text="_VISITOR_TYPE_F1">';} - if($type eq "self") {$true_type='<AF_M text="_VISITOR_TYPE_SELF">';} - push(@access_log, {id=> $id, - id2=> $id2, - time=> timestamp2stringB($time), - nickname => $true_name, - type => $true_type}); - } - - debug_print("AccessLog::show end."); - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AffelioNews.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AffelioNews.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AffelioNews.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AffelioNews.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/AffelioNews.pm Tue Oct 25 04:20:53 2005 @@ -1,122 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: AffelioNews.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::AffelioNews; -{ - use strict; - - use lib("../../../../extlib/"); - use Error qw(:try); - use Fcntl; - use LWP::Simple 'get'; - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::WebInput qw(delete_HTML); - use Affelio::exception::IOException; - use Affelio::misc::Time; - - use Exporter; - @Affelio::App::Admin::AffelioNews::ISA = "Exporter"; - @Affelio::App::Admin::AffelioNews::EXPORT = qw (getnews getRSS); - - ####################################################################### - #getRSS - ####################################################################### - sub getRSS{ - my $af = shift; - - if(-e "$af->{site__user_dir}/AffelioNews/"){ - }else{ - mkdir("$af->{site__user_dir}/AffelioNews/"); - if($@){ - throw Affelio::exception::IOException("Cannot make directory for AffelioNews!"); - } - } - - #Load last-updated time - my $updated_time =0; - my $cur_time = get_timestamp(); - sysopen(IN, "$af->{site__user_dir}/AffelioNews/update", O_RDONLY); - if($@){ - }else{ - $updated_time = <IN>; - if($cur_time < $updated_time + 010000){ - return; - } - } - close(IN); - - my $url = "http://home1.affelio.jp/affelio_news/" - . $af->{site__locale} . "/index.txt"; - if($af->{site__locale} eq "en_us"){ - $url = "http://affelio.us/affelio_news/en_us/index.txt"; - } - - my $data = LWP::Simple::get($url); - if($@){ - #throw Affelio::exception::NetworkException("Network connection error to affelio web site"); - return(); - } - - sysopen(OUT, "$af->{site__user_dir}/AffelioNews/news.html", - O_WRONLY|O_CREAT|O_TRUNC); - - my @elements = split('\n', $data); - my $size = @elements; - my $index=0; - while($index < $size){ - my $datetime = timestamp2string($elements[$index++]); - my $type = $elements[$index++]; - my $title = $elements[$index++]; - my $url = $elements[$index++]; - - print OUT "<TR><TH>$datetime</TH><TD><A HREF=\"$url\" target=\"_blank\">$title</A></TD></TR>"; - } - - print OUT "\n\0"; - close(OUT); - - #Record current time - sysopen(OUT, "$af->{site__user_dir}/AffelioNews/update", - O_WRONLY|O_CREAT|O_TRUNC); - print OUT $cur_time; - close(OUT); - } - - ####################################################################### - #getnews - ####################################################################### - sub getnews{ - my $af = shift; - my $output_ref = shift; - - getRSS($af); - - sysopen(IN, "$af->{site__user_dir}/AffelioNews/news.html", - O_RDONLY); - if(!$@){ - $output_ref->{"AffelioNews"} = <IN>; - } - close(IN); - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Configuration.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Configuration.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Configuration.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Configuration.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Configuration.pm Tue Oct 25 04:20:53 2005 @@ -1,141 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Configuration.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::Configuration; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Time qw(timestamp2string); - use Affelio::misc::WebInput; - - use Exporter; - @Affelio::App::Admin::Configuration::ISA = "Exporter"; - @Affelio::App::Admin::Configuration::EXPORT = qw (show configure); - - ####################################################################### - #configure - ####################################################################### - sub configure{ - my $af= shift; - my $cgi = shift; - - debug_print("Config::conf: start."); - my $wi = new Affelio::misc::WebInput; - - ############################################## - #Top page - ############################################## - my $toppage = $wi->PTN_word($cgi->param("toppage")); - $af->{userpref__toppage_app_installname} = $toppage; - debug_print("Config::conf: toppage=[$toppage]"); - - ############################################## - #Messaging - ############################################## - my $val = $wi->PTN_word($cgi->param("pref__mesging__emailflg")); - debug_print("Config::conf: mesging__emailflg=[$val]"); - if($val eq "no"){ - $af->{userpref__mesging__emailflg} = "no"; - }else{ - $af->{userpref__mesging__emailflg} = "yes"; - } - - ############################################## - #Preferred Hosting Service - ############################################## - $af->{userpref__preferred_hosting_service} = - $wi->PTN_URL($cgi->param("pref__hosting_service")); - - $af->write_user_prefs(); - debug_print("Config::conf: end."); - } - - - - ####################################################################### - #show - ####################################################################### - sub show{ - my $af= shift; - my $output_ref = shift; - - debug_print("Config::show start."); - - ############################################## - #Top Page - ############################################## - my @applications=(); - my $install_name; - my $app; - my $core_flag=""; - my $app_flag=""; - - $output_ref->{"applications"} = \@applications; - if($af->{userpref__toppage_app_installname} eq "Affelio"){ - $core_flag="true"; - } - ############### - #Core - ############### - push(@applications, {install_title => "Affelio Core", - install_name => "Affelio", - selected => $core_flag} ); - ############### - #Apps - ############### - while (($install_name, $app) = each(%{$af->{am}->{apps}})){ - - if($af->{userpref__toppage_app_installname} - eq $app->{install_name}){ - $app_flag="true"; - }else{ - $app_flag=""; - } - - push(@applications, {install_title => "(Application) " . - $app->{install_title}, - install_name => $app->{install_name}, - selected => $app_flag} - ); - } - - ############################################## - #Messaging - ############################################## - my $name = "pref__mesging_emailflg__" - . $af->{userpref__mesging__emailflg}; - $output_ref->{$name} = "checked"; - - ############################################## - #Preferred Hosting Service - ############################################## - $output_ref->{"pref__hosting_service"} = - $af->{userpref__preferred_hosting_service}; - - debug_print("Config::show end."); - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditProfile.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditProfile.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditProfile.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditProfile.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditProfile.pm Tue Oct 25 04:20:53 2005 @@ -1,156 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: EditProfile.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::EditProfile; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - - use Exporter; - @Affelio::App::Admin::EditProfile::ISA = "Exporter"; - @Affelio::App::Admin::EditProfile::EXPORT = qw (show_profileeditor show_profile save_profile); - - - ####################################################################### - #set_profile_into_hash__show - ####################################################################### - sub set_profile_into_hash__show{ - my $self = shift; - my $af = $self->{af}; - my $output_data_ref = shift; - my $viewers_mode = shift; - debug_print("set_profile_into_hash__show: start mode=[$viewers_mode]"); - - foreach my $key (sort keys %$af){ - #debug_print("set_profile_into_hash: " . $key . "=" . $af->{$key}); - - if($key =~ /user__mode_/){ - my $key2 = $key; - $key2 =~ s/user__mode_//; - - if( (($af->{$key} eq "na") - && ($viewers_mode eq "self")) - || - (($af->{$key} eq "f1") - && (($viewers_mode eq "self") - || ($viewers_mode eq "f1")) - ) - || - (($af->{$key} eq "f2") - && (($viewers_mode eq "self") - || ($viewers_mode eq "f1") - || ($viewers_mode eq "f2")) - ) - || - ($af->{$key} eq "pb") - ){ - - my $key3 = "flg_$key2"; - $$output_data_ref{$key3} = "true"; - debug_print("af($key3) = $$output_data_ref{$key3}"); - } - - }elsif($key =~ /user__/){ - my $key2 = $key; - $key2 =~ s/user__//; - $$output_data_ref{$key2} = $af->{$key}; - debug_print("af($key2) = $af->{$key}"); - } - } - } - - ####################################################################### - #show_profileeditor - ####################################################################### - sub show_profileeditor{ - my $af = shift; - my $output_data_ref = shift; - - foreach my $key (sort keys %$af){ - #debug_print("set_profile_into_hash: " . $key . "=" . $af->{$key}); - - if($key =~ /user__mode_/){ - - }elsif($key =~ /user__/){ - my $key2 = $key; - $key2 =~ s/user__//; - $$output_data_ref{$key2} = $af->{$key}; - debug_print("af($key2) = $af->{$key}"); - } - } - } - - ####################################################################### - #save_profile - ####################################################################### - sub save_profile{ - my $af = shift; - my $cgi =shift; - my $err=""; - - my @param_names = $cgi->param; - - foreach my $param_key (@param_names){ - if($param_key ne "submit"){ - $af->{"user__$param_key"} - = $cgi->param($param_key); -# = Jcode->new($cgi->param($param_key), - - debug_print("EditProfile::save_profile: $param_key= " . Jcode::getcode($cgi->param($param_key)) . "\n"); - debug_print("EditProfile::save_profile: $param_key= [". $af->{"user__$param_key"} . "]"); - - } - } - - #XXX - #Sanitize inputs - - #XXX - #Semantics check - $err .= check_nickname( $af->{user__nickname} ); - #$err .= ... - - #Save Profile - $af->{pm}->save_profile(); - - return($err); - } - - - ######################################################################### - # Misc routines. - # XXX : need to be relocated. - ######################################################################### - sub check_nickname{ - my $input = shift; - - if($input =~ /[^\w]/){ - return "nickname can be only alphabet characters."; - }else{ - return ""; - } - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditSkins.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditSkins.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditSkins.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditSkins.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditSkins.pm Tue Oct 25 04:20:53 2005 @@ -1,258 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: EditSkins.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::EditSkins; -{ - use strict; - - use Fcntl; - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::WebInput; - - use Exporter; - @Affelio::App::Admin::EditSkins::ISA = "Exporter"; - @Affelio::App::Admin::EditSkins::EXPORT = qw (show choose_skin backup upload save_css); - - ####################################################################### - #choose_skin - ####################################################################### - sub choose_skin{ - my $af = shift; - my $cgi = shift; - my $wi = new Affelio::misc::WebInput; - - $af->{userpref__skin} = $wi->PTN_word($cgi->param("skin_list")); - $af->write_user_prefs(); - - return; - } - - ####################################################################### - #save_css - ####################################################################### - sub save_css{ - my $af = shift; - my $cgi = shift; - - sysopen(FILEOUT, "$af->{site__fs_root}/skins/$af->{userpref__skin}/style.css", O_WRONLY|O_TRUNC|O_CREAT, 0755); - print FILEOUT $cgi->param("style.css"); - close(FILEOUT); - return; - } - - - ####################################################################### - #upload - ####################################################################### - sub upload{ - my $af = shift; - my $cgi = shift; - use File::Basename; - - my $wi = new Affelio::misc::WebInput; - - debug_print("EditSkins:upload: start."); - - ############################### - #Enabling/disabling upload - ############################### - my $farm_con; - $farm_con = $af->get_farm_connecter(); - if($farm_con){ - if($farm_con->get_val("can_upload_skin") ne "yes"){ - return(); - } - } - - - my $filename = $cgi->param('uploadingfile'); - my $filetype = $cgi->uploadInfo($filename)->{'Content-Type'}; - my $basename = ""; #basename($filename,""); - - my $buffer=""; - my $filecontent=""; - while(my $bytesread = read($filename, $buffer, 2048)){ - $filecontent .= $buffer; - } - - my $ostype = $cgi->param('ostype'); - fileparse_set_fstype("$ostype"); - - my $euc_filename = Jcode->new($filename)->euc; - $euc_filename =~ s|\\|/|g; - debug_print("EditSkins:upload: euc_filename = $euc_filename"); - - if($euc_filename =~ /([\w\-]+\.zip)$/){ - $basename = ($1); - } - - debug_print("EditSkins:upload: ostype = $ostype"); - debug_print("EditSkins:upload: filetype = $filetype"); - debug_print("EditSkins:upload: filename = $filename"); - debug_print("EditSkins:upload: basename = $basename"); - - $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin'; - - if($filetype =~ /zip/ || $filename =~ /\.[zip|ZIP]$/){ - debug_print("EditSkins:upload: OK. This is a zip file. "); - debug_print("EditSkins:upload: Extracting [$basename]..."); - - open(FILEOUT, "> $af->{site__fs_root}/skins/$basename"); - binmode(FILEOUT); - print(FILEOUT $filecontent); - close(FILEOUT); - - system("cd $af->{site__fs_root}/skins; unzip $basename"); - system("cd $af->{site__fs_root}/skins; rm -rf $basename"); - - debug_print("EditSkins:upload: Extracting [$basename]...DONE."); - }else{ - debug_print("EditSkins:upload: This is a NOT zip file. [$basename]"); - debug_print("EditSkins:upload: Putting [$basename]..."); - - open(FILEOUT, "> $af->{site__fs_root}/skins/$af->{userpref__skin}/$basename"); - binmode(FILEOUT); - print(FILEOUT $filecontent); - close(FILEOUT); - } - - } - - ####################################################################### - #backup - ####################################################################### - sub backup{ - my $af = shift; - my $cgi = shift; - - my $wi = new Affelio::misc::WebInput(); - - my $skin_name = $wi->PTN_word($cgi->param("selected_skin")); - my $specified_name = $wi->PTN_word($cgi->param("archive_name")); - - debug_print("EditSkin:backup skin_name = $skin_name"); - debug_print("EditSkin:backup specified_name = $specified_name"); - - my $archive_file_name = ""; - my $archive_dir =""; - - $ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin'; - - if($specified_name ne ""){ - system("cp -rf $af->{site__fs_root}/skins/$skin_name $af->{site__fs_root}/skins/$specified_name"); - $archive_file_name = $specified_name . ".zip"; - $archive_dir = $specified_name; - }else{ - $archive_file_name = $skin_name . ".zip"; - $archive_dir = $skin_name; - } - - system("cd $af->{site__fs_root}/skins/; zip -r $archive_file_name $archive_dir"); - - print <<__EOF__; -Content-Type: application/octet-stream -Content-Disposition: attachment; filename=$archive_file_name - -__EOF__ -#; - - sysopen(FILEIN, "$af->{site__fs_root}/skins/$archive_file_name", O_RDONLY); - binmode(OUT); - print while read FILEIN, $_, 1024; - close FILEIN; - close OUT; - - system("cd $af->{site__fs_root}/skins/; rm -rf $specified_name"); - system("cd $af->{site__fs_root}/skins/; rm -rf $archive_file_name"); - return; - } - - - ####################################################################### - #show - ####################################################################### - sub show{ - - my $af = shift; - my $output_ref = shift; - - ############################### - #Skin list - ############################### - my @skin_list=(); - my $dir; - my $selected=""; - opendir(DIR, "$af->{site__fs_root}/skins/"); - while (defined($dir = readdir(DIR))) { - #print "$dir\n"; - if(($dir ne '.') && ($dir ne '..') && ($dir ne 'CVS')){ - - if($dir eq $af->{userpref__skin}){ - $selected="true"; - }else{ - $selected=""; - } - - push(@skin_list, {name => $dir, - selected => $selected - }); - } - } - $output_ref->{"skin_list"} = \@skin_list; - - ############################### - #Enabling/disabling upload - ############################### - my $farm_con; - $farm_con = $af->get_farm_connecter(); - if($farm_con){ - if($farm_con->get_val("can_upload_skin") eq "yes"){ - $output_ref->{'upload_disabler'} = ""; - }else{ - $output_ref->{'upload_disabler'} = "disabled"; - } - } - - ############################### - #Selected skin's CSS file - ############################### - my $css_body=""; - sysopen(IN, - "$af->{site__fs_root}/skins/$af->{userpref__skin}/style.css", - O_RDONLY); - if(-w "$af->{site__fs_root}/skins/$af->{userpref__skin}/style.css"){ - $output_ref->{'current_css_mode'} = ""; - }else{ - $output_ref->{'current_css_mode'} = "readonly"; - } - - while(<IN>){$css_body .=$_;} - close(IN); - $output_ref->{'current_css_body'} = $css_body; - - $output_ref->{'current_skin_name'} = $af->{userpref__skin}; - - - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditTemplates.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditTemplates.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditTemplates.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditTemplates.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/EditTemplates.pm Tue Oct 25 04:20:54 2005 @@ -1,248 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: EditTemplates.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::EditTemplates; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Fcntl; - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::WebInput; - - use Exporter; - @Affelio::App::Admin::EditTemplates::ISA = "Exporter"; - @Affelio::App::Admin::EditTemplates::EXPORT = qw (rebuild show_templates save_templates); - - ####################################################################### - #save_templates - ####################################################################### - sub save_templates{ - my $af = shift; - my $cgi = shift; - - sysopen(OUT, "$af->{site__user_dir}/af_templates/header.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("header.aftmpl"); - close(OUT); - - sysopen(OUT, "$af->{site__user_dir}/af_templates/footer.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("footer.aftmpl"); - close(OUT); - - sysopen(OUT, "$af->{site__user_dir}/af_templates/right.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("right.aftmpl"); - close(OUT); - - sysopen(OUT, "$af->{site__user_dir}/af_templates/left.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("left.aftmpl"); - close(OUT); - - sysopen(OUT, "$af->{site__user_dir}/af_templates/body_index.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("body_index.aftmpl"); - close(OUT); - - sysopen(OUT, "$af->{site__user_dir}/af_templates/body_flist.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("body_flist.aftmpl"); - close(OUT); - - sysopen(OUT, "$af->{site__user_dir}/af_templates/body_profile.aftmpl", O_WRONLY|O_TRUNC); - print OUT $cgi->param("body_profile.aftmpl"); - close(OUT); - } - - - ####################################################################### - #rebuild - ####################################################################### - sub rebuild{ - my $af = shift; - my $output_data_ref = shift; - - my $wi = new Affelio::misc::WebInput; - - debug_print("rebuild: start."); - - ################################ - #Prep - - #Open the header template file in userdata dir - my $header=""; - sysopen(HEADER, "$af->{site__user_dir}/af_templates/header.aftmpl", O_RDONLY); - while(<HEADER>){$header .=$_;} - close(HEADER); - - #Open the left template file in userdata dir - my $left=""; - sysopen(LEFT, "$af->{site__user_dir}/af_templates/left.aftmpl", O_RDONLY); - while(<LEFT>){$left .=$_;} - close(LEFT); - - #Open the right template file in userdata dir - my $right=""; - sysopen(RIGHT, "$af->{site__user_dir}/af_templates/right.aftmpl", O_RDONLY); - while(<RIGHT>){$right .=$_;} - close(RIGHT); - - #Open the footer template file in userdata dir - my $footer=""; - sysopen(FOOTER, "$af->{site__user_dir}/af_templates/footer.aftmpl", O_RDONLY); - while(<FOOTER>){$footer .=$_;} - close(FOOTER); - - - ################################ - #Main loop. For each body template.... - my $from_template_file = ""; - opendir(DIR1, "$af->{site__user_dir}/af_templates"); - while (defined($from_template_file = readdir(DIR1))) { - - $from_template_file = $wi->PTN_basefilename($from_template_file); - - if($from_template_file =~ /\.aftmpl/){ - - debug_print("rebuild: Source file=[$from_template_file]"); - - my $from_contents=""; - sysopen(BODY, "$af->{site__user_dir}/af_templates/$from_template_file", O_RDONLY); - while(<BODY>){$from_contents .=$_;} - close(BODY); - - my $template_name = $from_template_file; - $template_name =~ s/\.aftmpl//g; - if($from_template_file =~ /body.*\.aftmpl/){ - #Body template files.... - $template_name =~ s/body_//g; - }else{ - $template_name = "_" . $template_name; - } - - my $output_contents =""; - if($from_template_file =~ /body.*\.aftmpl/){ - #Concatenate 3 files. - $output_contents = $header . $left - . $from_contents . $right . $footer; - }else{ - $output_contents = $from_contents; - } - - ################################################### - #Replacement - ################################################### - # (1)s/AF_VAR/TMPL_VAR/g - $output_contents =~ s/AF_VAR/TMPL_VAR/g; - - # (2)AF_BLOCK - my $aftag_file; - opendir(DIR2, "$af->{site__fs_root}/lib/Affelio/App/Admin/AFTemplateBlocks"); - while (defined($aftag_file = readdir(DIR2))) { - #print "$aftag_file; - if(($aftag_file ne '.') && ($aftag_file ne '..') - && ($aftag_file ne 'CVS')){ - - debug_print("rebuild:\taf_tag file = $aftag_file"); - my $tagname = $aftag_file; - $tagname =~s/\.aftag//g; - #debug_print("rebuild: Replace AF_BLOCK=$tagname"); - my $tagcontent=""; - open(TAGCONTENT, - "$af->{site__fs_root}/lib/Affelio/App/Admin/AFTemplateBlocks/$aftag_file"); - while(<TAGCONTENT>){$tagcontent .=$_;} - close(TAGCONTENT); - - my $rep = '<AF_BLOCK NAME="' . $tagname . '">'; - $output_contents =~ s/$rep/$tagcontent/g; - }#if - }#while - - ################################################### - #Save to file in templates_dyn/ dir - ################################################### - sysopen(OUT, "$af->{site__fs_root}/templates_dyn/$template_name.tmpl", O_WRONLY|O_CREAT|O_TRUNC, 0755); - print OUT $output_contents; - close(OUT); - - }#if - }#while(for each file...) - - $ENV{PATH} = "/bin:/usr/bin"; - - debug_print("rebuild: header+left => Header"); - system("cat $af->{site__fs_root}/templates_dyn/_header.tmpl $af->{site__fs_root}/templates_dyn/_left.tmpl > $af->{site__fs_root}/templates_dyn/Header.tmpl"); - debug_print("rebuild: right+footer => Footer"); - system("cat $af->{site__fs_root}/templates_dyn/_right.tmpl $af->{site__fs_root}/templates_dyn/_footer.tmpl > $af->{site__fs_root}/templates_dyn/Footer.tmpl"); - - debug_print("rebuild: end."); - } - - ####################################################################### - #show_templates - ####################################################################### - sub show_templates{ - - my $af = shift; - my $output_ref = shift; - - my $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/header.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'header_template'} = $body; - - $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/footer.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'footer_template'} = $body; - - $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/left.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'left_template'} = $body; - - $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/right.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'right_template'} = $body; - - $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/body_index.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'body_template__index'} = $body; - - $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/body_flist.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'body_template__flist'} = $body; - - $body=""; - sysopen(IN, "$af->{site__user_dir}/af_templates/body_profile.aftmpl", O_RDONLY); - while(<IN>){$body .=$_;} - close(IN); - $output_ref->{'body_template__profile'} = $body; - - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/FriendsGraph.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/FriendsGraph.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/FriendsGraph.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/FriendsGraph.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/FriendsGraph.pm Tue Oct 25 04:20:54 2005 @@ -1,123 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: FriendsGraph.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::FriendsGraph; -{ - use strict; - - use lib("../../../../extlib/"); - use Error qw(:try); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::SNS::Handshaker_c; - use Affelio::misc::Debug qw(debug_print); - use Affelio::exception::IOException; - use Affelio::exception::DBException; - - use Exporter; - @Affelio::App::Admin::FriendsGraph::ISA = "Exporter"; - @Affelio::App::Admin::FriendsGraph::EXPORT = qw (show_friendsgraph retrieve); - - - ####################################################################### - #retrieve - ####################################################################### - sub retrieve{ - my $af = shift; - - my @friends_list=(); - my $result = $af->{fm}->get_all_friend_list(); - my %tmp_hash; - - while( my @row = $result->fetchrow_array ){ - $tmp_hash{$row[1]} = $row[7]; - } - undef($result); - - while (my ($peer_af_id, $last_updated) = each(%tmp_hash)) { - debug_print("FriendsGraph::retrieve: [$peer_af_id]"); - - ################################################## - #Get peer's friends list. - try{ - my $ret = get_F2List(dest_uri =>"$peer_af_id/bin/xml-rpc-serv.cgi", - timestamp => $last_updated); - debug_print("FriendsGraph::retrieve: \tget_F2List finished."); - debug_print("FriendsGraph::retrieve: \t[$ret]"); - - ################################################## - #Save the F2 list into my DB - $af->{fm}->save_F2List($ret, $peer_af_id); - - }catch Affelio::exception::IOException with{ - - }; - - - } - - } - - - - ####################################################################### - #show_friendsgraph - ####################################################################### - sub show_friendsgraph{ - my $af = shift; - my $output_data_ref = shift; - - my $ret=""; - - my $f1_result= $af->{fm}->get_all_friend_list(); - my @person=(); - while(@person = $f1_result->fetchrow_array) { - # $person[0] uid - # $person[2] nickname - # $person[8] f2list - - $ret .= $af->{user__nickname} . "-" . $person[2] . ","; - - my @f2list_elements = split(',', $person[8]); - foreach my $f2_uid (@f2list_elements){ - if($f2_uid ne ""){ - if($f2_uid > 0){ - #The other peer is also an F1 person. - my $f2_nickname - = $af->{fm}->get_attribute_by_uid($f2_uid, - "nickname"); - $ret .= $person[2] . "-" . $f2_nickname . ","; - }else{ - #The other peer is an F2 person. - my $f2_nickname - = $af->{fm}->F2_get_attribute_by_uid($f2_uid, - "nickname"); - $ret .= $person[2] . "-" . $f2_nickname . ","; - } - } - } - } - - debug_print("show_FriendsGraph: edge=[$ret]"); - $$output_data_ref{edges} = $ret; - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/GroupMemberTable.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/GroupMemberTable.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/GroupMemberTable.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/GroupMemberTable.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/GroupMemberTable.pm Tue Oct 25 04:20:54 2005 @@ -1,132 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: GroupMemberTable.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::GroupMemberTable; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - - use Exporter; - @Affelio::App::Admin::GroupMemberTable::ISA = "Exporter"; - @Affelio::App::Admin::GroupMemberTable::EXPORT = qw (show_GroupMember_table save_GroupMember_table); - - - ##################################################################### - #save_GroupMember_table - ##################################################################### - sub save_GroupMember_table{ - my $af = shift; #arg(1) AF - my $q = shift; #arg(2) CGI - my @params = $q->param; - - my @gid_array =(); - my @gid_uid_table =(); - - foreach my $key (@params){ - my $value = $q->param($key); - if($key =~ /^GRPHEADER__([0-9]*)/){ - my $this_gid =$1; - push(@gid_array, $this_gid); - } - elsif($key =~ /^GRP__([0-9]*)__([0-9]*)/){ - my $this_gid =$1; - my $this_uid =$2; - - push(@{$gid_uid_table[$this_gid]}, $this_uid); - } - } - - foreach my $gid (@gid_array){ - $af->{gm}->set_member_by_intarray($gid, \@{$gid_uid_table[$gid]}); - } - - } - - ##################################################################### - #show_GroupMember_table - ##################################################################### - sub show_GroupMember_table{ - my $af = shift; #arg(1) AF - my $output_ref = shift; #arg(3) ref of %output_data; - - debug_print("show_GroupMember_table: start."); - - ####################################################### - #Row(1): Group names - my @group_names=(); - $output_ref->{'group_names'} = \@group_names; - - my $groups_SQL = $af->{gm}->get_all_group_list(); - while( (my ($gid, $group_name, $members, $option_pid, $lastupdated, $f2list) = $groups_SQL->fetchrow_array)){ - - push(@group_names, - {'group_name' => $group_name, - 'gid' => "GRPHEADER__" . $gid } - ); - } - - my $group_num = @group_names; - - ####################################################### - #Read all friends and fill all the checkbox names - my @members=(); - $output_ref->{'members'} = \@members; - - my $SQL_result = $af->{fm}->get_all_friend_list(); - my @person=(); - while(@person = $SQL_result->fetchrow_array) { - #For each friend.... - debug_print("FriendRoutines: friend=(@person)"); - #$person[0] uid - #$person[2] nickname - - #Set my belonging groups - my @my_belonging_groups=(); - for(my $i=1; $i<=$group_num; $i++){ - push(@my_belonging_groups, - ({'checkbox_name' => "GRP__$i".'__'. $person[0], - 'checked_flag' => ""} - ) - ); - } - - #Set "checked_flag" for each belonging group - my $SQL_result2 = $af->{gm}->get_groups_by_uid($person[0]); - while((my $tmp_gid, my @rest) = $SQL_result2->fetchrow_array) { - $my_belonging_groups[$tmp_gid-1]{'checked_flag'} ="checked"; - } - - #Set my info into "members" - push(@members, - ({'member_name' => $person[2], - 'groups' => \@my_belonging_groups}) - ); - } - } - - - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageApplication.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageApplication.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageApplication.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageApplication.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageApplication.pm Tue Oct 25 04:20:54 2005 @@ -1,202 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ManageApplication.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::ManageApplication; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - - use Exporter; - @Affelio::App::Admin::ManageApplication::ISA = "Exporter"; - @Affelio::App::Admin::ManageApplication::EXPORT = qw (manage_top show_app save_permission); - - ##################################################################### - #save_permission - ##################################################################### - sub save_permission{ - my $af = shift; #arg(1) AF - my $q = shift; #arg(2) CGI - my $app_name = shift; #arg(e) app_name - - #formhead_num_action_types - #formdata_pid(\n)_(n) - my $num_action_types = $q->param("formhead_num_action_types"); - my $pid_list = $q->param("formhead_pid_list"); - my @pids = split('[\s]+', $pid_list); - - my @type_array = - @{$af->{am}->{apps}->{$app_name}->{action_types}}; - unshift(@type_array, "DF_access"); - unshift(@type_array, "DF_visibility"); - - foreach my $pid (@pids){ - my $type_count=0; - for($type_count=0; $type_count<$num_action_types; $type_count++){ - - my $param_name = "formdata_pid" . $pid . "_" . $type_count; - my $param_value = $q->param($param_name); - if($param_value ne ""){ - $param_value = 1; - }else{ - $param_value = 0; - } - debug_print("ManageApp:save: [$pid]:[$type_array[$type_count]] = [$param_value]"); - - $af->{am}->update_permission($app_name, - $pid, - $type_array[$type_count], - $param_value); - } - - } #for each - - } - ##################################################################### - #show_app - ##################################################################### - sub show_app{ - my $af = shift; #arg(1) AF - my $app_name = shift; #arg(2) app_name - my $output_ref = shift; #arg(3) ref of %output_data; - - debug_print("ManageApp::show_app: start."); - - $output_ref->{"install_name"} = $app_name; - $output_ref->{"install_title"} - = $af->{am}->{apps}->{$app_name}->{install_title}; - - ####################### - #Headers - ####################### - my @headers=(); - $output_ref->{"headers"} = \@headers; - - push(@headers, {header => '<AF_M text="DF_visibility">'}); - push(@headers, {header => '<AF_M text="DF_access">'}); - - my $type_desc_array = - $af->{am}->{apps}->{$app_name}->{action_types_desc}; - - my $count=0; - foreach my $desc (@{$type_desc_array}){ - debug_print("ManageApp::show_app: header=[$desc]"); - push(@headers, {header => "$desc"}); - $count++; - } - $output_ref->{"num_action_types"} = $count + 2; #gotta inlude DF 2s. - - ####################### - #Permission data - ####################### - my @groups=(); - $output_ref->{"groups"} = \@groups; - - #prepare application permission table - $af->{am}->prepare_app_perm_table($app_name); - - #Retrieve table - my $result= $af->{am}->get_all_permission($app_name); - - ################## - #For each group... - ################## - my $pid_list=""; - while( (my ($pid, $type, $target_id, @perms) - = $result->fetchrow_array)){ - - debug_print("ManageApp::show_app: data[$pid] $type, $target_id, @perms"); - my %this_group=(); - push(@groups, \%this_group); - - ####################### - #Group name - if($pid==1){ - $this_group{group_name} = "<B><I>" . - $af->{lh}->maketext("_VISITOR_TYPE_F1") . "</I></B>"; - }elsif($pid==2){ - $this_group{group_name} = "<B><I>" . - $af->{lh}->maketext("_VISITOR_TYPE_F2") . "</I></B>"; - }elsif($pid==3){ - $this_group{group_name} = "<B><I>" . - $af->{lh}->maketext("_VISITOR_TYPE_PB") . "</I></B>"; - }elsif($type eq "g"){ - my $query = "select group_name from AFuser_CORE_group where gid=$target_id"; - my $sth = $af->{db}->prepare($query) or die $af->{db}->errstr; - $sth->execute() or die $af->{db}->errstr; - my @tmp_array = $sth->fetchrow_array; - $this_group{group_name} = $tmp_array[0]; - } #if - - ####################### - #Values - my @data_array=(); - $this_group{data_array} = \@data_array; - - my $count=0; - foreach my $val (@perms){ - - my $chk_name = "formdata_pid" . $pid . "_" . $count; - push(@data_array, {value => $val, - checkbox_name => $chk_name}); - $count++; - } - - $pid_list .= "$pid "; - } #while (for each group) - - $output_ref->{"pid_list"} = $pid_list; - - } - - - ##################################################################### - #manage_top - ##################################################################### - sub manage_top{ - my $af = shift; #arg(1) AF - my $output_ref = shift; #arg(2) ref of %output_data; - - my @applications=(); - - my $install_name; - my $app; - while (($install_name, $app) = each(%{$af->{am}->{apps}})){ - - push(@applications, {install_title => $app->{install_title}, - install_name => $app->{install_name}, - # - editlink_URL => "$af->{site__web_root}/admin.cgi?mode=access_control_apps&mode2=show_app&app_name=$app->{install_name}", - app_URL => "$af->{site__web_root}/apps/$app->{install_name}/$app->{guest_index}", - # - app_name => $app->{app_name}, - app_version => $app->{app_version} - }); - } - - $output_ref->{"applications"} = \@applications; - } - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageFriend.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageFriend.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageFriend.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageFriend.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageFriend.pm Tue Oct 25 04:20:54 2005 @@ -1,285 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ManageFriend.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::ManageFriend; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - - use Affelio::App::FriendRoutines; - - use Exporter; - @Affelio::App::Admin::ManageFriend::ISA = "Exporter"; - @Affelio::App::Admin::ManageFriend::EXPORT = qw (manage_top modify_member show_member subscribe_group unsubscribe_group remove_member); - - ##################################################################### - #modify_member - ##################################################################### - sub modify_member{ - my $af = shift; #arg(1) AF - my $uid = shift; #arg(2) uid - my $cgi = shift; #arg(3) CGI - - debug_print("modify_member uid[$uid] start."); - - my $attr = $cgi->url_param("modified"); - my $value = $cgi->param($attr); - debug_print("modify_member [$attr] is modified to [$value]"); - - $af->{fm}->set_attribute_by_id($uid, $attr, $value); - - debug_print("modify_member uid[$uid] end."); - } - - ##################################################################### - #remove_member - ##################################################################### - sub remove_member{ - my $af = shift; #arg(1) AF - my $uid = shift; #arg(2) uid - my $cgi = shift; #arg(3) cgi - - debug_print("remove_member uid[$uid] start."); - my $afid = $af->{fm}->get_attribute_by_uid($uid, "af_id"); - - #Remove entry(uid) from AFuser_CORE_friends - #Remove uid from friends of others in AFuser_CORE_friends - #Remove entry(uid) from AFuser_CORE_friendsfriends - #Remove uid from friends of others in AFuser_CORE_friendsfriends - $af->{fm}->remove_friend($uid); - - #Remove uid from groups - $af->{gm}->remove_person_from_all($uid); - - #add uid to erasedfriends - - - - debug_print("remove_member uid[$uid] end."); - } - - ##################################################################### - #show_member - ##################################################################### - sub show_member{ - my $af = shift; #arg(1) AF - my $uid = shift; #arg(2) uid - my $output_ref = shift; #arg(3) ref of %output_data; - - debug_print("show_member uid[$uid] start."); - - my @person = $af->{fm}->get_friend_by_uid($uid); - # returns array(0uid, 1af_id, 2nickname, 3timestamp, - # 4password, 5intro, 6option_pid, 7lastupdated, 8 f2list) - debug_print("show_member [@person]"); - - $output_ref->{"uid"} = $person[0]; - - #Set nickname and image URL - $output_ref->{"nickname"} = $person[2]; - my $image_URL = generate_getcontentURL($af, - $af->{site__web_root}, - "self", - $person[1], - $person[4], - "core", - "/profile/profile_face.jpg"); - - $output_ref->{"image_URL"} = $image_URL; - - #Set this friend's intro message - $output_ref->{"intro"} = $person[5]; - - ##################### - - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - ##################### - #F1 - - #Get permission list of "F1" - my $perm_result = $af->{perm}->get_permission("f", "f1"); - my @perm_F1 = $perm_result->fetchrow_array; - debug_print("show_member: perm_F1=[@perm_F1]"); - - #Set values - my @row=(); - while(@row = $attributes->fetchrow_array){ - #debug_print("show_member: row=[@row]"); - - my $attribute_name = $row[1]; - - my $aid = $row[0]; #attribute ID - my $TMPL_var_value = $perm_F1[$aid+3]; - # Why +3? - # [0] ... Permission ID - # [1] ... "f" - # [2] ... "f1" - # [3] ... perm for "nickname" which is always 1. - # [4] ... 1st element. <= - - if($TMPL_var_value >= 1){ - $output_ref->{"f1_$attribute_name"} = $TMPL_var_value; - $output_ref->{"sum_$attribute_name"} = $TMPL_var_value; - }else{ - $output_ref->{"f1_$attribute_name"} = ""; - } - } - - ##################### - #Group - - #Get group lists which the target friends belongs to - my $groups_SQL = $af->{gm}->get_groups_by_uid($person[0]); - - my @groups_ret=(); - - #For each group returned... - while( (my ($gid, $group_name, $members, $option_pid) - = $groups_SQL->fetchrow_array)){ - - debug_print("show_member: User uid[$uid] is in group[$gid]."); - debug_print("show_member: gid=[$gid], gname=[$group_name], member=[$members], pid=[$option_pid]"); - - if($gid <1){last;} - - my %this_group_ret =(); - $this_group_ret{"group_name"} = $group_name; - - #For each group, get the permission list. - my $g_perm_result = $af->{perm}->get_permission("g", "$gid"); - my @g_perm = $g_perm_result->fetchrow_array; - debug_print("show_member: group_permission=[@g_perm]"); - - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - - #Set values - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - - if($attr_id < 0) {last;} - #debug_print("show_member: [$attr_name]"); - - if($g_perm[$attr_id+3] >= 1){ - $this_group_ret{$attr_name} = $g_perm[$attr_id+3]; - $output_ref->{"sum_$attr_name"} = $g_perm[$attr_id+3]; - }else{ - $this_group_ret{$attr_name} = ""; - } - } - - $this_group_ret{"gid"} = $gid; - $this_group_ret{"uid"} = $uid; -# $this_group_ret{"tmpl_path"} = $output_ref->{tmpl_path}; - push(@groups_ret, \%this_group_ret); - - - }#while - - $output_ref->{"groups"} = \@groups_ret; - - ################################################## - #Groups that the user DOES NOT belong to - my $add_groups_SQL = $af->{gm}->get_unsubscribing_groups_by_uid($uid); - - my @add_groups_ret=(); - - #For each group returned... - while( (my ($gid, $group_name, $members, $option_pid) - = $add_groups_SQL->fetchrow_array)){ - - push(@add_groups_ret, {group_name =>$group_name, - gid => $gid} - ); - } - $output_ref->{"add_groups"} = \@add_groups_ret; - } - - - - ##################################################################### - #subscribe_group - ##################################################################### - sub subscribe_group{ - my $af = shift; #arg(1) AF - my $gid = shift; #arg(3) GID - my $uid = shift; #arg(2) UID - - debug_print("subscribe_group: start. g[$gid] u[$uid]"); - - $af->{gm}->add_member($gid, $uid); - - debug_print("subscribe_group: end."); - } - - ##################################################################### - #unsubscribe_group - ##################################################################### - sub unsubscribe_group{ - my $af = shift; #arg(1) AF - my $gid = shift; #arg(3) GID - my $uid = shift; #arg(2) UID - - debug_print("unsubscribe_group: start. g[$gid] u[$uid]"); - - $af->{gm}->remove_member($gid, $uid); - - debug_print("unsubscribe_group: end."); - } - - - ##################################################################### - #manage_top - ##################################################################### - sub manage_top{ - my $af = shift; #arg(1) AF - my $output_ref = shift; #arg(2) ref of %output_data; - - my @friends_list=(); - my $result = $af->{fm}->get_all_friend_list(); - - while( my @row = $result->fetchrow_array ){ - - my $userhome_URL = $af->{site__web_root} - . "/outgoing.cgi?dest_url=" . $row[1]; - - my $editlink_URL = 'admin.cgi?mode=manage_friends&mode2=show_member&uid=' . $row[0]; - my $delete_URL = 'admin.cgi?mode=manage_friends&mode2=delete&uid=' . $row[0]; - - push(@friends_list, {nickname => $row[2], - userhome_URL => $userhome_URL, - editlink_URL => $editlink_URL, - delete_URL => $delete_URL, - tmpl_path => $output_ref->{tmpl_path} - }); - } - - $output_ref->{"friends"} = \@friends_list; - } - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageGroup.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageGroup.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageGroup.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageGroup.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/ManageGroup.pm Tue Oct 25 04:20:54 2005 @@ -1,118 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ManageGroup.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::ManageGroup; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::MyCrypt qw( msg_encrypt url_encode); - - use Exporter; - @Affelio::App::Admin::ManageGroup::ISA = "Exporter"; - @Affelio::App::Admin::ManageGroup::EXPORT = qw (manage_top rename_group add_group remove_group); - - ##################################################################### - #rename_group - ##################################################################### - sub rename_group{ - my $af = shift; #arg(1) AF - my $gid = shift; #arg(2) gid - my $new_name = shift; #arg(3) new_name - - $af->{gm}->rename_group($gid,$new_name); - } - - ##################################################################### - #add_group - ##################################################################### - sub add_group{ - my $af = shift; #arg(1) AF - my $group_name = shift; #arg(2) new_name - - if($group_name eq ""){ - return; - } - - debug_print("ManageGroup:add_group start.[$group_name]"); - - #Create a new group - my $gid = $af->{gm}->add_group($group_name); - - #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); - #Set values - my @g_perm=(); - while(my ($attr_id, $attr_name, $attr_type) - = $attributes->fetchrow_array){ - $g_perm[$attr_id] = 0; - } - $g_perm[1] = 0; - - debug_print("ManageGroup:add_group newg group=[@g_perm]"); - $af->{perm}->add_permission("g", $gid, \@g_perm); - } - - ##################################################################### - #remove_group - ##################################################################### - sub remove_group{ - my $af = shift; #arg(1) AF - my $gid = shift; #arg(2) gid - my $q = shift; #arg(3) CGI - - $af->{gm}->remove_group($gid); - } - - - ##################################################################### - #manage_top - ##################################################################### - sub manage_top{ - my $af = shift; #arg(1) AF - my $output_ref = shift; #arg(2) ref of %output_data; - - my @friends_list=(); - my $result = $af->{gm}->get_all_group_list(); - - while( my @row = $result->fetchrow_array ){ - - my $group_attr_URL = 'admin.cgi?mode=access_control'; - my $group_member_URL = 'admin.cgi?mode=group_member_table'; - my $removelink_URL = 'admin.cgi?mode=manage_groups&mode2=remove_group&gid=' . $row[0]; - my $rename_URL = 'admin.cgi?mode=manage_groups&mode2=rename&gid=' . $row[0]; - - push(@friends_list, {group_name => $row[1], - rename_URL => $rename_URL, - group_attr_URL => $group_attr_URL, - group_member_URL => $group_member_URL, - removelink_URL => $removelink_URL, -# tmpl_path => $output_ref->{tmpl_path} - }); - } - - $output_ref->{"friends"} = \@friends_list; - } - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Messaging.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Messaging.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Messaging.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Messaging.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/Messaging.pm Tue Oct 25 04:20:54 2005 @@ -1,308 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Messaging.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::Messaging; -{ - use strict; - - use lib("../../../../extlib/"); - use Error qw(:try); - use MIME::Base64::Perl; - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Time qw(timestamp2string get_timestamp); - use Affelio::misc::WebInput; - use Affelio::SNS::Handshaker_c; - use Affelio::exception::CommunicationException; - - use Exporter; - @Affelio::App::Admin::Messaging::ISA = "Exporter"; - @Affelio::App::Admin::Messaging::EXPORT = qw (show_message_list show_message mark_as_read get_new compose send_message); - - ####################################################################### - #send_message - ####################################################################### - sub send_message{ - my $af = shift; - my $cgi = shift; - - debug_print("Mesg::send: start."); - - my $msg_to = $cgi->param("msg_to"); - my $msg_title = $cgi->param("msg_title"); - my $msg_body = $cgi->param("msg_body"); - - debug_print("Mesg::send: $msg_to $msg_title $msg_body"); - - my $passAB = $af->{fm}->get_attribute_by_afid($msg_to, "password"); - if(!defined($passAB) || $passAB eq ""){ - #Exception! - exit(1); - } - debug_print("Mesg::send: passAB=[$passAB]"); - - my $ret=""; - try{ - $ret = post_Message(dest_uri => "$msg_to/bin/xml-rpc-serv.cgi", - src => $af->{site__web_root}, - password => $passAB, - msg_from => $af->{site__web_root}, - msg_from_nickname => $af->{user__nickname}, - msg_to => $msg_to, - msg_timestamp => get_timestamp(), - msg_title => $msg_title, - msg_body => $msg_body); - }catch Affelio::exception::NetworkException with{ - my $E = shift; - throw Affelio::exception::CommunicationException($E); - - }catch Affelio::exception::InvalidInputException with{ - my $E = shift; - error($cgi, "<PRE>Exception: " . $E . "</PRE>"); - }; - } - - - ####################################################################### - #compose - ####################################################################### - sub compose{ - my $af = shift; - my $cgi = shift; - my $output_ref = shift; - my $wi = new Affelio::misc::WebInput; - - my $reply_to = $cgi->param("reply_to"); - my $reply_title = $cgi->param("reply_title"); - my $reply_body = $cgi->param("reply_body"); - - debug_print("Messaging::compose: start."); - debug_print("Messaging::compose: Reply-To: [$reply_to]"); - - ############################ - #To: - ############################ - my @friends_list=(); - my $result = $af->{fm}->get_all_friend_list(); - while( my @row = $result->fetchrow_array ){ - - my $selected = ""; - if($row[1] eq $reply_to){ - $selected ="selected"; - } - - push(@friends_list, {nickname => $row[2], - afid => $row[1], - selected => $selected}); - debug_print("Messaging::\t$row[2]"); - } - $output_ref->{"friends"} = \@friends_list; - - ############################ - #Title: - ############################ - $output_ref->{"msg_title"} = $reply_title; - - ############################ - #Body: - ############################ - $output_ref->{"msg_body"} = $reply_body; - - - debug_print("Messaging::compose: end."); - } - - ####################################################################### - #mark_as_read - ####################################################################### - sub mark_as_read{ - my $wi = new Affelio::misc::WebInput; - - my $af = shift; - my $mid = shift; - $mid = $wi->PTN_num($mid); - - debug_print("marK_as_read: start"); - - my $ret= $af->{mesgm}->mark_as_read($mid); - - debug_print("marK_as_read: end"); - } - - ####################################################################### - #get_new - ####################################################################### - sub get_new{ - my $af = shift; - debug_print("get_new: start"); - - my $ret= $af->{mesgm}->get_unread_message_num(); - - debug_print("get_new: end"); - return($ret); - } - - - ####################################################################### - #show_message - ####################################################################### - sub show_message{ - my $wi = new Affelio::misc::WebInput; - - my $af = shift; - my $mid = shift; - $mid = $wi->PTN_num($mid); - my $output_ref = shift; - - debug_print("show_message: start."); - - my @message= $af->{mesgm}->retrieve_message($mid); - my ($msg_mid, $msg_timestamp, $msg_title, $msg_type, - $msg_from, $msg_body, $msg_readflag) = @message; - - if($msg_type=~ /Encode\-Base64/){ - $msg_body = decode_base64($msg_body); - } - debug_print("show_message: $msg_from $msg_title $msg_type $msg_body"); - - $msg_timestamp = timestamp2string($msg_timestamp); - - if($msg_type=~ /UserToUser/){ - my $reply_title = "Re: $msg_title"; - my $reply_body = $msg_body; - $reply_body =~ s/\r\n/\n/g; - $reply_body =~ s/\r/\n/g; - $reply_body =~ s/\n/\n>>/g; - $reply_body = "\r\n>>" . $reply_body; - - my $reply_to=""; - if($msg_from =~ /HREF="(.+)">/){ - $reply_to = $1; - } - - my $reply_HTML = <<EOT; -<FORM METHOD="POST" ACTION="admin.cgi?mode=messages&action=compose"> -<INPUT TYPE="hidden" NAME="reply_to" VALUE="$reply_to"> -<INPUT TYPE="hidden" NAME="reply_title" VALUE="$reply_title"> -<INPUT TYPE="hidden" NAME="reply_body" VALUE="$reply_body"> -<INPUT TYPE="submit" VALUE="<AF_M text="Reply">"> -</FORM> -EOT - $$output_ref{"reply_HTML"} = $reply_HTML; - - } - - #URL ---> <A HREF="URL">URL</A> - $msg_body = $wi->translate_URL_to_HTML($msg_body); - #\n ----> <BR> - $msg_body =~ s/\r\n/\n/g; - $msg_body =~ s/\r/\n/g; - $msg_body =~ s/\n/<BR>/g; - - ############### - #UserToUser (inter-Affelio massaging - ############### - #XXX - # This part is quite nasty. Since $msg_from is using format - # like '<A HREF="url">nickname</A>' due to a weird DB problem, - # We have to change the URL to the one through outgoing.cgi - # by using ad-hoc regexes.... - if($msg_type =~ /UserToUser/){ - $msg_from =~ /<A HREF="(.*)">(.+)<\/A>/; - debug_print("show_message_list: \t[$1]"); - debug_print("show_message_list: \t[$2]"); - - $msg_from = '<A HREF="' . $af->{site__web_root} . '/outgoing.cgi?dest_url=' . $1 . '" target="_blank">' . $2 . '</A>'; - } - ########### - - - $$output_ref{"msg_timestamp"} = $msg_timestamp; - $$output_ref{"msg_title"} = $msg_title; - $$output_ref{"msg_from"} = $msg_from; - $$output_ref{"msg_body"} = $msg_body; - - $$output_ref{"url2list"} = "$af->{site__web_root}/admin.cgi?mode=messages"; - - debug_print("show_message: end."); - } - - ####################################################################### - #show_message_list - ####################################################################### - sub show_message_list{ - my $af = shift; - my $output_ref = shift; - - debug_print("show_message_list: start."); - - my @ret_messages=(); - $output_ref->{'messages'} = \@ret_messages; - - my $messages= $af->{mesgm}->retrieve_all_messages(); - - my @message=(); - while(@message = $messages->fetchrow_array) { - my ($msg_mid, $msg_timestamp, $msg_title, $msg_type, - $msg_from, $msg_body, $msg_readflag) = @message; - - $msg_timestamp = timestamp2string($msg_timestamp); - - debug_print("show_message_list: [$msg_title]"); - debug_print("show_message_list: [$msg_from]"); - debug_print("show_message_list: [$msg_body]"); - debug_print("show_message_list: [$msg_timestamp]"); - - ############### - #UserToUser (inter-Affelio massaging - ############### - #XXX - # This part is quite nasty. Since $msg_from is using format - # like '<A HREF="url">nickname</A>' due to a weird DB problem, - # We have to change the URL to the one through outgoing.cgi - # by using ad-hoc regexes.... - if($msg_type =~ /UserToUser/){ - $msg_from =~ /<A HREF="(.*)">(.+)<\/A>/; - debug_print("show_message_list: \t[$1]"); - debug_print("show_message_list: \t[$2]"); - - $msg_from = '<A HREF="' . $af->{site__web_root} . '/outgoing.cgi?dest_url=' . $1 . '" target="_blank">' . $2 . '</A>'; - } - ########### - - - my $linkurl = "$af->{site__web_root}/admin.cgi?mode=messages&action=show&mid=$msg_mid"; - push(@ret_messages, - { - 'msg_title' => $msg_title, - 'msg_from' => $msg_from, - 'msg_timestamp' => $msg_timestamp, - 'readflag' => $msg_readflag, - 'msg_linkurl' => $linkurl - } - ); - } - debug_print("show_message_list: end."); - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/MyStatus.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/MyStatus.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/MyStatus.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/MyStatus.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/MyStatus.pm Tue Oct 25 04:20:54 2005 @@ -1,52 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: MyStatus.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::MyStatus; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::WebInput qw(delete_HTML); - - use Exporter; - @Affelio::App::Admin::MyStatus::ISA = "Exporter"; - @Affelio::App::Admin::MyStatus::EXPORT = qw (post); - - ####################################################################### - #post - ####################################################################### - sub post{ - my $af = shift; - my $currentstatus = shift; - - debug_print("MyStatus::post start [$currentstatus]"); - - $af->{user__currentstatus} = $currentstatus; - - $af->{pm}->save_profile(); - - debug_print("MyStatus::post end"); - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendHandshake.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendHandshake.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendHandshake.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendHandshake.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendHandshake.pm Tue Oct 25 04:20:54 2005 @@ -1,131 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: SendHandshake.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::SendHandshake; -{ - use strict; - - use lib("../../../../extlib/"); - use Error qw(:try); - use Crypt::DH; - use MIME::Base64::Perl; - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Time qw(timestamp2string get_timestamp); - use Affelio::misc::WebInput; - use Affelio::SNS::Handshaker_c; - use Affelio::SNS::Handshaker_tmpDB; - use Affelio::exception::CommunicationException; - - use Exporter; - @Affelio::App::Admin::SendHandshake::ISA = "Exporter"; - @Affelio::App::Admin::SendHandshake::EXPORT = qw (send); - - ####################################################################### - #send - ####################################################################### - sub send{ - my $af = shift; - my $cgi = shift; - my $output_ref = shift; - my $wi = new Affelio::misc::WebInput; - - debug_print("SendHandshake::send: start."); - - my $dest_uri = $wi->PTN_URL($cgi->param("dest_uri")); - my $my_mesg = $cgi->param("my_mesg"); - - debug_print("SendHandshake::send: $dest_uri"); - debug_print("SendHandshake::send: $my_mesg"); - - ###################### - #Remove "/" from the end of $dest_uri - ###################### - $dest_uri =~ s/\/$//; - my $dest_xml_uri = $dest_uri . "/bin/xml-rpc-serv.cgi"; - debug_print("SendHandshake::send: $dest_xml_uri\n"); - - ########################################### - # Get current time; - my $cur_time = get_timestamp(); - - ########################################### - #DH key generation - my $mydh = Crypt::DH->new; - #RFC 2412 - The OAKLEY Key Determination Protocol - #Group 1: A 768 bit prime - my $DH_g="2"; - my $DH_p="1552518092300708935130918131258481755631334049434514313202351194902966239949102107258669453876591642442910007680288864229150803718918046342632727613031282983744380820890196288509170691316593175367469551763119843371637221007210577919"; - $mydh->g($DH_g); - $mydh->p($DH_p); - - #Step (1): create my public_key - $mydh->generate_keys; - my $my_DH_pub_key_str = $mydh->pub_key->bstr; - my $my_DH_pri_key_str = $mydh->priv_key->bstr; - - debug_print("SendHandshake::send: pri_key = $my_DH_pri_key_str [" . length($my_DH_pri_key_str) . "]digits"); - debug_print("SendHandshake::send: pub_key = $my_DH_pub_key_str [" . length($my_DH_pub_key_str) . "]digits"); - - - ########################################### - # Send HandShake to the URL - ########################################### - my $ret=""; - try{ - $ret = send_HandShake(dest_uri => $dest_xml_uri, - timestamp => $cur_time, - my_nickname => $af->{user__nickname}, - my_AFID => $af->{site__web_root}, - DH_pub_key_str => $my_DH_pub_key_str, - mesg => $my_mesg); - }catch Affelio::exception::NetworkException with{ - my $E = shift; - throw Affelio::exception::CommunicationException($E); - }catch Affelio::exception::Exception with{ - my $E = shift; - throw Affelio::exception::CommunicationException($E); - }; - if($ret->{flerror} == 1){ - #XML-RPC communication was successful. - #But the peer returned error. denyetc... - throw Affelio::exception::CommunicationException($@); - } - - ########################################### - # Save peer's info into pending_DB - ########################################### - my $tmpdb= new Affelio::SNS::Handshaker_tmpDB($af); - $tmpdb->add_sent_Handshake($cur_time, - $dest_xml_uri, - "", - $cur_time, - $my_DH_pri_key_str); - debug_print("SendHandshake::send: wrote DB $dest_uri => $cur_time\n"); - - $output_ref->{target_url} = $dest_uri; - $output_ref->{mypage_url} = "$af->{site__web_root}/admin.cgi"; - - return; - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendInvitation.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendInvitation.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendInvitation.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendInvitation.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/App/Admin/SendInvitation.pm Tue Oct 25 04:20:54 2005 @@ -1,77 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: SendInvitation.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::App::Admin::SendInvitation; -{ - use strict; - - use lib("../../../../extlib/"); - use lib("../../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - - use Exporter; - @Affelio::App::Admin::SendInvitation::ISA = "Exporter"; - @Affelio::App::Admin::SendInvitation::EXPORT = qw (send_invitation); - - ##################################################################### - #send_invitation - ##################################################################### - sub send_invitation{ - my $af = shift; - my $dest_address = shift; #arg(2) destination address - my $output_ref = shift; #arg(3) ref of %output_data; - - debug_print("send_invitation: start. dest=[$dest_address]"); - - my $encoded_subject = "Invitation to Affelio"; - - my $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/invitation_email.tmpl"; - my $emailbody = `cat $TMPL_FILE`; - - $emailbody =~ s/\[TO_ADDR\]/$dest_address/g; - $emailbody =~ s/\[FROM_NICKNAME\]/$af->{user__nickname}/g; - $emailbody =~ s/\[FROM_ADDR\]/$af->{user__email1}/g; - $emailbody =~ s/\[FROM_URL\]/$af->{site__web_root}/g; - - my $intro_url= "http://www.handshaker.jp/?from=" - . $af->{site__web_root} . "&preferred=" - . $af->{userpref__preferred_hosting_service}; - - $emailbody =~ s/\[INTRO_URL\]/$intro_url/g; - - - open(MAIL, " | $af->{cmd__nkf} -j | $af->{cmd__sendmail} -t "); - print MAIL "To: $dest_address\n"; - print MAIL "From: $af->{user__email1}\n"; - print MAIL "Subject: $encoded_subject\n"; - print MAIL "Content-Type: text/plain; charset=iso-2022-jp\n"; - print MAIL "MIME-Version: 1.0\n\n"; - print MAIL $emailbody; - close(MAIL); - - #Set notice message - $output_ref->{'notice'} = "Email sent to $dest_address"; - - debug_print("send_invitation: end."); - } - -}#package -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:54 +0900 Subject: [Affelio-cvs 680] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane Message-ID: <20051024192054.6D7512AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter.pm Tue Oct 25 04:20:54 2005 @@ -1,30 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: FarmConnecter.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Backplane::FarmConnecter; -{ - use strict; - use lib("../../../extlib"); - use lib("../../../lib"); - - - -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:54 +0900 Subject: [Affelio-cvs 681] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter Message-ID: <20051024192054.8C2472AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Backplane/FarmConnecter/SimpleFileConnecter.pm Tue Oct 25 04:20:54 2005 @@ -1,75 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: SimpleFileConnecter.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Backplane::FarmConnecter::SimpleFileConnecter; -{ - use strict; - use lib("../../../../extlib"); - use Error qw(:try); - use lib("../../../../lib"); - use Affelio::misc::Debug; - use Affelio::exception::IOException; - - use vars qw(@ISA); - @ISA = qw(Affelio::Backplane::FarmConnecter); - - sub new{ - debug_print("SimpleFileConn: start."); - - my $class = shift; - my %param = @_; - - my $file_path = $param{path}; - debug_print("SimpleFileConn: path = [$file_path]"); - my %config = (); - - my $self = {file_path => $file_path, - config => \%config}; - bless $self, $class; - - my $line=""; - try{ - open(IN, $file_path); - while($line = <IN>){ - chop($line); - if($line =~ /^AF_CTRL_([A-Za-z0-9\-\_]*)\s*\=\s*(.*)/){ - $config{$1} =$2; - debug_print("SimpleFileConn: [$1] = [$2]"); - } - } - close(IN); - }catch Error with{ - my $e=shift; - debug_print("SimpleFileConn: $e"); - }; - - return($self); - } - - sub get_val{ - my $self =shift; - my $arg = shift; - - debug_print("SimpleFileConn::get_val $arg = $self->{config}->{$arg}"); - return($self->{config}->{$arg}); - } - -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:55 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:55 +0900 Subject: [Affelio-cvs 682] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/exception Message-ID: <20051024192055.3D1F02AC035@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/CommunicationException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/CommunicationException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/CommunicationException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/CommunicationException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/CommunicationException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: CommunicationException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::CommunicationException ; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/DBException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/DBException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/DBException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/DBException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/DBException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: DBException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::DBException; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/Exception.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/Exception.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/Exception.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/Exception.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/Exception.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Exception.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::Exception; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/IOException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/IOException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/IOException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/IOException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/IOException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: IOException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::IOException; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/InvalidInputException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/InvalidInputException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/InvalidInputException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/InvalidInputException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/InvalidInputException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: InvalidInputException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::InvalidInputException; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/NetworkException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/NetworkException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/NetworkException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/NetworkException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/NetworkException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: NetworkException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::NetworkException; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/SystemException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/SystemException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/SystemException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/SystemException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/SystemException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: SystemException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::SystemException; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/exception/TaintedInputException.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/exception/TaintedInputException.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/exception/TaintedInputException.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/exception/TaintedInputException.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/exception/TaintedInputException.pm Tue Oct 25 04:20:55 2005 @@ -1,28 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: TaintedInputException.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Error; -$Error::Debug = 1; - -package Affelio::exception::TaintedInputException; -{ - use base qw/Error::Simple/; - use overload ('""' => 'stringify'); -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:54 +0900 Subject: [Affelio-cvs 683] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/NetLib Message-ID: <20051024192054.DD18A2AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/NetLib/Email.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/NetLib/Email.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/NetLib/Email.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/NetLib/Email.pm:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/NetLib/Email.pm Tue Oct 25 04:20:54 2005 @@ -1,140 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Email.pm,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -package Affelio::NetLib::Email; -{ - use strict; - use lib("../../../extlib"); - use Exporter; - use Jcode; - use lib("../../../lib"); - use Affelio::misc::Debug; - @Affelio::NetLib::Email::ISA = "Exporter"; - @Affelio::NetLib::Email::EXPORT = qw (encode_mail_subject send_email); - - ######################################################################## - #send_email - ######################################################################## - sub send_email{ - my $af = shift; - my $from = shift; - my $to = shift; - my $title = shift; - my $body = shift; - - ########################################### - Affelio::misc::Debug::debug_print("send_mail_ack: $af->{cmd__sendmail} -t\n"); - #Sendmail - open(MAIL, " | $af->{cmd__sendmail} -t "); - print MAIL "To: $to\n"; - print MAIL "From: $from\n"; - print MAIL "Subject: $title\n\n"; - print MAIL "$body\n"; - print MAIL "\n"; - close(MAIL); - } - - - ######################################################################## - #encode_mail_subject - ######################################################################## - sub encode_mail_subject { - my($String) = @_; -# &jcode::convert(\$String, "euc"); -# $String = jcode($String)->euc; - my($Base64Table) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'. - 'abcdefghijklmnopqrstuvwxyz'. - '0123456789+/'; - my($chunk, $ByteChunk, $PackedByteChunk, $DecimalNum, $EncodedString); - my($SplitedWord, @SplitedWordList, $i, $Byte, $Buff); - my($KI) = 0; - my($KO) = 0; - my($CharNum) = 0; - my($CharType) = 0; - my($LineLength) = 0; - my($CharEndFlag) = 1; - if($String =~ /[^a-zA-Z0-9\!\"\#\$\%\&\'\(\)\*\+\,\-\.\/\:\;\<\=\>\?\@\[\/\^\_\~ ]/) { - $i = 0; - @SplitedWordList = (); - while($i < length($String)) { - $Byte = substr($String, $i, 1); - if($Byte =~ /[\x8E\xA1-\xFE]/) { - unless($CharType eq 'K') {$KI ++;} - $CharType = 'K'; - if($CharEndFlag) { - $CharEndFlag = 0; - } else { - $CharEndFlag = 1; - } - } else { - if($CharType eq 'K') {$KO ++;} - $CharType = 'A'; - $CharEndFlag = 1; - } - $Buff .= $Byte; - $CharNum += 1; - $LineLength = 27 + ($CharNum*4/3) + (($KI+$KO)*4) + 2; - if($CharType eq 'K') {$LineLength += 4;} - if($CharEndFlag && $LineLength>=70) { -# &jcode::convert(\$Buff, "jis"); - $Buff = jcode($Buff)->jis; - push(@SplitedWordList, $Buff); - $Buff = ''; - $CharNum = 0; - $CharType = 0; - $KI = 0; - $KO = 0; - } - $i ++; - } -# &jcode::convert(\$Buff, "jis"); - $Buff = jcode($Buff)->jis; - push(@SplitedWordList, $Buff); - - for $SplitedWord (@SplitedWordList) { - $EncodedString .= '=?ISO-2022-JP?B?'; - my $BitStream = unpack("B*", $SplitedWord); - $i = 0; - while($chunk = substr($BitStream, $i*6, 6)) { - unless(length($chunk) == 6) { - $chunk = pack("B6", $chunk); - $chunk = unpack("B6", $chunk); - } - $ByteChunk = sprintf("%08d", $chunk); - $PackedByteChunk = pack("B8", $ByteChunk); - $DecimalNum = unpack("C", $PackedByteChunk); - $EncodedString .= substr($Base64Table, $DecimalNum, 1); - $i++; - } - if(length($SplitedWord) % 3 == 1) { - $EncodedString .= '=='; - } elsif(length($SplitedWord) % 3 == 2) { - $EncodedString .= '='; - } - $EncodedString .= '?='."\n "; - } - $EncodedString =~ s/\n $//; - } else { - $EncodedString = $String; - } - return $EncodedString; - } - ######################################################################## - -}#package -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:54 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:54 +0900 Subject: [Affelio-cvs 684] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing Message-ID: <20051024192054.B59ED2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/AccessLogManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/AccessLogManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/AccessLogManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/AccessLogManager.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/AccessLogManager.pm Tue Oct 25 04:20:54 2005 @@ -1,206 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: AccessLogManager.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Managing::AccessLogManager; -{ - use strict; - use lib("../../../extlib"); - use DBI; - use Jcode; - use lib("../../"); - use Affelio::misc::CGIError; - use Affelio::misc::Time qw(get_timestamp get_today); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Debug qw(debug_print); - use Affelio::NetLib::Email qw(send_email); - use Affelio::exception::DBException; - - ####################################################################### - #Constructor - ####################################################################### - sub new{ - my $class = shift; - my $af = shift; - - debug_print("AccessLogManager::new: start."); - - my $self = {af => $af - }; - - bless $self, $class; - - debug_print("AccessLogManager::new: end."); - return $self; - } - - ####################################################################### - #save_log - ####################################################################### - sub save_log{ - my $self=shift; - my $afid = shift; - my $nickname = shift; - my $type=shift; - - #AFuser_CORE_accesslog - # id id2 timestamp INT, nickname TEXT, afid TEXT, type TEXT - - my $af=$self->{af}; - my $cur_time = get_timestamp(); - my $startoftheday = get_today(); - - ################################ - #Check the table - ################################ - my $create_tbl_cmd = "CREATE TABLE AFuser_CORE_accesslog(id INTEGER PRIMARY KEY, id2 INTEGER, timestamp BIGINT, nickname TEXT, afid TEXT, type TEXT)"; - eval{ - $af->{db}->do($create_tbl_cmd); - }; - if($@){ - }else{ - debug_print("AccessLog:save: Table created."); - } - - ################################ - #check today's past access of this user - ################################ - my $query1; my $sth1; $@=""; - my @row1=(); - $query1 = "SELECT * FROM AFuser_CORE_accesslog WHERE timestamp >= $startoftheday AND afid = '$afid'"; - debug_print("AccessLog:save: q=[$query1]"); - eval{ - $sth1 = $af->{db}->prepare($query1); - $sth1->execute(); - @row1 = $sth1->fetchrow_array; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - if(@row1 == () ){ - debug_print("AccessLog:save: This is your 1st access today. proceed."); - my $newid=0; my $maxid=0; - - ############################## - #Get existing max ID - my $query2 = 'SELECT max(id) FROM AFuser_CORE_accesslog'; - my $sth2; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row2 = $sth2->fetchrow_array; - $maxid = $row2[0]; - debug_print("AccessLog:save: maxid=[$maxid]"); - - if(defined($row2[0])){ - $maxid = $row2[0]; - }else{ - $maxid = 0; - } - $newid = $maxid+1; - - ############################## - #Get existing max ID2 - my $newid2=0; my $maxid2=0; - if($afid =~ /http/){ - $query2 = 'SELECT max(id2) FROM AFuser_CORE_accesslog'; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - @row2 = $sth2->fetchrow_array; - $maxid2 = $row2[0]; - debug_print("AccessLog:save: maxid2=[$maxid2]"); - if(defined($row2[0])){ - $maxid2 = $row2[0]; - }else{ - $maxid2 = 0; - } - $newid2 = $maxid2+1; - } - - ################################ - #Add this access - ################################ - my $query3; my $sth3; - $query3 = "insert into AFuser_CORE_accesslog(id, id2, timestamp, nickname, afid, type) values ($newid, $newid2, $cur_time, '$nickname', '$afid', '$type')"; - eval{ - $sth3 = $af->{db}->prepare($query3); - $sth3->execute(); - }; - debug_print("AccessLog:save: inserted [$query3]"); - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("AccessLog:save: recorded!"); - }else{ - debug_print("AccessLog:save: You are a repeater. ignore you."); - } - } - - ####################################################################### - #get_log - ####################################################################### - sub get_log{ - my $self=shift; - my $from=shift; - my $to=shift; - my $af = $self->{af}; - - debug_print("AccessLog::get_log: $from -> $to"); - - ################################ - #Check the table - ################################ - my $create_tbl_cmd = "CREATE TABLE AFuser_CORE_accesslog(id INTEGER PRIMARY KEY, id2 INTEGER, timestamp INTEGER, nickname TEXT, afid TEXT, type TEXT)"; - eval{ - $af->{db}->do($create_tbl_cmd); - }; - if($@){ - }else{ - debug_print("AccessLog:save: Table created."); - } - - ############################## - #retrieve all friend records from DB - my $query = "SELECT * FROM AFuser_CORE_accesslog WHERE timestamp > $from AND timestamp < $to order by id desc"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - return($sth); - } - -}#package -1; - - Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ApplicationManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ApplicationManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ApplicationManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ApplicationManager.pm:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ApplicationManager.pm Tue Oct 25 04:20:54 2005 @@ -1,386 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ApplicationManager.pm,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -package Affelio::Managing::ApplicationManager; -{ - use strict; - use lib("../../../extlib"); - use DBI; - use Jcode; - use lib("../../"); - use Affelio::misc::CGIError; - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Debug qw(debug_print); - use Affelio::exception::DBException; - - ####################################################################### - #Constructor - ####################################################################### - sub new{ - my $class = shift; - my $af = shift; - my %apps=(); - - debug_print("ApplicationManager::new: start."); - my $self = {af => $af, - apps => %apps - }; - - bless $self, $class; - - load_applications($self); - - debug_print("ApplicationManager::new: end."); - return $self; - } - - ##################################################################### - #get_summed_app_perm - ##################################################################### - sub get_summed_app_perm{ - my $self = shift; - my $af = $self->{af}; - my $visitor_id = shift; #arg(1) visitor_ID - my $visitor_mode = shift; #arg(2) visitor_mode - my $app_name =shift; #arg(3) application install_name - my $action_type =shift; #arg(4) action_type - - my @ret_list=(); - - debug_print("AppManager::get_summed_app_perm: start."); - debug_print("AppManager::get_summed_app_perm: visitor_id = $visitor_id"); - debug_print("AppManager::get_summed_app_perm: visitor_mode= $visitor_mode"); - debug_print("AppManager::get_summed_app_perm: app_name = $app_name"); - debug_print("AppManager::get_summed_app_perm: action_type = $action_type"); - - if($visitor_mode eq "f2" || $visitor_mode eq "pb"){ - #################### - # f2 or PB - #################### - - my $query = "select $action_type from AFuser_" . $app_name - ."_permission where type = 'f' and target_id = '$visitor_mode'"; - - debug_print("AppManager::get_summed_app_perm: q=[$query]"); - - my $sth = $af->{db}->prepare($query) or - throw Affelio::exception::DBException("cannot insert"); - $sth->execute() or - throw Affelio::exception::DBException("cannot insert"); - - my @row = $sth->fetchrow_array; - - debug_print("AppManager::get_summed_app_perm: end [$row[0]]"); - return($row[0]); - - }elsif($visitor_mode eq "self"){ - - return(1); - - }else{ - #################### - # f1 - #################### - #We will make - # perm(f1) OR Vx(perm(G)) - - ################# - #(1) as a friend - my $query = "select $action_type from AFuser_" . $app_name - ."_permission where type = 'f' and target_id = '$visitor_mode'"; - my $sth = $af->{db}->prepare($query) or - throw Affelio::exception::DBException("cannot insert"); - $sth->execute() or - throw Affelio::exception::DBException("cannot insert"); - my @row = $sth->fetchrow_array; - if($row[0] == 1){ - return(1); - } - - ################# - #(2) as a member of each group - - #Get the visitor's UID - my ($t_uid, $t_afid, $t_nickname, $t_time, - $t_pass, $t_intro, $t_pid, $t_lastupdated, $t_f2list) - = $af->{fm}->get_friend_by_afid($visitor_id); - - #Get the visitor's groups - my $SQL_result = $af->{gm}->get_groups_by_uid($t_uid); - - #For each group... - my @g_data=(); - my $flag=0; - while(@g_data = $SQL_result->fetchrow_array) { - my $gid = $g_data[0]; - - my $query = "select $action_type from AFuser_" . $app_name - ."_permission where type = 'g' and target_id = '$gid'"; - my $sth = $af->{db}->prepare($query) or - throw Affelio::exception::DBException("cannot insert"); - $sth->execute() or - throw Affelio::exception::DBException("cannot insert"); - my @row = $sth->fetchrow_array; - - if($row[0] ==1){ - $flag=1; - } - } - - return($flag); - - } - - } - - ###################################################################### - #get_all_permission - ###################################################################### - sub get_all_permission{ - my $self = shift; - my $app_name = shift; #arg(1) app install_name - - debug_print("get_all_premission: start"); - my $af = $self->{af}; - - ############################## - #retrieve all permission records from DB - my $query = 'SELECT * FROM AFuser_' . $app_name . '_permission'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("get_all_premission: end"); - return($sth); - } - - ###################################################################### - #prepare_app_perm_table Check Appliation Permission Table - ###################################################################### - sub prepare_app_perm_table{ - my $self = shift; - my $af = $self->{af}; - my $caller = shift; #application install name - - #Does my application's permission table already exist? - my $my_table_name = "AFuser_" . $caller . "_permission"; - debug_print("AppManager::check_table: table = [".$my_table_name."]"); - - my $query = "SELECT * FROM " . $my_table_name; - eval{ - my $sth = $af->{db}->prepare($query); - my @dummy = $sth->execute(); - }; - if($@){ - ############################################# - #Table of this application does not exist! - #Thus, we will make the table - my $create_table_SQL="CREATE TABLE $my_table_name (pid INTEGER, type TEXT, target_id TEXT, DF_visibility INTEGER, DF_access INTEGER, "; - my $new_rec_SQL="insert into $my_table_name(pid, type, target_id, DF_visibility, DF_access, "; - - my $num_action_types - = @{ $self->{apps}->{$caller}->{action_types} }; - my $i; - for($i=0; $i < $num_action_types; $i++){ - $create_table_SQL .= - ${ $self->{apps}->{$caller}->{action_types} }[$i]; - $create_table_SQL .= " INTEGER,"; - - $new_rec_SQL .= - ${ $self->{apps}->{$caller}->{action_types} }[$i]; - $new_rec_SQL .= ","; - - } - chop($create_table_SQL); #Delete "," at the end. - $create_table_SQL .= ") "; - chop($new_rec_SQL); #Delete "," at the end. - $new_rec_SQL .= ")"; - - debug_print("AppManager::check_table: create_SQL = [".$create_table_SQL."]"); - - my $sth = $af->{db}->prepare($create_table_SQL) or - throw Affelio::exception::DBException("cannot create table"); - $sth->execute() or - throw Affelio::exception::DBException("cannot create table"); - - debug_print("AppManager::check_table: created the table!"); - - ############################################# - #Synchronized the table - # Find all records from AFuser_CORE_permission and - # prepare 0-filled records into my table - my $CORE_perm_tbl = $af->{perm}->get_all_permission(); - while( my($pid, $type, $target, $dummy) = $CORE_perm_tbl->fetchrow_array ){ - - my $SQL = $new_rec_SQL . " values ('$pid','$type','$target',1,0,"; - for($i=0; $i < $num_action_types; $i++){ - $SQL .= "0,"; - } - chop($SQL); - $SQL .= ")"; - - debug_print("AppManager::check_table: insert_SQL = [".$SQL."]"); - my $sth = $af->{db}->prepare($SQL) or - throw Affelio::exception::DBException("cannot insert"); - $sth->execute() or - throw Affelio::exception::DBException("cannot insert"); - - } - - - } - debug_print("AppManager::check_table: end."); - } - - ###################################################################### - #update_permission - ###################################################################### - sub update_permission{ - my $self = shift; - my $af = $self->{af}; - - my $app_name = shift; - my $pid = shift; - my $action_type = shift; - my $value = shift; - - #prepare SQL query - my $query = "update AFuser_" . $app_name . "_permission set " - . "$action_type = $value where pid=$pid"; - #debug_print("AppManager::update_permission q=[$query]"); - - #access DB - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - #debug_print("AppManager::update_permission end."); - } - - - ###################################################################### - #load_applications - ###################################################################### - sub load_applications{ - my $self = shift; - my $af = $self->{af}; - - my $app_dir; - opendir(DIR, "$af->{top_dir}/apps"); - while (defined($app_dir = readdir(DIR))) { - if( ($app_dir ne '.') - && ($app_dir ne '..') - && ($app_dir ne 'index.html') - && ($app_dir ne 'sampleapp') - && ($app_dir ne 'CVS') - ){ - - ################################## - #For each found application... - ################################## - debug_print("Affelio::load_apps: [$app_dir]"); - - ################################## - #Open a config file - ################################## - my $cfg = new Config::IniFiles( -file => "$af->{top_dir}/apps/$app_dir/AF_app.cfg" ); - if(!$cfg){ next; } - - my %this_app=(); - my $err_flag=0; - ################################## - #Read application-specific parameters - ################################## - my @read_parameter_list= - ("app_name", "app_version", "app_author", - "guest_index", "owner_index", - "action_types", "action_types_desc"); - - foreach my $param (@read_parameter_list){ - my $data = $cfg->val('application', $param); - if ($data){ - debug_print("Affelio::load_apps: \t$param = $data"); - $this_app{$param} = $data; - }else{ - debug_print("Affelio::load_apps: \t$param not found."); - $err_flag=1; - } - } - - my @this_app_action_types =(); - my @this_app_action_types_desc =(); - @this_app_action_types =split(',\s', $this_app{action_types}); - @this_app_action_types_desc =split(',', $this_app{action_types_desc}); - - ################################## - #Read installation-specific parameters - ################################## - my @inst_parameter_list= ("title"); - - foreach my $param (@inst_parameter_list){ - my $data = $cfg->val('this_installation', $param); - if ($data){ - debug_print("Affelio::load_apps: \t$param = $data"); - $this_app{"install_" . $param} = $data; - }else{ - debug_print("Affelio::load_apps: \t$param not found."); - $err_flag=1; - } - } - - ################################## - #Store into Affelio's hash - ################################## - if(!$err_flag){ - $self->{apps}->{$app_dir} - = {'app_name' => $this_app{'app_name'}, - 'app_version' => $this_app{'app_version'}, - 'app_author' => $this_app{'app_author'}, - 'guest_index' => $this_app{'guest_index'}, - 'owner_index' => $this_app{'owner_index'}, - # - 'action_types' => \@this_app_action_types, - 'action_types_desc' => \@this_app_action_types_desc, - # - 'install_name' => $app_dir, - 'install_title' => $this_app{'install_title'} - }; - } - - }#if - }#while - - } - - - - - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/GroupManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/GroupManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/GroupManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/GroupManager.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/GroupManager.pm Tue Oct 25 04:20:54 2005 @@ -1,476 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: GroupManager.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Managing::GroupManager; -{ - use strict; - - use lib("../../../extlib"); - use DBI; - - use lib("../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::DBroutines qw(db_value_replace); - - ######################################################################## - #Constructor - ######################################################################## - sub new{ - my $class = shift; - my $af = shift; - - debug_print("GroupManager::new: start."); - - my $self = {af => $af - }; - bless $self, $class; - - debug_print("GroupManager::new: end."); - return $self; - } - - ######################################################################## - #add_group - ######################################################################## - sub add_group{ #returns gid (int) - my $self = shift; - my $group_name = shift; #arg(1) group_name (string) - - debug_print("add_group: $group_name"); - - my $af = $self->{af}; - - ############################## - #Get existing max ID - my $query = 'SELECT max(gid) FROM AFuser_CORE_group'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - my $maxid = $row[0]; - if(defined($row[0])){ - $maxid = $row[0]; - }else{ - $maxid = 0; - } - debug_print("add_group: maxgid = $maxid"); - - ############################## - #Insert a new record - $query = 'insert into AFuser_CORE_group(gid, group_name, members, option_pid) values (?,?,?,?)'; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($maxid+1, $group_name, ",", -1); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("add_group: end."); - return($maxid+1); - } - - ######################################################################## - #remove_group - ######################################################################## - sub remove_group{ #void - my $self = shift; - my $gid = shift; #arg(1) gid - - debug_print("remove_group: g[$gid]"); - my $af = $self->{af}; - - my $query1 = 'SELECT option_pid FROM AFuser_CORE_group WHERE gid = ?'; - my $sth1; - eval{ - $sth1 = $af->{db}->prepare($query1); - $sth1->execute($gid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row1 = $sth1->fetchrow_array; - my $perm_id = $row1[0]; - - my $query2 = 'DELETE FROM AFuser_CORE_group WHERE gid = ?'; - my $sth2; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute($gid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - use Affelio::Managing::PermissionManager; - $af->{perm}->remove_permission_by_pid($perm_id); - - debug_print("remove_group: end."); - } - - ######################################################################## - #rename_group - ######################################################################## - sub rename_group{ - my $self = shift; - my $gid = shift; #arg(1) gid - my $new_name = shift; #arg(2) new_name - - debug_print("rename_group: g[$gid] -> [$new_name]"); - my $af = $self->{af}; - - ############################## - #Update DB - my $query = "update AFuser_CORE_group set group_name = '$new_name' where gid = $gid"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("rename_group: end."); - } - - - ######################################################################## - #get_member - ######################################################################## - sub get_member{ #returns int[] uids - my $self = shift; - my $gid = shift; #arg(1) gid - - debug_print("get_member: g[$gid]"); - my $af = $self->{af}; - - my $query = 'SELECT members FROM AFuser_CORE_group WHERE gid = ?'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($gid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - - if(!@row){ - debug_print("get_member: Error: No such group."); - return; - } - - my @member_array = split(",", $row[0]); - return(@member_array); - } - - - ######################################################################## - #add_member - ######################################################################## - sub add_member{ #void - my $self = shift; - my $gid = shift; #arg(1) gid - my $uid = shift; #arg(2) uid - - debug_print("add_member: g[$gid] <- u[$uid]"); - my $af = $self->{af}; - - ############################## - #retrieve a friend record from DB - my $query = 'SELECT * FROM AFuser_CORE_group WHERE gid = ?'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($gid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - my @row = $sth->fetchrow_array; - - if(!@row){ - debug_print("add_member: Error: No such group."); - return; - } - - ############################## - #Check existing member - my $current_mem = $row[2]; - if($current_mem =~ /,$uid,/){ - debug_print("add_member: Error: u[$uid] is already in g[$gid]"); - return; - } - - ############################## - #Add the new user - debug_print("add_member: Member($gid) = ($current_mem) (before)"); - my $new_mem = $current_mem . $uid . ","; - debug_print("add_member: Member($gid) = ($new_mem) (after)"); - - ############################## - #Update DB - $query = "update AFuser_CORE_group set members = '$new_mem' where gid = $gid"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("add_member: end."); - } - - - ######################################################################## - #remove_person_from_all - ######################################################################## - sub remove_person_from_all{ - my $self = shift; - my $uid = shift; #arg(1) uid - - my $af=$self->{af}; - - db_value_replace($af->{db}, - "AFuser_CORE_group", - "gid", - "members", - ",$uid," , - ",," , - ); - } - - - ######################################################################## - #remove_member - ######################################################################## - sub remove_member{ #void - my $self = shift; - my $gid = shift; #arg(1) gid - my $uid = shift; #arg(2) uid - - debug_print("remove_member: g[$gid] u[$uid]"); - my $af = $self->{af}; - - my $query = 'SELECT members FROM AFuser_CORE_group WHERE gid = ?'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($gid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - my @row = $sth->fetchrow_array; - - if(!@row){ - debug_print("remove_member: Error: No such group."); - return; - } - - debug_print("remove_member: Member($gid) = ($row[0]) (before)"); - $row[0] =~ s/,$uid,/,/; - debug_print("remove_member: Member($gid) = ($row[0]) (after)"); - - my $query2 = "update AFuser_CORE_group set members = '$row[0]' where gid = $gid"; - my $sth2; - eval{ - $sth2= $af->{db}->prepare($query2); - $sth2->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("remove_member: end."); - return; - } - - ######################################################################## - #get_groups_by_uid - ######################################################################## - #sub SQL_result get_groups_by_uid(uid) - #SQL_result (gid, group_name, members, option_pid) - sub get_groups_by_uid{ #returns SQL result - my $self = shift; - my $uid = shift; #arg(1) uid - - debug_print("get_groups_by_uid: u[$uid]"); - my $af = $self->{af}; - - my $query = - "SELECT * FROM AFuser_CORE_group WHERE members like '%,$uid,%'"; - debug_print("get_groups_by_uid: q=[$query]"); - - ############################## - #retrieve a friend record from DB - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - return($sth); - } - - ######################################################################## - #get_unsubscribing_groups_by_uid - ######################################################################## - #sub SQL_result get_unsubscribing_groups_by_uid - #SQL_result (gid, group_name, members, option_pid) - sub get_unsubscribing_groups_by_uid{ #returns SQL result - my $self = shift; - my $uid = shift; #arg(1) uid - - debug_print("get_unsubscribing_groups_by_uid: u[$uid]"); - my $af = $self->{af}; - - my $query = "SELECT * FROM AFuser_CORE_group WHERE members NOT like " - ."'%,$uid,%'"; - - debug_print("get_unsubscribing_groups_by_uid: q=[$query]"); - - ############################## - #retrieve a friend record from DB - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - return($sth); - } - - ######################################################################## - #get_all_group_list - ######################################################################## - #sub SQL_result get_all_group_list - #result (gid, group_name, members, option_pid) - sub get_all_group_list{ #returns SQL result - my $self = shift; - - debug_print("get_all_group_list: start"); - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $query = 'SELECT * FROM AFuser_CORE_group'; - my $sth; - eval{ - $sth= $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - return($sth); - } - - ######################################################################## - #set_member_by_intarray - ######################################################################## - sub set_member_by_intarray{ #void - my $self = shift; - my $gid = shift; #arg(1) gid - my $uids_ref = shift; #arg(2) * uid_array_ref - my @uids = @$uids_ref; - - debug_print("set_member_by_intarray: g[$gid] uids[@uids]"); - - my $uids_str=","; - while(my $member = pop(@uids)){ - $uids_str .= $member . ","; - } - - set_member_by_string($self,$gid, $uids_str); - debug_print("set_member_by_intarray: end."); - } - - ######################################################################## - #set_member_by_string - ######################################################################## - sub set_member_by_string{ #void - my $self = shift; - my $gid = shift; #arg(1) gid - my $uids_str = shift; #arg(2) uids_str ex. ",0,1,2,3...20," - - my $af = $self->{af}; - debug_print("set_member_by_string: g[$gid] uids[$uids_str]"); - - ############################## - #Update DB - my $query = "update AFuser_CORE_group set members = '$uids_str' where gid = $gid"; - my $sth; - eval{ - $sth= $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("set_member_by_string: end."); - } - - ######################################################################## - #set_pid - ######################################################################## - sub set_pid{ #void - my $self = shift; - my $gid = shift; #arg(1) gid - my $pid = shift; #arg(2) pid - - my $af = $self->{af}; - debug_print("set_pid: g[$gid] p[$pid]"); - - ############################## - #Update DB - my $query = "update AFuser_CORE_group set option_pid = $pid where gid = $gid"; - my $sth; - eval{ - $sth= $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("set_pid: end."); - } - - ######################################################################## - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/MessageManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/MessageManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/MessageManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/MessageManager.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/MessageManager.pm Tue Oct 25 04:20:54 2005 @@ -1,241 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: MessageManager.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Managing::MessageManager; -{ - use strict; - use lib("../../../extlib"); - use DBI; - use Jcode; - use lib("../../"); - use Affelio::misc::CGIError; - use Affelio::misc::Time qw(get_timestamp); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Debug qw(debug_print); - use Affelio::NetLib::Email qw(send_email); - use Affelio::exception::DBException; - - ####################################################################### - #Constructor - ####################################################################### - sub new{ - my $class = shift; - my $af = shift; - - debug_print("MessageManager::new: start."); - - my $self = {af => $af - }; - - bless $self, $class; - - debug_print("MessageManager::new: end."); - return $self; - } - - #MessageManager looks up each application directory - #to get the whole list of message types. - - ######################################################################## - #get_unread_message_num - ######################################################################## - sub get_unread_message_num{ - my $self = shift; - - debug_print("MM::get_unread_message_num: start"); - my $af = $self->{af}; - - my $sth; - eval{ - $sth = $af->{db}->prepare(q{SELECT * FROM AFuser_CORE_message where readflag=0}); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - return(""); - } - - my $count=0; - while(my @row = $sth->fetchrow_array){ - $count++; - } - - debug_print("MM::get_unread_message_num: end"); - return($count); - } - - - ######################################################################## - #mark_as_read - ######################################################################## - sub mark_as_read{ - my $self = shift; - my $mid =shift; - - my $af = $self->{af}; - - my $query = "update AFuser_CORE_message set readflag = 1 where mid = $mid"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("MM::retrieve_all: end"); - return(); - } - - - ######################################################################## - #retrieve_all_messages - ######################################################################## - #sub SQL_result get_all_group_list - # result (mid,timestamp,msg_title,msg_type,msg_from,msg_body,readflag) - sub retrieve_all_messages{ - my $self = shift; - - debug_print("MM::retrieve_all: start"); - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $sth; - eval{ - $sth = $af->{db}->prepare(q{SELECT * FROM AFuser_CORE_message order by timestamp desc}); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("MM::retrieve_all: end"); - return($sth); - } - - ######################################################################## - #retrieve_message - ######################################################################## - #sub SQL_result get_all_group_list - # result (mid,timestamp,msg_title,msg_type,msg_from,msg_body,readflag) - sub retrieve_message{ - my $self = shift; - my $mid = shift; - - debug_print("MM::retrieve: start"); - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $sth; - eval{ - $sth = $af->{db}->prepare("SELECT * FROM AFuser_CORE_message where mid = $mid"); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - - if(!@row){ - debug_print("MM::retrieve Error: No such group."); - return; - } - - debug_print("MM::retrieve: end"); - return(@row); - } - - ####################################################################### - #post_message - # arg1 SenderName: (app_name) - # arg2 Title: (UTF-8) - # arg3 Type: (Ascii) - # arg4 Body: (free text including URL) - ####################################################################### - sub post_message{ - my $self = shift; - my $from = shift; #1 - my $title = shift; #2 - my $type = shift; #3 - my $body = shift; #4 - - my $af = $self->{af}; - - Affelio::misc::Debug::debug_print("MM::post_message: start."); - - #DB - #mid,timestamp,msg_title,msg_type,msg_from,msg_body,readflag - - ############################## - #Get existing max ID - my $sth; - eval{ - $sth = $af->{db}->prepare(q{SELECT max(mid) FROM AFuser_CORE_message}); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - my $maxid = $row[0]; - if(defined($row[0])){ - $maxid = $row[0]; - }else{ - $maxid = 0; - } - my $newid = $maxid+1; - Affelio::misc::Debug::debug_print("MM::post_message: newid = $newid"); - - my $cur_time = Affelio::misc::Time::get_timestamp(); - - Affelio::misc::Debug::debug_print("MM::post_message: Writing to DB..."); - Affelio::misc::Debug::debug_print("MM::post_message: [$body]"); - - Affelio::misc::Debug::debug_print("size [" . length($body) ."]"); - - ############################## - #Insert a new record - my $str10 = "insert into AFuser_CORE_message(msgbody, mid, timestamp, msgtitle, msgtype, msgfrom, readflag) values ('$body', $newid, '$cur_time', '$title', '$type', '$from', 0)"; - eval{ - $sth = $af->{db}->prepare($str10); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - undef($sth); - - ############################## - #Email notification if needed - if($af->{userpref__mesging__emailflg} eq "yes"){ - my $abs_URL = $af->{site__web_root} . "/admin.cgi?mode=messages&action=show&mid=$newid"; - Affelio::NetLib::Email::send_email($af, "Your Affelio <$af->{user__email1}>", $af->{user__email1}, "New message to your Affelio", $abs_URL); - Affelio::misc::Debug::debug_print("MM::post_message: Email sent!"); - } - - Affelio::misc::Debug::debug_print("MM::post_message: end."); - return(""); - } - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/PermissionManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/PermissionManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/PermissionManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/PermissionManager.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/PermissionManager.pm Tue Oct 25 04:20:54 2005 @@ -1,285 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: PermissionManager.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Managing::PermissionManager; -{ - use strict; - - use lib("../../../extlib"); - use DBI; - use lib("../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::exception::DBException; - - ######################################################################## - #Constructor - ######################################################################## - sub new{ - my $class = shift; - my $af = shift; - - debug_print("PermissionManager::new: start."); - - my $self = {af => $af - }; - - bless $self, $class; - - debug_print("PermissionManager::new: end."); - return $self; - } - - ######################################################################## - #(1)add_permission - ######################################################################## - sub add_permission{ #return int pid - my $self = shift; - my $type = shift; #arg(1) IN char* type - my $id = shift; #arg(2) IN char* target_id - my $flag_array_ref = shift; #arg(3) IN * flag_array_ref - - my @flag_array = @$flag_array_ref; - my $flag_size = @flag_array; - - debug_print("add_permission type[$type] id[$id] size(flag)=$flag_size"); - my $af = $self->{af}; - - #add more elements upto 63 - for(my $i=$flag_size; $i<=63; $i++){ - push(@flag_array, "-1"); - } - $flag_size = @flag_array; - - debug_print("add_permission (increased) size(flag)=$flag_size"); - - #Decide $newid - my $query = 'SELECT max(pid) FROM AFuser_CORE_permission'; - my $sth; - eval{ - $sth= $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - my $maxid = $row[0]; - if(defined($row[0])){ - $maxid = $row[0]; - }else{ - $maxid = 0; - } - my $newid = $maxid + 1; - - #generate an SQL query - $query = "insert into AFuser_CORE_permission(pid, type, target_id"; - for(my $j=0; $j<=63; $j++){ - $query .= ", attr$j"; - } - $query .= ") values (?,?,?"; - for(my $k=0; $k<=63; $k++){ - $query .= "," . $flag_array[$k]; - } - $query .= ")"; - debug_print("add_permission q=[$query]"); - - #DB access - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($newid, $type, $id); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("add_permission DB access done."); - - #Set new_id into Friend table or Group table - if($type eq "f"){ - } - if($type eq "p"){ - #Set this new pid into Friend table record. - try{ - $af->{fm}->set_attribute_by_id($id, "option_pid", $newid); - }catch Affelio::exception::DBException with { - my $e = shift; - throw $e; - }; - } - if($type eq "g"){ - #Set this new pid into Group table record. - $af->{gm}->set_pid($id, $newid); - } - - debug_print("add_permission end."); - return($newid); - } - - - ######################################################################## - #(2)update_permission - ######################################################################## - sub update_permission{ #void - my $self = shift; - my $pid = shift; #arg(1) IN int pid - my $flag_array_ref = shift; #arg(2) IN * flag_array_ref - - my @flag_array = @$flag_array_ref; - - debug_print("update_permission pid[$pid]"); - my $af = $self->{af}; - - #add more elements upto 63 - my $flag_size = @flag_array; - for(my $i=$flag_size; $i<=63; $i++){ - push(@flag_array, "-1"); - } - - #prepare SQL query - my $query = "update AFuser_CORE_permission set "; - for(my $k=0; $k<=63; $k++){ - $query .= " attr$k = '" . $flag_array[$k] . "'," ; - } - chop($query); - $query .= " where pid='$pid'"; - debug_print("update_permission q=[$query]"); - - #access DB - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("PermissionManager::update_permission end."); - } - - ######################################################################## - #(3)get_permission - ######################################################################## - sub get_permission{ #return SQL_result - my $self = shift; - my $type = shift; #arg(1) IN char* type - my $id = shift; #arg(2) IN char* target_id - - debug_print("get_permission type[$type] id[$id]"); - my $af = $self->{af}; - - my $query = "SELECT * FROM AFuser_CORE_permission where type='$type' and target_id='$id'"; - debug_print("get_permission end: q=[$query]"); - - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("get_permission end."); - return($sth); - } - - - ######################################################################## - #(4)get_permission_by_pid - ######################################################################## - sub get_permission_by_pid{ #return SQL_result - my $self = shift; - my $pid = shift; #arg(1) IN int pid - - debug_print("get_permission_by_pid pid[$pid]"); - my $af = $self->{af}; - - my $query = 'SELECT * FROM AFuser_CORE_permission WHERE pid = ?'; - - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($pid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("get_permission_by_pid end."); - return($sth); - } - - ######################################################################## - #(5)remove_permission_by_pid - ######################################################################## - sub remove_permission_by_pid{ - my $self = shift; - my $pid = shift; #arg(1) IN int pid - - debug_print("remove_permission_by_pid pid[$pid]"); - my $af = $self->{af}; - - my $query = 'DELETE FROM AFuser_CORE_permission WHERE pid = ?'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute($pid); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("remove_permission_by_pid end."); - } - - ######################################################################## - #(6)get_all_permission - #sub SQL_result get_all_permission - #result (pid, type, target, a, b, c, d .....) - ######################################################################## - sub get_all_permission{ - my $self = shift; - - debug_print("get_all_premission: start"); - my $af = $self->{af}; - - ############################## - #retrieve all permission records from DB - my $query = 'SELECT * FROM AFuser_CORE_permission'; - - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - debug_print("get_all_premission: end"); - return($sth); - } - - -}#package -1; - Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ProfileManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ProfileManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ProfileManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ProfileManager.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/ProfileManager.pm Tue Oct 25 04:20:54 2005 @@ -1,207 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: ProfileManager.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::Managing::ProfileManager; -{ - use strict; - use lib("../../../extlib"); - use DBI; - use Jcode; - use Error qw(:try); - use lib("../../"); - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::exception::DBException; - - ####################################################################### - #Constructor - ####################################################################### - sub new{ - my $class = shift; - my $af = shift; - my $mode = shift; - - debug_print("ProfileManager::new: start."); - - my $self = {af => $af, - mode => $mode - }; - - bless $self, $class; - - #Load profile - if($mode ne "init"){ - $self->load_profile(); - } - - debug_print("ProfileManager::new: end."); - return $self; - } - - - ####################################################################### - #save_profile - ####################################################################### - sub save_profile{ - my $self = shift; - my $af = $self->{af}; - - #Write down user__* variables - foreach my $key (sort keys %$af){ - if($key =~ /user__/){ - my $key2 = $key; - $key2 =~ s/user__//g; - debug_print("ProfileManager::save_profile: $key2 = $af->{$key}"); - if($af->{$key} ne ""){ - try{ - save_profile_value($self, $key2, $af->{$key}); - }catch Affelio::exception::DBException with { - my $e = shift; - throw $e; - }; - } - } - } - - return(""); - } - - sub save_profile_value{ - my $self = shift; - my $af = $self->{af}; - my $attribute = shift; - my $value = shift; - - debug_print("ProfileManager::save_profile_value: ($attribute) = ($value)"); - - my $query = "SELECT * FROM AFuser_CORE_prof where attribute = '$attribute'"; - my $sth1; - eval{ - $sth1 = $af->{db}->prepare($query); - $sth1->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @result= $sth1->fetchrow_array(); - if(@result==()){ - my $query2 = 'insert into AFuser_CORE_prof(attribute, value) values (?,?)'; - my $sth2; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute($attribute, $value); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - }else{ - my $query3 = "update AFuser_CORE_prof set value = '$value' where attribute = '$attribute'"; - - my $sth3; - eval{ - $sth3 = $af->{db}->prepare($query3); - $sth3->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - } - } - - - ####################################################################### - #load_profile - ####################################################################### - sub load_profile{ - my $self = shift; - my $af = $self->{af}; - - debug_print("ProfileManager::load_profile: start."); - - my $SQL_profattr; - - try{ - $SQL_profattr = load_profile_table($self); - }catch Affelio::exception::DBException with { - my $e = shift; - throw $e; - }; - - my $attribute=""; my $value=""; - while( ($attribute, $value) = $SQL_profattr->fetchrow_array){ - $af->{"user__$attribute"} = $value; - debug_print("ProfileManager::load_profile: user__$attribute = " - . $af->{"user__$attribute"}); - } - - debug_print("ProfileManager::load_profile: end."); - return(""); - } - - ######################################################################## - #load_profile_table - # returns SQL_result (attribute, value) x records - ######################################################################## - sub load_profile_table{ - my $self = shift; - my $af = $self->{af}; - - my $sth; - my $query = 'SELECT * FROM AFuser_CORE_prof'; - - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - }; - - return($sth); - } - - ######################################################################## - #get_attribute_table - # returns SQL_result (aid, name, type) x records - ######################################################################## - sub get_attribute_table{ - my $self = shift; - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $query = 'SELECT * FROM AFuser_CORE_prof_attr'; - my $sth; - - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - }; - - return($sth); - } - - - -}#package -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/WhatsNewManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/WhatsNewManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/WhatsNewManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/WhatsNewManager.pm:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/Managing/WhatsNewManager.pm Tue Oct 25 04:20:54 2005 @@ -1,127 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: WhatsNewManager.pm,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -package Affelio::Managing::WhatsNewManager; -{ - use strict; - use lib("../../../extlib"); - use DBI; - use Jcode; - use lib("../../"); - use Affelio::misc::CGIError; - use Affelio::misc::Time qw(get_timestamp); - use Affelio::misc::Encoding qw(db_encode db_decode); - use Affelio::misc::Debug qw(debug_print); - - ####################################################################### - #Constructor - ####################################################################### - sub new{ - my $class = shift; - my $af = shift; - - debug_print("WhatsNewManager::new: start."); - - my $self = {af => $af - }; - - bless $self, $class; - - debug_print("WhatsNewManager::new: end."); - return $self; - } - - #WhatsNewManager looks up each application directory - #to get the whole list of message types. - - ######################################################################## - #retrieve_message - ######################################################################## - #sub SQL_result get_all_group_list - # result (mid,timestamp,msg_title,msg_type,msg_from,msg_body,readflag) - sub retrieve_all_messages{ - my $self = shift; - - debug_print("MM::retrieve: start"); - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $sth = $af->{db}->prepare(q{SELECT * FROM AFuser_CORE_message}) or die $af->{db}->errstr; - $sth->execute; - - debug_print("MM::retrieve: end"); - return($sth); - } - - ####################################################################### - #post_message - # arg1 SenderName: (app_name) - # arg2 Title: (UTF-8) - # arg3 Type: (Ascii) - # arg4 Body: (free text including URL) - ####################################################################### - sub post_message{ - my $self = shift; - my $from = shift; #1 - my $title = shift; #2 - my $type = shift; #3 - my $body = shift; #4 - - my $af = $self->{af}; - - Affelio::misc::Debug::debug_print("MM::post_message: start."); - -# $body = Affelio::misc::Encoding::db_encode($body); -# $title = Affelio::misc::Encoding::db_encode($title); -# $from = Affelio::misc::Encoding::db_encode($from); - - #mid,timestamp,msg_title,msg_type,msg_from,msg_body,readflag - - ############################## - #Get existing max ID - my $sth = $af->{db}->prepare(q{SELECT max(mid) FROM AFuser_CORE_message}) or die $af->{db}->errstr; - $sth->execute; - my @row = $sth->fetchrow_array; - my $maxid = $row[0]; - if(defined($row[0])){ - $maxid = $row[0]; - }else{ - $maxid = 0; - } - my $newid = $maxid+1; - Affelio::misc::Debug::debug_print("MM::post_message: newid = $newid"); - - my $cur_time = Affelio::misc::Time::get_timestamp(); - - Affelio::misc::Debug::debug_print("MM::post_message: Writing to DB..."); - Affelio::misc::Debug::debug_print("MM::post_message: [$body]"); - - ############################## - #Insert a new record - my $str1 = "insert into AFuser_CORE_message(mid, timestamp, msgtitle, msgtype, msgfrom, msgbody, readflag) values ($newid, '$cur_time', '$title', '$type', '$from', '$body', 0)"; - $sth = $af->{db}->prepare($str1) or die $af->{db}->errstr; - $sth->execute or die $af->{db}->errstr; - - Affelio::misc::Debug::debug_print("MM::post_message: end."); - - return(""); - } - -}#package -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:55 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:55 +0900 Subject: [Affelio-cvs 685] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N Message-ID: <20051024192055.929632AC040@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/en_us.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/en_us.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/en_us.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/en_us.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/en_us.pm Tue Oct 25 04:20:55 2005 @@ -1,230 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: en_us.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::L10N::en_us; -{ - use strict; - use lib("../../../../extlib"); - use lib("../../../../lib"); - use Affelio::misc::L10N; - # - use vars qw(@ISA %Lexicon); - - sub encoding { "UTF-8" } - - @ISA = qw(Affelio::misc::L10N); - - %Lexicon = ( - ########################################################## - #System - ########################################################## - '_SYS_ENCODING_DUMMY' =>'', - '_SYS_attr_opened' =>'Yes', - '_SYS_attr_closed' =>'', - - ########################################################## - #Setup wizard - ########################################################## - '_SETUP_title_10' => 'Welcome to Affelio!', - '_SETUP_msg_10' => 'Welcome to the Affelio setup wizard! You can set up Affelio easily and quickly by following the wizard screen.<P><B>This setup wizard is <FONT COLOR="red">NOT for upgrade install</FONT>. Please read release note document for upgrade install.</B><P>Click "Next" and proceed.', - # - '_SETUP_title_30' => 'On the GPL2.0 version', - '_SETUP_msg_30' => '<B><FONT COLOR="red">Caution!!</FONT></B>  This Affelio is "Affelio (GPL version)" which will be licensed for the customer via <A HREF="http://www.gnu.org/copyleft/gpl.html" target="_blank">GNU General Public License (GPL) 2.0</A>.</B> Push the "Accept" button and go to the next screen, <B>ONLY IF you understand this licensing policy.</B> <P><HR><P>NO WARRANTY (from GPL2.0)<BR>11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. <P>12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.<P><HR><P>Affelio is software with dual licensing based on GPL2.0 and Affelio Commercial License. Visit <A HREF="http://affelio.jp/modules/tinyd5/" target="_blank">our web page on the licenses</A>.', - # - '_SETUP_title_50' => 'Required Perl Modules', - '_SETUP_msg_50_1' => 'Followings are the Perl modules necessary for Affelio installation. If you can see any <FONT COLOR="red">NOT INSTALLED</FONT> module, install the module before you go to the next screen. <P>', - '_SETUP_msg_50_2' => 'Click "Next" when everything is ok.', - '_SETUP_msg_50_3' => '</blockquote>Also, <B>one of the following two modules</B> needs to be installed as a database driver module. If the database driver you want to use is <FONT COLOR="red">NOT INSTALLED</FONT>, install it before you go to the next screen.<blockquote>', - '_SETUP_check_50_err1' => 'You need to install some Perl modules more.', - # - '_SETUP_title_100' => 'Configuration File', - - '_SETUP_msg_100' => 'On your web server, set permission writable (example: 700 or 777) for the following directories.<UL><LI>config/<LI>userdata/<LI>session/<LI>skins/<LI>templates_dyn/<UL>', - - '_SETUP_check_100_err1' => '<LI>"affelio.cfg" not found.<BR>On your web server, create a file named "affeio.cfg" with writable file permission (example: 666) in the same directory as "stup.cgi"', - '_SETUP_check_100_err2' => '<LI>"affelio.cfg" is not readable.<BR>Set permission of "affelio.cfg" redable (example: 666).', - '_SETUP_check_100_err3' => '<LI>"affelio.cfg" is not writable.<BR>Set permission of "affelio.cfg" writable (example: 666).', - '_SETUP_check_100_err4' => '<LI>[_1] is not writable. Configure the file writable.</P>', - '_SETUP_check_100_err5' => '<LI>[_1] is not readable. Configure the file readable.</P>', - # - '_SETUP_title_200' => 'External Programs', - '_SETUP_msg_200' => '<P>The setup program detected place of \"sendmail\" command as follows. Click \"Next\" if you are okay with this.</P><P>Input the place (path) if the detected result is blank. Ask your web server\'s administrator if you don\'t know the path.</P>', - '_SETUP_check_200_err1' => 'sendmail is not found in [_1]!', - # - '_SETUP_title_350' => 'Choose your database', - '_SETUP_msg_350' => - '<P>Choose your database.</p>' - . '<P><INPUT TYPE="radio" NAME="dbtype" VALUE="mysql">MySQL' - . '<UL><TABLE BORDER=0>' - . '<TR><TD>DB name: </TD><TD><INPUT TYPE="text" NAME="mysql_dbname"></TD></TR>' - . '<TR><TD>DB username: </TD><TD><INPUT TYPE="text" NAME="mysql_username"></TD></TR>' - . '<TR><TD>password: </TD><TD><INPUT TYPE="text" NAME="mysql_password"></TD></TR>' - . '<TR><TD>DB hostname: </TD><TD><INPUT TYPE="text" NAME="mysql_hostname">(optional)</TD></TR>' - . '<TR><TD>port: </TD><TD><INPUT TYPE="text" NAME="mysql_port">(optional)</TD></TR>' - . '</TABLE></UL>' - . '<P><INPUT TYPE="radio" NAME="dbtype" VALUE="sqlite" checked>SQLite', - # - - '_SETUP_title_400' => 'Site Owner\'s Login Information', - '_SETUP_msg_400' => '<P>Decide and input your user name and password which are necessary for login as the site owner of this Affelio. Input your email address. </P><P>Also, decide and input your nickname on the Affelio. The nickname will be opended for the global Affelio network.</P>' - . '<P><TABLE BORDR="0"><TR><TD VALIGN="top">User name: </TD>' - . '<TD><INPUT TYPE="text" NAME="username" SIZE="30" VALUE=""><BR><font size="-2">(Alphabet and numerical letters)</font></TD></TR>' - . '<TR><TD VALIGN="top">Password: </TD>' - . '<TD><INPUT TYPE="text" NAME="password" SIZE="30" VALUE=""><BR><font size="-2">(Alphabet and numerical letters)</font></TD></TR>' - . '<BR><TR><TD>Email address: </TD>' - . '<TD><INPUT TYPE="text" NAME="email" SIZE="30" VALUE=""><BR><font size="-2">(Alphabet and numerical letters)</font></TD></TR>' - . '<TR><TD HIGHT="20"> </TD><TD> </TD></TR>' - . '<TR><TD VALIGN="top">Nickname: </TD>' - . '<TD><INPUT TYPE="text" NAME="nickname" SIZE="30" VALUE="" onBlur="checkNickname2(this)"><BR><font size="-2">(Alphabet and numerical letters)</font></TD></TR>' - . '</TABLE>', - # - '_SETUP_title_500' => 'Congratulations! Setup is complete.', - '_SETUP_msg_500' => '<P>Congratulations! Setup is complete. Your Affelio page is <A HREF="[_1]">[_1]</A>. Log onto your page and configure your profile!</P><P>Delete "setup.cgi" and "upgrade-*.cgi"s from the web server since it is not necessary any more and since it can be a security issue.</P>', - # - '_SETUP_group_dear_friend' => 'close friend', - # - '_SETUP_err_module_notfound' => '[_1]   <FONT COLOR="red"><B>NOT INSTALLED</B></FONT><BR>', - '_SETUP_module_found' => '[_1]   OK. installed. ([_2])<BR>', - - ########################################################## - #Friend class - ########################################################## - '_VISITOR_TYPE_PB' => 'Public Guest', - '_VISITOR_TYPE_F2' => 'Friend of A Friend', - '_VISITOR_TYPE_F1' => 'Friend', - '_VISITOR_TYPE_SELF' => 'Site Owner', - - ########################################################## - #Profile - ########################################################## - - ########################################################## - #System information - ########################################################## - - ########################################################### - #Handshake - ########################################################### - - ########################################################## - #owner pages - ########################################################## - #Top - '_ADMIN_TOP_EXP' => 'Here is the top page of the Affelio owner page that only the Affelio owner can access. Here you can configure the Affelio settings, such as profile, your friends, or Affelio itself.', - '_ADMIN_TOP_MYSTATUS' => 'My Greeting', - '_ADMIN_TOP_MYSTATUS_EXP' => 'Write your recent greeting! Your friends can see it.', - '_ADMIN_TOP_SEND_LINK_EXP' => 'Request a friend link for another Affelio', - '_ADMIN_TOP_SEND_LINK_EXP2' => 'Destination Affelio URL', - '_ADMIN_TOP_SEND_LINK_EXP3' => 'Send', - '_ADMIN_TOP_SEND_LINK_EXP4' => 'Your message to the person', - '_ADMIN_TOP_SEND_INVITATION_EXP' => 'Send invitation email to my friend', - '_ADMIN_TOP_SEND_INVITATION_EXP2' => 'Email address: ', - '_ADMIN_TOP_SEND_INVITATION_EXP3' => 'Send', - - ######################## - #Menu - - ######################## - "_ADMIN_ACCESS_CONTROL_EXP" => 'Here you can configure who ("friend", "friend of a friend", or other guests) can access which part of your personal information.', - "_ADMIN_ACCESS_CONTROL_DETAIL_EXP" => '<div class="afPubContentBlock"><div class="afPubContentBlockTitle">What are "friend"??friend of a friend"??public guest"?</div><UL><LI><b>Friend</b><BR>Those who you are directly connected to through Affelio.<P><img src="./images/friends.png"><LI><b>Friend of a Friend</b><BR>Those who "your friend" are directly connected to through Affelio.<P><img src="./images/friendsoffriends.png"><LI><b>Public Guest</b><BR>Those who cannot be in the two types above.</UL></div><div class="afPubContentBlock"><div class="afPubContentBlockTitle">What is "Group" for friends?</div><UL>For your friends, you can set access control more flexibly with "groups". For example, if you include a friend, <b>Tom</b>, in <b>group (A)</b>, Tom can access your <B>personal information which you configure to open for either "friend" or "group (A)"</B>.</UL></div>', - ######################## - "_ADMIN_EDIT_SKINS_EXP" => 'You can change the settings for skins of your public page<P><UL><LI>Select a skin from already installed ones<LI>Customize the skin you are currently using<LI>Back up the skin in zip file<LI>Install a skin by uploading zip file</UL>', - "_ADMIN_EDIT_SKINS_BACKUP_EXP" => 'You can backup your skins in zip file.<OL><LI>First, select the skin you want to backup<LI>Specify the name of saved skin file if you want to change it<LI>Click on the Download button</OL>', - "_ADMIN_EDIT_SKINS_UPLOAD_EXP" => 'You can upload skin package which is compressed as zip file.<OL><LI>First, select the skin to upload<LI>Click on the Upload button</OL>*.zip file will be recognized as skin package and *.gif, *.jpg, *.jpeg and *.png files will be uploaded upder the skin directory which is currently active.', - - ######################## - '_ADMIN_AFFELIO_CONFIG_EXP' =>'Here you can configure your Affelio.', - - '_ADMIN_SYSCONFIG_TOPPAGE_EXP' => 'You can set which module will be the top page, that is URL:<A HREF="[_1]" target="_blank">[_1]</A>', - - '_ADMIN_SYSCONFIG_NOTIFICATION_EXP' => 'Do you want to get email notification when you have a new message in Affelio Messaging?', - - '_ADMIN_SYSCONFIG_HOSTING_EXP' => 'Your preferred Affelio Hosting Service when you invite your friend into the Affelio world. <BR>(Coming Soon!)', - - - ######################## - "_ADMIN_EDIT_TEMPLATES_EXP" => 'Here, you can edit various template files for the design of your guest pages.', - - ######################## - "_ADMIN_EDIT_PROFILE_EXP" => 'Here, you can edit your profile on Affelio. <P><font color="red">You can disclose your profile only to whom you want disclose it. </font>', - "_ADMIN_EDIT_PROFILE_EXP2" => 'Tips for "Description": Examples are "Private", "Work", "MSN Messenger", or "Skype".', - "_ADMIN_EDIT_PROFILE_EXP3" => 'This introduction is opened for public. All visitor\'s to your Affelio can see it.', - "_ADMIN_EDIT_PROFILE_EXP4" => 'This introdcution can be access-controled. For instance, write your introduction which you want allow only your friend to access to it.', - - ######################## - '_ADMIN_FRIEND_GRAPH_EXP' => 'You and your friends are displayed in a graph. This is still a test version', - - ######################## - '_ADMIN_GROUP_FRIENDS_EXP' => '<BR>Here, you can configure which friend belongs which group.', - - 'Affelio Messaging' => 'Affelio Messaging', - 'Messages' => 'Messages', - '_ADM_MSG_FROM' => 'Sender', - '_ADM_MSG_TO' => 'To:', - '_ADM_MSG_TITLE' => 'Title:', - '_ADM_MSG_DATE' => 'Date:', - '_ADM_MSG_BODY' => 'Body:', - - '_ADM_MSG_EXP' => 'Here you can browse messages from your Affelio or friends in Affelio Network.', - - ######################## - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP' => 'Write your comment for the friend in the text box below. Comment will be on your Affelio\'s friend list page!', - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP1' => 'Information opened for [_1]', - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP2' => 'As a member of "[_1]"', - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP3' => 'Count out from this group', - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP4' => 'Add membership of other groups', - - ######################## - '_ADMIN_UPLOAD_PICTURES_EXP' => 'Here you can upload a picture for your Affelio profile.<BR><BR>Upload a JPEG file with .jpg or .jpeg extension. The maximum size is 150 x 150.<BR><BR><strong>It may take several seconds for upload to be completed, depending on the size of the picture.</strong>', - - - ######################## - '_ADMIN_ACCESS_LOG_EXP' => '', - - - ######################## - '_ADM_MSG_FROM' => 'Sender', - '_ADM_MSG_TITLE' => 'Title', - '_ADM_MSG_DATE' => 'Date', - '_ADM_MSG_EXP' => 'Here you can see messages from your Affeilo or your friends.', - - ######################## - '_ADMIN_MANAGE_FRIEND_TOP_EXP1' => 'Here you can edit your Affelio friends.<BR> * Write your comment for your friends.<BR> * Check your personal information disclosed for each friend.<BR> * You can adjust disclosure of your personal information by adding /deleting a friend to/from "groups".', - '_ADMIN_MANAGE_FRIEND_TOP_EXP2' => 'Friends of [_1]', - - ######################## - '_ADMIN_MANAGE_APP_TOP_EXP' => '', - '_ADMIN_MANAGE_APP_TOP_EXP1' => '', - '_ADMIN_MANAGE_APP_TOP_EXP2' => 'Applications currently installed on this Affelio', - 'DF_visibility' => 'Show in the app. tab', - 'DF_access' => 'Basic access to the app', - - ######################## - '_ADMIN_MANAGE_GROUP_TOP_EXP1' => 'Your Groups', - '_ADMIN_MANAGE_GROUP_TOP_EXP2' => 'Push the button after you input the group name to be added.', - '_ADMIN_MANAGE_GROUP_TOP_EXP3' => 'Group Name: ', - - ########################################################## - '_SYS_WARN_OUTGOING_PRIV_IP' => 'Warning:<BR>You are currently accessing this Affelio from a private IP address "[_1]". In such a case, note that the Affelio may not forward your login session to the destination Affelio.', - '_SYS_WARN_OUTGOING_PRIV_IP2' => 'Click this link to manually go to the destination Affelio! :)', - - ########################################################## - '_AUTO' => 1, - ); -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/ja.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/ja.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/ja.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/ja.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N/ja.pm Tue Oct 25 04:20:55 2005 @@ -1,352 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: ja.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::L10N::ja; -{ - use strict; - use lib("../../../../extlib"); - use lib("../../../../lib"); - use Affelio::misc::L10N; - use Affelio::misc::L10N::en_us; - # - use vars qw(@ISA %Lexicon); - - sub encoding { "UTF-8" } - - @ISA = qw(Affelio::misc::L10N::en_us); - - %Lexicon = ( - ########################################################## - #System - ########################################################## - '_SYS_ENCODING_DUMMY' =>'????祉??祉?', - '_SYS_attr_opened' =>'鐚?, - '_SYS_attr_closed' =>'鐚?, - - ########################################################## - #Setup wizard - ########################################################## - 'Affelio Setup Wizard' => 'Affelio ?祉???????????吟???, - 'Next' => '?????, - # - '_SETUP_title_10' => 'Affelio???????≪??????????!', - '_SETUP_msg_10' => 'Affelio???????≪??????????! Affelio???????≪????????c??若?綵√??х??≪???ず???????c??蚊?????с?膂≦??????????????c???????<P><B>????祉???????????吟????<FONT COLOR="red">Affelio???荀?ゃ??鴻??若?絨???с?</FONT>??????????????ffelio????潟??????????????翫???????????≪?????c??若???戎?c??祉?????????????<FONT COLOR="red"><B>篁ュ?????若?????帥?綣??膓??????????/B></FONT>篁ュ?????若??с???????????違??若???????????c??若???戎?????с????????ラ????????若??с????????鴻??若??????????????????</B><P>"?????????潟??若????罨<??蚊??с???????', - # - '_SETUP_title_30' => 'GPL????吾??潟????????ゃ???, - '_SETUP_msg_30' => '<B><FONT COLOR="red">??絵??</FONT></B>  ???Affelio???<B>GNU <A HREF="http://www.opensource.jp/gpl/gpl.ja.html" target="_blank">General Public License (GPL)</A> 2.0</B> ?с??ゃ??潟????????若??с??с????絎∽?????祉???????????吟??????????????蚊??с???ffelio????潟???????????翫????????ゃ??潟????????????????????<B>?????????????帥?????潟??若?????檎???????????</B><P><HR><P>?>?荐若??ゃ???(<A HREF="http://www.opensource.jp/gpl/gpl.ja.html">GPL2.0?ユ?茯?┳</A>???)<BR>????????????撮箴∞?????????┗???????????????羈??茯????????????????????????????????????篆?┝?????????????≪??ャ?菴違????????ゃ???????罔???????????篁???d?????????????????茵????????荐??????????????キ????с?篆?┝????祉???????????劫?????????????(?????????)?????????篆?┝?<???????????障??ф????????????違??????蟹????純??≪?????鴻?????鴻?????????鍵絮???????????????????ャ??????????????????????綽?????絎??罎??茖?信??信罩c?荀??????鴻?????鴻???????????????????P>??岡?????? (<A HREF="http://www.opensource.jp/gpl/gpl.ja.html">GPL2.0?ユ?茯?┳</A>???)<BR>??????????≪?????????c??純?????????????篏?┤????障????荐??荐怨??????????????????違???????紊????????絽???????????篏????????????????????????????????????筝???х??????幻???????ユ?絎潟??句????????ユ?絎?????帥?羔?け???罩g∈????????????膃?????茴?????紊宴?????????????????????????????≪?筝?????篏????????????桁??????????????????????)??????莢?算?????????????????????????????с??ゃ???充???綽?????????????????罕???????<P><HR><P>Affelio???GPL??ffelio?潟??若??c?????祉??鴻?????≪?????祉??鴻?????????????羇丞?????純??鴻??若???????????????翫? (????泣?????吾???????) ???GPL????吾??潟?????潟??若??c?????祉??鴻??若??с?????????????????с?????????A HREF="http://affelio.jp/modules/tinyd5/" target="_blank">??ffelio????ゃ??潟???/A> (http://affelio.jp) ???荀т????????ゃ??潟???勝?若??≪????荅潟????<A HREF="mailto:license @ affelio.jp">license @ affelio.jp</A> ?障??????????????', - 'Accept' => '?粋?', - - # - '_SETUP_title_50' => '綽????erl?≪??ャ??????????', - '_SETUP_msg_50_1' => '篁ヤ????Affelio????潟???????綽????erl?≪??ャ?????????????篏??<FONT COLOR="red">?ゃ??鴻??若??????????</FONT>?≪??ャ????????翫????罨<??蚊?????ゃ??鴻??若???????????<P>', - '_SETUP_msg_50_2' => '???????潟????????????????罨<??蚊??с???????', - '_SETUP_msg_50_3' => '</blockquote>?障?????若?????合??≪??ャ???????<B>篁ヤ?????<????ゃ??≪??ャ???/B>???荀?????篏睡????????若?????合?????吾??若???FONT COLOR="red">?ゃ??鴻??若??????????</FONT>?翫????罨<??蚊?????ゃ??鴻??若???????????<blockquote>', - '_SETUP_check_50_err1' => '?ゃ??鴻??若???????????≪??ャ????????障?', - # - - '_SETUP_title_100' => '荐??????ゃ??????, - '_SETUP_msg_100' => '篁ヤ???????????c????????≪???????????激??潟? 777 ??700 ?????GI?????昭???</B> ??┃絎???????????<UL><LI>config/<LI>userdata/<LI>session/<LI>skins/<LI>templates_dyn/</UL>', - '_SETUP_check_100_err1' => '<LI>affelio.cfg???????????BR>setup.cgi???????c??????????affelio.cfg?????????腥冴??<????????炊???????ermission?т?????????????', - '_SETUP_check_100_err2' => '<LI>CGI???affelio.cfg???絎鴻?茯??莨若??障????<BR>茯???吾????????若?????с???┃絎???????????', - '_SETUP_check_100_err3' => '<LI>CGI???affelio.cfg?御???昭????????BR>茯???吾????????若?????с???┃絎???????????', - '_SETUP_check_100_err4' => '<LI>[_1] ?????昭?水??????c???????????若?????с?荐??????c????????', - '_SETUP_check_100_err5' => '<LI>[_1] ????粋昭?水??????c???????????若?????с?荐??????c????????', - - # - '_SETUP_title_200' => '紊??????違????罎??', - '_SETUP_msg_200' => '<P>sendmail?潟??潟??????PATH)???????吟????篁ヤ???????罎???????????罎???с?????c??翫????罨?????????障????????ц???????????障???????????帥??????????????</P><P>腥堺???????????潟??潟???????????у??????????????贋???????????翫????Web?泣????????????????????筝?????</P>', - '_SETUP_check_200_err1' => '[_1] ??endmail????冴???????!', - # - '_SETUP_title_350' => '????帥??若??????, - '_SETUP_msg_350' => - '<P>篏睡????????帥??若??????????????(篏睡???????????????BD?≪??ャ?????ゃ??鴻??若??????????荀??????障?)</p>' - . '<P><INPUT TYPE="radio" NAME="dbtype" VALUE="mysql">MySQL' - . '<UL><TABLE BORDER=0>' - . '<TR><TD>DB?? </TD><TD><INPUT TYPE="text" NAME="mysql_dbname"></TD></TR>' - . '<TR><TD>DB????九?: </TD><TD><INPUT TYPE="text" NAME="mysql_username"></TD></TR>' - . '<TR><TD>???????? </TD><TD><INPUT TYPE="text" NAME="mysql_password"></TD></TR>' - . '<TR><TD>DB??????: </TD><TD><INPUT TYPE="text" NAME="mysql_hostname">(????激???</TD></TR>' - . '<TR><TD>???????? </TD><TD><INPUT TYPE="text" NAME="mysql_port">(????激???</TD></TR>' - . '</TABLE></UL>' - . '<P><INPUT TYPE="radio" NAME="dbtype" VALUE="sqlite" checked>SQLite', - # - '_SETUP_title_400' => '?泣?????若??若????????違??恰???, - '_SETUP_msg_400' => - '<P>???Affelio?泣?????????????????違??潟???????綽??????若??弱?????鴻??若???浦?????????????????????腟∞?????若??≪??????????????????/P><P>?障???ffelio???????若?筝??????????????????????????羆冴?????ュ????筝?????</p>' - . '<P><TABLE BORDR="0"><TR><TD VALIGN="top">????ゃ?????九?鐚?/TD>' - . '<TD><INPUT TYPE="text" NAME="username" SIZE="30" VALUE=""><BR><font size="-2">(?掩?絖?</font></TD></TR>' - . '<TR><TD VALIGN="top">?????????</TD>' - . '<TD><INPUT TYPE="text" NAME="password" SIZE="30" VALUE=""><BR><font size="-2">(?掩?絖?</font></TD></TR>' - . '<BR><TR><TD>?g機????若??≪????鐚?/TD>' - . '<TD><INPUT TYPE="text" NAME="email" SIZE="30" VALUE=""><BR><font size="-2">(?掩?絖?</font></TD></TR>' - . '<TR><TD HIGHT="20">??/TD><TD> </TD></TR>' - . '<TR><TD VALIGN="top">??????????若?鐚?/TD>' - . '<TD><INPUT TYPE="text" NAME="nickname" SIZE="30" VALUE="" onBlur="checkNickname2(this)"><BR><font size="-2">(?掩?絖?</font></TD></TR>' - . '</TABLE>', - # - '_SETUP_title_500' => 'Congrat! ?祉???????絎???с?鐚?, - '_SETUP_msg_500' => '<P>Congratulations! ?祉??????????篋???障????</P><P><FONT COLOR="red"><B>???setup.cgi???upgrade-*.cgi??????荀???????????????d????蕁????????????с?Web?泣????筝??????ゃ??????????</B></FONT> </P><P>罨<???A HREF="[_1]">[_1]</A>?????????Affelio?泣????????ゃ???????????ゃ???┃絎??????????/P>', - # - '_SETUP_group_dear_friend' => '荀??????', - # - '_SETUP_err_module_notfound' => '[_1]???<FONT COLOR="red"><B>?ゃ??鴻??若??????????!</B></FONT><BR>', - '_SETUP_module_found' => '[_1]???OK. ?ゃ??鴻??若????????障?. ([_2])<BR>', - - ########################################################## - #Friend class - ########################################################## - '_VISITOR_TYPE_PB' => '筝???蚊???, - '_VISITOR_TYPE_F2' => '???????', - '_VISITOR_TYPE_F1' => '???', - '_VISITOR_TYPE_SELF' => '?泣?????若???, - - ########################################################## - #Access_log - ########################################################## - 'Date/Time' => '?≪??祉????', - 'User Type' => '????吟??ゃ?', - - ########################################################## - #Profile - ########################################################## - 'Nickname' => '???????若?', - 'Last' => '???', - 'Given' => '???', - 'Middle' => '?????, - 'Birthday' => '茯????, - 'Picture' => '???', - 'Introduction 1' => '?????????綏援換篁?, - 'Introduction 2' => '荅潟????綏援換篁?, - 'Greeting' => '筝???鴻??若???, - 'URL 1' => 'Web?????1)', - 'URL 2' => 'Web?????2)', - 'URL 3' => 'Web?????3)', - 'IM 1' => 'IM?≪????(1)', - 'IM 2' => 'IM?≪????(2)', - 'IM 3' => 'IM?≪????(3)', - - 'New Group' => '?域?篏??', - 'Name here!' => '?違??若??????, - 'Save changes' => '紊?????絖????, - 'Save' => '篆??', - - ########################################################## - #System information - ########################################################## - "Please login." => '????ゃ???????????', - "reason" => '???', - "login" => '????ゃ?', - 'Login failed.' => '????ゃ???け????障????', - "We'll be back to the front page after 1 sec." => "1腱????????????若??????????", - "You can use only alphabets, numbers, and _ for your nickname." => "???????若???戎?????????茹???医???_ ????с???, - 'http://www.affelio.info' => 'http://www.affelio.jp', - - ########################################################### - #Handshake - ########################################################### - 'Link request has been sent out!' => '??????箴??????鴻?????障????', - 'Destination' => '絎??', - - 'Go back to the owner page' => 'Owner page?吾????', - - 'Link acceptance has been sent back to the requester.' => '???????粋????????檎??????????!', - - 'Requester' => '箴????, - "Requester's Affelio" => '箴?????Affelio', - 'detail' => "荅潟??????, - - ########################################################## - #owner pages - ########################################################## - #Top - 'Top' => '?????, - '_ADMIN_TOP_EXP' => '???????吾?Affelio?????????????吾????????с???ffelio????若??若??????????????≪??祉??с?????若??с???P>?脂?綏????;腓冴????????<??ャ?????????ffelio?泣?????????????????若????腮?隈????с??障???, - '_ADMIN_TOP_MYSTATUS' => '腱???蚊?????鴻??若???, - '_ADMIN_TOP_MYSTATUS_EXP' => '?蚊???????菴???????????????<?????吾????????????????????????????筝???鴻??若??鴻?荀?????????????', - '_ADMIN_TOP_SEND_LINK_EXP' => '篁??篋冴?Affelio?吾?????????????茫????, - '_ADMIN_TOP_SEND_LINK_EXP2' => '???????活?????御???ffelio URL', - '_ADMIN_TOP_SEND_LINK_EXP3' => '??????茫?????', - '_ADMIN_TOP_SEND_LINK_EXP4' => '?御??吾??<??祉??醐? ?????????綏援換篁?????紊援ぜ??????????????????', - '_ADMIN_TOP_SEND_INVITATION_EXP' => '??????緇???若??????, - '_ADMIN_TOP_SEND_INVITATION_EXP2' => '?<????????御?????若??≪????', - '_ADMIN_TOP_SEND_INVITATION_EXP3' => '?<?????????, - - ######################## - #Menu - 'Go to Guest Pages' => 'Guest????吾?', - 'Owner Page: Top' => 'OwnerPage?????, - - 'Affelio Options' => 'Affelio??┃絎?, - 'Application Options' => '?≪????荐??', - 'Logout' => '????≪???, - - ######################## - "Access Control (core)" => "?≪??祉??九勝 (?潟?)", - - "_ADMIN_ACCESS_CONTROL_EXP" => "????с??????????????????????????????篁ュ???査??????????泣?????????????????鴻???????荐???с??障???, - "_ADMIN_ACCESS_CONTROL_DETAIL_EXP" => '<div class="afPubContentBlock"><div class="afPubContentBlockTitle">"???"?????????"?????篁ュ???査"???鐚?/div><UL><LI><b>???</b><BR>??????Affelio??????????ャ??潟???宍?c?篋冴??<????<P><img src="./images/friends.png"><LI><b>???????</b><BR>?????????????Affelio????????????綣泣???査????с???P><img src="./images/friendsoffriends.png"><LI><b>???篁ュ???査</b><BR>筝??2?ゃ??????????????障????篋冴??<????</UL></div><div class="afPubContentBlock"><div class="afPubContentBlockTitle">"?????賢???????????鐚?/div><UL>???????贋・??????綣泣?????????????????違??若???戎?c?膣違???≪??祉??九勝?с??障??????????<strong>???</strong>??strong>?違??若?A</strong>???????翫????????????????????????????strong>??????1?や札筝???????/strong>???荐?????????宴???strong>?????strong>???????障???/UL></div>', - ######################## - 'Edit Skins' => '????ゃ??鴻??潟?膩??', - 'Skin Configuration for guest pages' => 'Guest????悟?????ゃ??鴻??潟?膩??', - 'Select skin' => '?鴻??潟??御?', - 'Choose' => '?御????', - 'Customize the currently selected skin' => '?上??御?筝???鴻??潟?CSS????鴻??????, - 'File name' => '????ゃ???, - 'Browse files of the currently-selected skin' => '?上??御?筝???鴻??潟??∫?????ゃ?????????, - 'Back up skin' => '?鴻??潟??????????', - 'Which skin' => '?鴻??潟??御?', - 'with what skin name' => '?????????????ュ? (箴? MySkin)', - 'optional' => '????激???, - 'Download' => '????潟??若?', - 'Upload skin' => '?鴻??潟??≪?????若?', - 'Upload' => '?≪?????若?', - 'Which file' => '????ゃ??????, -'You can edit the CSS in the following text area, only if permission of the skin file above is writable.' => 'Web?泣?????т?荐?SS????ゃ?????吾?莨若??????????????激??活┃絎?????????翫???????筝??????鴻?????≪??贋・膩?????絖????????', - "Style-sheet Template" => '????帥?????若??祉??潟???????', - "_ADMIN_EDIT_SKINS_EXP" => '????с???ublic????悟?????吟??潟??????????荐???????????<P><UL><LI>?ゃ??鴻??若?????????????????????????<LI>?上??御?筝???鴻??潟?????帥??ゃ??с??障???LI>?鴻??潟?ZIP????ゃ???????????≪??????????<LI>?鴻??潟?ZIP????ゃ?????????????????ゃ??鴻??若??с??障???/UL>', - "_ADMIN_EDIT_SKINS_BACKUP_EXP" => '????с?????若??寂?????????IP綵√???????????宴??吾????????????? (????潟??若?) ?с??障???OL><LI>?障????????≪???????????????????????<LI>????????????(??????????????????????????????????????????ュ???????????<LI>????潟??若?????潟??若??????????</OL>', - "_ADMIN_EDIT_SKINS_UPLOAD_EXP" => '????с???IP綵√???????????宴??吾??泣?????吾?????????????????≪?????若????????????札?????????????????????<OL><LI>?障????????????????????????????????<LI>?≪?????若?????潟??若??????????</OL>.zip????ゃ?????????????????鴻??潟?????若???????茘????????.gif, .jpg, .jpeg, .png????ゃ??????????????????憜??御????????鴻??潟????????????????????????????', - - ######################## - 'Affelio Configuration' => 'Affelio??┃絎?, - '_ADMIN_AFFELIO_CONFIG_EXP' =>'???????吾????Affelio???篏???≪?????障??障?荐????????????с??障???, - - '_ADMIN_SYSCONFIG_TOPPAGE_EXP' => '<A HREF="[_1]" target="_blank">[_1]</A>???????鴻???????茵?ず???????吾?荐????????', - - '_ADMIN_SYSCONFIG_NOTIFICATION_EXP' => '?<??祉??吾?絮??????????????<??????????????????┃絎???障???, - - '_ADMIN_SYSCONFIG_HOSTING_EXP' => 'Affelio???????????換篁????????????????????Affelio???????潟??泣??????RL??┃絎???障???BR>(Coming Soon!)', - - ######################## - 'Edit Templates' => '???????若???隈??, - 'Template Configuration for guest pages' => 'Guest????悟????????若???隈??, - "_ADMIN_EDIT_TEMPLATES_EXP" => '????с???ublic????悟????腮???潟???????膩????????<P>???????若???ぇ???篁ヤ???腮?????????障???UL><LI>Header??ooter??ight??eft???????若?<UL>筝???潟?罕????ffelio?脂????筝?窪?潟???????????????????Affelio?潟?????с????ffelio?≪??????????茵?ず????障????????脂?筝??筝??????主????????????????eader???????若???隈??????絖???????????</UL><LI>????c????????若?<UL>????c????????若????Affelio?潟?????若???賢荳??????上???ndex??list??rofile???ゃ?????障???ffelio?潟???????????≪?????脂???????????翫????????潟???????膩?????篆????????????</UL></UL>', - - "Rebuild all templates" => '?????????????若????罕?????', - "Save and rebuild" => '篆?????罕?????', - - "Header Template" => '??eader ???????若???, - "Left Template" => '??eft ???????若???, - "Right Template" => '??ight ???????若???, - "Footer Template" => '??ooter ???????若???, - "Body Template: 1.Index page" => '??ody ???????若? (1)?ゃ?????????, - "Body Template: 2.Friend list" => '??ody ???????若? (2)???筝?Η??, - "Body Template: 3.Profile page" => '??ody ???????若? (3)???????若???, - - ######################## - "Edit Profile" => "???????若???隈??, - "_ADMIN_EDIT_PROFILE_EXP" => 'Affelio???????若?筝?????????c????膩???с??障?????????拘?????????????????????????≪?????若??????????<P><B><font color="red">????у???????????c????????????????荐潟?????????????????鴻??潟????????純?篏帥??????????荐?????篋冴????????с??障???/font></B>', - 'Name on the Affelio network' => '??ffelio????????????', - 'Your basic information' => '?堺????', - 'Your contact on the net' => '??????腟≦?', - "_ADMIN_EDIT_PROFILE_EXP2" => '???????????????????????????????鴻????篋???????????MSN????祉?????c?茯????????梢?????????:)', - "Description" => '茯??', - - "_ADMIN_EDIT_PROFILE_EXP3" => '<B><FONT color="red">羈??!!</font>: ???????????????????с????綏援換篁???с???/B>?≪??祉??九勝???????????BR>茯違????????????????絎鴻????莠???障??????, - "_ADMIN_EDIT_PROFILE_EXP4" => '<B>綽?????????≪??祉??狗????????????訓膣剛???????</B><BR>??????????ャ?Affelio???????????????綏援換篁??????若???????????吾??障??????, - - ######################## - "Friend Graph" => '????≫???, - '_ADMIN_FRIEND_GRAPH_EXP' => '????????査?≫????????ц;腓冴??障???ava??戎?c????????若??с??с???P>羈??鐚??????????????????違?????倶???;???????????????????若?筝??????鴻??贋?????帥???????????井??宴??≪?????若??????拭?????????????', - 'Retrieve the latest information' => '????????♂?篆??????違???, - - ######################## - "Group Friends" => '??????????????, - '_ADMIN_GROUP_FRIENDS_EXP' => '<BR>????с?????????????????????ャ????荐???с??障???, - - ######################## - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP' => '膣剛?????潟??潟???札筝??????鴻??????????????????? ?吾?????<????????????ffelio???????若?????膣剛?罨???画?????障????', - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP1' => '[_1]???????????????????????, - 'Summary' => '?泣????', - 'As a friend' => '????????, - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP2' => '[_1]?<?????????, - 'Unregister' => '?????, - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP3' => '????違??若????????????, - '_ADMIN_MANAGE_FRIEND_SHOW_MEMBER_EXP4' => '?????????????<??????????', - 'Add' => '菴遵?', - - ######################## - 'Upload Pictures' => '??????????????, - '_ADMIN_UPLOAD_PICTURES_EXP' => 'Affelio????吾???????????????????????с??障???BR><BR>?≦宍絖?? .jpg ??.jpeg ??PEG????ゃ???????????????????????上?????泣??冴?150x150?????????<BR><BR><strong>??拭????潟??若???????????若????????????с???????????翫??????????</strong>', - - 'Your current picture' => '?上?荐?????????????, - 'Choose a picture to upload' => '?≪?????若????????ゃ????絎???????????', - 'Upload' => '?≪?????若?', - - ######################## - 'Access Log' => '莇潟???, - '_ADMIN_ACCESS_LOG_EXP' => '????с????????????ffelio??┴??????荐??鐚?恭???鐚???????????????????????<P>"Global"??垩???ffelio????吟????筝??????鴻???????????≪??祉???垩????<BR>"Affelio"??垩????篏??????鴻??????ffelio????吟?????≪??祉??????????????????????<P>莇潟????罧????ffelio????吟????????若??????????????????査??ffelio????潟?????障?Affelio????吟?????≪??祉??с????????劫?????????;腓冴???????', - - - ######################## - 'Referrer Log' => '?≪??祉????', - - ######################## - 'Affelio Messaging' => 'Affelio?<??祉??吾???, - 'Messages' => '?<??祉???, - '_ADM_MSG_FROM' => '?坂拭??, - '_ADM_MSG_TO' => '絎??', - '_ADM_MSG_TITLE' => '?帥????', - '_ADM_MSG_DATE' => '?ユ?', - '_ADM_MSG_BODY' => '???', - - 'Config' => '荐??', - 'Compose' => '?域?篏??', - 'Go back to the list' => '筝?Η?吾????', - - '_ADM_MSG_EXP' => '????????ffelio????????????絮?????????若???;腓冴???????<P>Affelio??????????Affelio?<??祉??吾??違?篁???帥?篏帥????????若?????????с??障?鐚?P>?障?????????ffelio鐚???鴻???????????ャ?????激?????倶?????ャ??<??祉??吾?????鴻?????????????', - - ######################## - 'Manage Friends' => '?????隈??, - '_ADMIN_MANAGE_FRIEND_TOP_EXP1' => '????с???ffelio?с?????c?????蚊?????????隈?????????<BR><BR>?糸????換篁??????<?????吾??障??????BR>?糸?????後??????????????????査???????с?????????????<BR>?糸???????????菴遵?????????????????ゃ????????????????膀????????', - '_ADMIN_MANAGE_FRIEND_TOP_EXP2' => '??_1]???????筝?Η??, - - ######################## - "Access Control (apps)" => "?≪??祉??九勝 (?≪???", - 'Manage Applications' => '?≪?????若??с???┃絎?, - '_ADMIN_MANAGE_APP_TOP_EXP' => '', - '_ADMIN_MANAGE_APP_TOP_EXP1' => '????с?????≪????絲障????????鴻??潟???????荐???с??障???P>???????宴??激??潟?????ゃ???????????????????????ャ??c??????;腓冴????????≪?????若??с??吾?荐???????????', - '_ADMIN_MANAGE_APP_TOP_EXP2' => '?上??ゃ??鴻??若??????????????宴??激??割?荀?, - 'DF_visibility' => '?≪?????????;腓?, - 'DF_access' => '?≪???????????????, - - ######################## - 'Manage Groups' => '?違??若???隈??, - '_ADMIN_MANAGE_GROUP_TOP_EXP1' => '?????????荀с?', - 'Rename' => '????若?', - 'Edit members' => '?<????膩??', - 'Edit access control' => '?≪??祉??九勝??隈??, - 'Delete' => '???', - '_ADMIN_MANAGE_GROUP_TOP_EXP2' => '?違??颷遵?????違??若?????ュ????????帥??????????????', - '_ADMIN_MANAGE_GROUP_TOP_EXP3' => '?違??若?????ュ?', - - ########################################################## - 'Link request has been sent out!' => '??????茫??????障???', - 'Destination' => '絎??Affelio: ', - 'Go back to the owner page' => '???????若??御???, - - ########################################################## - '_SYS_WARN_OUTGOING_PRIV_IP' => '??絵??BR>?上??????????????????P?с???_1]????≪??祉??????????????翫??????ffelio?吾??祉??激??活拶????????с?????翫???????????с?????帥???????', - '_SYS_WARN_OUTGOING_PRIV_IP2' => '?????????????????ffelio?後?????障???)', - - ########################################################## - '_AUTO' => 1, - ); -} -1; - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:55 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:55 +0900 Subject: [Affelio-cvs 686] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/misc Message-ID: <20051024192055.6C7B32AC039@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/CGIError.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/CGIError.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/CGIError.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/CGIError.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/CGIError.pm Tue Oct 25 04:20:55 2005 @@ -1,55 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: CGIError.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; - -package Affelio::misc::CGIError; -{ - use Exporter; - @Affelio::misc::CGIError::ISA = "Exporter"; - @Affelio::misc::CGIError::EXPORT = qw (error); - $Affelio::misc::CGIError::VERSION="0.01"; - - use CGI; - use CGI::Carp qw( fatalsToBrowser ); - - BEGIN{ - sub carp_error{ - my $error_message = shift; - my $q = new CGI; - - my $discard_this = $q->header("text/html"); - error ( $q, $error_message); - } - CGI::Carp::set_message( \&carp_error ); - } - - sub error{ - my ($q, $error_message) = @_; - - print $q->header("text/html"), - $q->start_html("Affelio Error"), - $q->h1("Affelio: We've got an error."), - $q->p("Following error has occured."), - $q->p('<PRE>' . $error_message), - $q->end_html; - exit; - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/DBroutines.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/DBroutines.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/DBroutines.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/DBroutines.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/DBroutines.pm Tue Oct 25 04:20:55 2005 @@ -1,102 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: DBroutines.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::DBroutines; -{ - use lib("../../../lib/"); - use DBI; - - use Exporter; - @Affelio::misc::DBroutines::ISA = "Exporter"; - @Affelio::misc::DBroutines::EXPORT = qw (db_value_replace); - - sub db_value_replace{ - my $db = shift; - my $dbname = shift; - my $key_col = shift; - my $target_col = shift; - my $old = shift; - my $new = shift; - - my $key_data; - my $target_data; - my $target_data_new; - my %tmphash; - - Affelio::misc::Debug::debug_print("db_replace: start."); - ###################################### - #Retrieve data - ###################################### - my $q1 = "SELECT $key_col, $target_col FROM $dbname"; - - Affelio::misc::Debug::debug_print("db_replace: [$q1]"); - - my $s1 = $db->prepare($q1); - if($@){ - Affelio::misc::Debug::debug_print("db_replace:".$db->errstr); - die $db->errstr; - } - - $s1->execute(); - if($@){ - Affelio::misc::Debug::debug_print("db_replace:".$db->errstr); - die $db->errstr; - } - - while( ($key_data, $target_data) = $s1->fetchrow_array){ - $tmphash{$key_data} = $target_data; - } - undef($q1); - undef($s1); - - ###################################### - #Distill each line, replace, and store - ###################################### - Affelio::misc::Debug::debug_print("db_replace: distilling..."); - while (($key_data, $target_data) = each(%tmphash)) { - - $target_data_new = $target_data; - $old =~ s/\-/\\\-/g; - $target_data_new =~ s/$old/$new/g; - - Affelio::misc::Debug::debug_print("db_replace: [$key_data] [$target_data]->[$target_data_new]"); - - my $q2 = "update $dbname set $target_col = '$target_data_new' where $key_col = $key_data"; - Affelio::misc::Debug::debug_print("db_replace: [$q2]"); - - my $s2 = $db->prepare($q2); - if($@){ - Affelio::misc::Debug::debug_print("db_replace:".$db->errstr); - die $db->errstr; - } - - $s2->execute(); - if($@){ - Affelio::misc::Debug::debug_print("db_replace:".$db->errstr); - die $db->errstr; - } - - } - - Affelio::misc::Debug::debug_print("db_replace: end."); - } - - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Debug.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Debug.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Debug.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Debug.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Debug.pm Tue Oct 25 04:20:55 2005 @@ -1,53 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Debug.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::Debug; -{ - use Exporter; - @Affelio::misc::Debug::ISA = "Exporter"; - @Affelio::misc::Debug::EXPORT = qw (debug_print); - - sub debug_print{ - my ($msg)= @_; -#################### - return; -#################### - chomp ($msg); - $msg .= "\n"; - if($msg){ - my $filename=""; - - #SECURITY |;" - if(defined($ENV{'SCRIPT_NAME'})){ - $ENV{'SCRIPT_NAME'} =~ /([^\|\;\"]*)/; - $filename = $1; - - $filename =~ s/\//\_/g; - $filename =~ s/^\_//g; - $filename =~ s/\~//g; - $filename =~ s/\_bin\_.*//g; - $filename =~ s/\_[a-zA-Z]*\.cgi$//g; - open(OUT, ">> /tmp/af_$filename"); - - print OUT "$$: ", $msg; - close(OUT); - } - } - } -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Encoding.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Encoding.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Encoding.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Encoding.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Encoding.pm Tue Oct 25 04:20:55 2005 @@ -1,48 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Encoding.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::Encoding; -{ - use lib "../../../extlib"; - use Crypt::RC5; - use Jcode; - - use Exporter; - @Affelio::misc::Encoding::ISA = "Exporter"; - @Affelio::misc::Encoding::EXPORT = qw (db_encode db_decode); - - ######################################################################## - sub db_encode{ - my $str = shift; - - $str = jcode($str)->mime_encode; - $str =~ s/\n//g; - $str =~ s/\r//g; - - return($str); - } - - ######################################################################## - sub db_decode{ - my $str = shift; - - return(jcode($str)->mime_decode); - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/InitAffelio.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/InitAffelio.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/InitAffelio.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/InitAffelio.pm Tue Oct 25 04:20:55 2005 @@ -1,538 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: InitAffelio.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::InitAffelio; -{ - use strict; - use Exporter; - @Affelio::misc::InitAffelio::ISA = "Exporter"; - @Affelio::misc::InitAffelio::EXPORT = qw (create_userdir get_userdir create_af_cfg create_db_cfg create_login_cfg copy_def_files init_db set_datadir_perm setup_affelio); - - use lib("../../../extlib/"); - use Cwd; - use DBI; - use Error qw(:try); - use lib("."); - use lib("../../../lib/"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug; - use Affelio::misc::MyCrypt; - use Affelio::App::Admin::EditTemplates; - use Affelio::exception::Exception; - use Affelio::exception::DBException; - use Affelio::exception::IOException; - - ##################################################################### - sub create_userdir{ - my $topdir = shift; - - srand(time ^ ($$ + ($$ << 15))); - #userdata - my $dir1 = Affelio::misc::MyCrypt::generate_password(); - mkdir("$topdir/userdata/$dir1", 0777); - my $dir2 = Affelio::misc::MyCrypt::generate_password(); - mkdir("$topdir/session/$dir2", 0777); - } - - ##################################################################### - sub get_userdir{ - my $userdata_dir = shift; - - my $dir; - my $ret; - try{ - opendir(DIR, $userdata_dir); - - while (defined($dir = readdir(DIR))) { - if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS') - && ($dir ne 'index.html')){ - $ret = "$userdata_dir/$dir"; - } - } - }catch Error with{ - my $e=shift; - throw($e); - }; - return($ret); - } - - ##################################################################### - sub create_af_cfg{ - my $affelio_cfg_path = shift; - my $fs_root = shift; - my $web_root = shift; - my $char_set = shift; - my $template = shift; - my $sendmail_path = shift; - my $additional_cfg = shift; - - eval{ - open(OUT, "> $affelio_cfg_path"); - print OUT "[site_config]\n"; - print OUT "fs_root=$fs_root\n"; - print OUT "web_root=$web_root\n"; - print OUT "char_set =$char_set\n"; - print OUT "template =$template\n"; - print OUT "\n"; - print OUT "[command]\n"; - print OUT "sendmail=$sendmail_path\n"; - - if($additional_cfg){ - print OUT "[affelio_farm]\n"; - print OUT "$additional_cfg\n"; - } - - close OUT; - - chmod 0444, "$affelio_cfg_path"; - }; - - - } - - ##################################################################### - sub create_db_cfg{ - my $db_cfg_path = shift; - my $db_type = shift; - my $db_dbname=shift; - my $db_username = shift; - my $db_password = shift; - my $db_hostname = shift; - my $db_port = shift; - - eval{ - open(OUT, "> $db_cfg_path"); - print OUT "[db]\n"; - print OUT "type=$db_type\n"; - print OUT "dbname=$db_dbname\n"; - print OUT "username=$db_username\n"; - print OUT "password=$db_password\n"; - print OUT "hostname=$db_hostname\n"; - print OUT "port=$db_port\n"; - print OUT "[appdb]\n"; - print OUT "type=$db_type\n"; - print OUT "dbname=$db_dbname\n"; - print OUT "username=$db_username\n"; - print OUT "password=$db_password\n"; - print OUT "hostname=$db_hostname\n"; - print OUT "port=$db_port\n"; - close OUT; - }; - } - - ##################################################################### - sub create_login_cfg{ - my $login_cfg_path = shift; - my $username = shift; - my $crypted_password = shift; - - eval{ - open(OUT, "> $login_cfg_path"); - print OUT "[auth]\n"; - print OUT "username=$username\n"; - print OUT "password=$crypted_password\n"; - close OUT; - }; - } - - ##################################################################### - sub copy_def_files{ - my $top_dir=shift; - my $user_dir=shift; - my $locale = shift; - - #Copy default face JPEG file - system("cp -f $top_dir/defaults/profile_face.jpg $user_dir/profile_face.jpg"); - system("chmod 666 $user_dir/profile_face.jpg"); - - #Copy default preference file - system("cp -f $top_dir/defaults/preference.cfg $user_dir/preference.cfg"); - - system("cp -fr $top_dir/defaults/af_templates/$locale $user_dir/af_templates"); - } - - ##################################################################### - sub init_db{ - my $top_dir = shift; - my $g_nickname = shift; - my $g_email =shift; - my $g_lh=shift; - - debug_print("init_db: [$top_dir] [$g_nickname] [$g_email]"); - - ################################################################ - #Stage 0: load Affelio (init mode) - ################################################################ - my $cfg_dir = "$top_dir/config/"; - my $af; - my $dbh; - try{ - $af = new Affelio(ConfigDir => $cfg_dir, - Mode => "init"); - $dbh = $af->{db}; - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("Could not load Affelio (init): $e"); - }; - - ################################################################ - #Stage 1: DB creation - ################################################################ - - ################################ - #profile DB - ################################ - my $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_CORE_prof(attribute TEXT, value TEXT) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating prof: $@"); - } - - $af->{user__nickname} = $g_nickname; - $af->{user__email1} = $g_email; - try{ - $af->{pm}->save_profile(); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("Cannot save_profile: $@"); - }; - debug_print("saved profile"); - - ################################ - #profile attribute DB - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_CORE_prof_attr(aid INTEGER, name TEXT, type INTEGER) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating attr: $@"); - } - - my $sth = ""; - eval{ - $sth = $dbh->prepare(q{insert into AFuser_CORE_prof_attr(aid, name, type) values (?,?,?)}); - }; - if($@){ - throw Affelio::exception::DBException("SQL prepare: $@"); - } - - try{ - open(FIN, "$top_dir/defaults/AFuser_CORE_prof_attr.csv"); - - while(my $line=<FIN>){ - chomp($line); - my ($aid, $name, $type) = split(',', $line); - #print "$aid - $name - $type\n"; - - $sth->execute($aid, $name, $type); - } - close(FIN); - }catch Error with{ - my $e = shift; - throw Affelio::exception::IOException("prof_attr: $@"); - }; - - ################################ - #friends DB - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_CORE_friends(uid INTEGER PRIMARY KEY, af_id CHAR(255), nickname TEXT, timestamp TEXT, password TEXT, intro TEXT, option_pid INTEGER, lastupdated TEXT, f2list TEXT) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating friends tbl: $@"); - } - - ################################ - #erasedfriends DB - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_CORE_erasedfriends(uid INTEGER PRIMARY KEY, af_id CHAR(255), timestamp TEXT) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating erased friends tbl: $@"); - } - - ################################ - #friendsfriends DB - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_CORE_friendsfriends(uid INTEGER PRIMARY KEY, af_id CHAR(255), nickname TEXT, timestamp TEXT, f1list TEXT) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating F2 tbl: $@"); - } - - ################################ - #group DB - ################################ - $create_tbl_cmd = "CREATE TABLE AFuser_CORE_group(gid INTEGER, group_name TEXT, members TEXT, option_pid INTEGER)"; - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating grp tbl: $@"); - } - - ################################ - #Permission DB - ################################ - $create_tbl_cmd = "CREATE TABLE AFuser_CORE_permission(pid INTEGER, type TEXT, target_id TEXT, "; - - for(my $i=0; $i<=63; $i++){ - $create_tbl_cmd .= " attr$i INT,"; - } - chop($create_tbl_cmd); - $create_tbl_cmd .= ")"; - debug_print("setup: create [$create_tbl_cmd]"); - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating perm tbl: $@"); - } - - ################################ - #tmp_recvd_hs - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_SNS_tmp_recvd_hs(sessionid TEXT, timestamp TEXT, af_id CHAR(255), nickname TEXT, DH_key_str TEXT) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating tmp_recved tbl: $@"); - } - - ################################ - #tmp_sent_hs - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_SNS_tmp_sent_hs(sessionid TEXT, timestamp TEXT, af_id CHAR(255), nickname TEXT, DH_key_str TEXT) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating tmp_send tbl: $@"); - } - - ################################ - #message - ################################ - $create_tbl_cmd = <<EOT; -CREATE TABLE AFuser_CORE_message(mid INTEGER PRIMARY KEY, timestamp TEXT, msgtitle TEXT, msgtype TEXT, msgfrom TEXT, msgbody TEXT, readflag INTEGER) -EOT - if(!$dbh->do($create_tbl_cmd)){ - throw Affelio::exception::DBException("creating msg tbl: $@"); - } - - try{ - $dbh->disconnect; - }catch Error with{ - my $e = shift; - throw Affelio::exception::DBException("DB disconnecting: $@"); - }; - - ################################################################ - #Stage 2: Reload Affelio - ################################################################ - try{ - undef($af); - $af = new Affelio(ConfigDir => $cfg_dir); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("Couldnot load Affelio: $e"); - }; - - ################################ - #Set permission to F1 - ################################ - # n names b i intro email url im - my @flag_array = (1,1,1,1, 1,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); - try{ - $af->{perm}->add_permission("f", "f1", \@flag_array); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("adding F1 perm: $@"); - }; - - ################################ - #Set permission to F2 - ################################ - # n names b i intro email url im - my @flag_array = (1,0,0,0, 0,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); - try{ - $af->{perm}->add_permission("f", "f2", \@flag_array); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("adding F2 perm: $@"); - }; - - ################################ - #Set permission to PB - ################################ - # n names b i intro email url im - my @flag_array = (1,0,0,0, 0,0, 1,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,0,0, 0); - try{ - $af->{perm}->add_permission("f", "pb", \@flag_array); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("adding PB perm: $@"); - }; - - ################################ - #Make a new group "dear_friend" - ################################ - my $gid; - try{ - $gid = $af->{gm}->add_group($af->{lh}->maketext("_SETUP_group_dear_friend")); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("adding dear Grp: $@"); - }; - - ##################################### - #Set permission to group "dear_friend" - ##################################### - # n names b i intro email url im - my @flag_array = (1,1,1,1, 1,1, 1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1,1,1, 1); - try{ - $af->{perm}->add_permission("g", $gid, \@flag_array); - }catch Error with{ - my $e = shift; - throw Affelio::exception::Exception("adding perm to Grp: $@"); - }; - } - - ##################################################################### - sub set_datadir_perm{ - my $top_dir = shift; - my $userdir = get_userdir("$top_dir/userdata"); - - #hmmmmmm.... - system("chmod -R 777 $userdir"); - } - - - ##################################################################### - #setup_affelio - # all-in-one function to setup affelio - ##################################################################### - sub setup_affelio{ - my $root_dir = shift; - my $root_url = shift; - my $locale = shift; - my $lh = shift; - my $template = shift; - my $additional_cfg = shift; - my $sendmail_path = shift; - # - my $db_type = shift; - my $db_dbname = shift; - my $db_username = shift; - my $db_password = shift; - my $db_hostname = shift; - my $db_port = shift; - # - my $username = shift; - my $password = shift; - my $nickname =shift; - my $email =shift; - - debug_print("InitAffelio:setup start."); - debug_print("\t$root_dir "); - debug_print("\t$root_url "); - debug_print("\t$locale "); - debug_print("\t$lh "); - debug_print("\t$template "); - debug_print("\t$additional_cfg"); - debug_print("\t$sendmail_path "); - debug_print("\t$db_type "); - debug_print("\t$db_dbname "); - debug_print("\t$db_username "); - debug_print("\t$db_password "); - debug_print("\t$db_hostname "); - debug_print("\t$db_port "); - debug_print("\t$username "); - debug_print("\t$password "); - debug_print("\t$nickname "); - debug_print("\t$email "); - - ################################ - #(1)Create user dir - create_userdir($root_dir); - debug_print("InitAffelio:setup (1) create dir done."); - - ################################ - #(2)Create af_cfg - create_af_cfg("$root_dir/config/affelio.cfg", - $root_dir, - $root_url, - $locale, - $template, - $sendmail_path, - $additional_cfg); - chmod 0700, "$root_dir/config"; - debug_print("InitAffelio:setup (2) create affelio.cfg done."); - - ################################ - #(3)Get userdata dir - my $user_dir = ""; - $user_dir = get_userdir("$root_dir/userdata"); - debug_print("InitAffelio:setup (3) user dir = [$user_dir]"); - - ################################ - #(4)create db.cfg - create_db_cfg("$user_dir/db.cfg", - $db_type, - $db_dbname, - $db_username, - $db_password, - $db_hostname, - $db_port); - debug_print("InitAffelio:setup (4) create db.cfg done"); - - ################################ - #(5)create login.cfg - my @salts = ( "A".."Z", "a".."z", "0".."9", ".", "/" ); - my $salt = $salts[int(rand(64))] . $salts[int(rand(64))]; - my $crypted_password = crypt($password, $salt); - create_login_cfg("$user_dir/login.cfg", - $username, - $crypted_password); - debug_print("InitAffelio:setup (5) create login.cfg [$crypted_password] done."); - - ################################ - #(6)Copy default files - copy_def_files($root_dir , $user_dir, $locale); - debug_print("InitAffelio:setup (6) copy default files. done."); - - ################################ - #(7)initialize DB - init_db($root_dir , $nickname, $email, $lh); - debug_print("InitAffelio:setup (7) Init DB done."); - - ################################ - #(8)Rebuild template - my $af; - $af = new Affelio(ConfigDir => "$root_dir/config/"); - Affelio::App::Admin::EditTemplates::rebuild($af); - debug_print("InitAffelio:setup (8) Rebuild template done."); - - ################################ - #(9)Set permission - set_datadir_perm($root_dir ); - debug_print("InitAffelio:setup (9) Set permission done."); - - debug_print("InitAffelio:setup ****ALL DONE****"); - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/L10N.pm Tue Oct 25 04:20:55 2005 @@ -1,34 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: L10N.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::L10N; -{ - use strict; - use lib("../../../extlib"); - use Locale::Maketext; - - use lib("../../../lib"); - use Affelio::misc::L10N; - - @Affelio::misc::L10N::ISA = qw(Locale::Maketext); - @Affelio::misc::L10N::Lexicon = (_AUTO => 1, - ); - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/MyCrypt.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/MyCrypt.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/MyCrypt.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/MyCrypt.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/MyCrypt.pm Tue Oct 25 04:20:55 2005 @@ -1,88 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: MyCrypt.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::MyCrypt; -{ - use lib "../../../extlib"; - use Crypt::RC5; - - use Exporter; - @Affelio::misc::MyCrypt::ISA = "Exporter"; - @Affelio::misc::MyCrypt::EXPORT = qw (generate_password msg_encrypt msg_decrypt url_encode url_decode verify_password); - - ######################################################################## - sub generate_password{ - @chara=('a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z','0','1','2','3','4','5','6','7','8','9'); - for($i=0; $i<9; $i++){ - $str .= $chara[int(rand($#chara+1))]; - } - return $str; - } - - ######################################################################## - sub msg_encrypt{ - my $plaintext = shift; - my $key = shift; - if ($key eq ""){ - die "msg_encrypt: Key is not defined!"; - } - - my $ref = Crypt::RC5->new($key, 12 ); - return( $ref->encrypt( $plaintext ) ); - } - - ######################################################################## - sub msg_decrypt{ - my $ciphertext = shift; - my $key = shift; - if ($key eq ""){ - die "msg_decrypt: Key is not defined!"; - } - - my $ref = Crypt::RC5->new($key, 12 ); - return($ref->decrypt( $ciphertext )); - } - - ######################################################################## - sub url_encode{ - my $str = shift; - $str =~ s/(\W)/sprintf("%%%02X", ord($1))/ego; - return($str); - } - - ######################################################################## - sub url_decode{ - my $str = shift; - $str =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex($1))/ego; - return($str); - } - - ######################################################################## - sub verify_password{ - $passwd = shift; - $epasswd = shift; - - if ($epasswd eq crypt($passwd, $epasswd)) { - return(1); - }else{ - return(-1); - } - } - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/NetMisc.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/NetMisc.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/NetMisc.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/NetMisc.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/NetMisc.pm Tue Oct 25 04:20:55 2005 @@ -1,125 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: NetMisc.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::NetMisc; -{ - use strict; - use Exporter; - @Affelio::misc::NetMisc::ISA = "Exporter"; - @Affelio::misc::NetMisc::EXPORT = qw (get_remote_domain get_remote_host URL2domain URL2path hostname2domain check_private_IP_addr); - - ######################################################################## - sub check_private_IP_addr{ - my $addr = shift; - - if($addr =~ /^192\.168\.([0-9]+)\.([0-9]+)/){ - return(1); - } - if($addr =~ /^192\.0\.2\.([0-9]+)/){ - return(1); - } - if($addr =~ /^10\.([0-9]+)\.([0-9]+)\.([0-9]+)/){ - return(1); - } - if($addr =~ /^172\.16\.([0-9]+)\.([0-9]+)/){ - return(1); - } - return(0); - } - - ######################################################################## - sub get_remote_domain{ - my %env = shift; - my $DomainName = !$ENV{'REMOTE_HOST'}||$ENV{'REMOTE_HOST'}eq$ENV{'REMOTE_ADDR'}?gethostbyaddr(pack('C4',split(/\./,$ENV{'REMOTE_ADDR'})),2)||$ENV{'REMOTE_ADDR'}:$ENV{'REMOTE_HOST'}; - $DomainName =~ s/^[\-+_0-9A-Za-z]+\.//; - - return $DomainName; - } - - ######################################################################## - sub get_remote_host{ - my %env = shift; - my $hostname = !$ENV{'REMOTE_HOST'}||$ENV{'REMOTE_HOST'}eq$ENV{'REMOTE_ADDR'}?gethostbyaddr(pack('C4',split(/\./,$ENV{'REMOTE_ADDR'})),2)||$ENV{'REMOTE_ADDR'}:$ENV{'REMOTE_HOST'}; - - return $hostname; - } - - ######################################################################## - sub hostname2domain{ - my $hostname = shift; - my $domain=""; - my $host=""; - - ($host, $domain) = split(/\./, $hostname); - print "$domain\n"; - - - if($ENV{'REMOTE_HOST'} eq ""){ - $host = gethostbyaddr(pack("C4",split(/\./,$ENV{'REMOTE_ADDR'})),2); - }else{ - $host = $ENV{'REMOTE_HOST'}; - } - - } - - ######################################################################## - sub URL2domain{ - my $url = shift; - - # $url="http://a.b.c.www-2.yahoo.com/cgi-bin/~a.cgi"; - # $url="http://1.2.3.4/cgi-bin/~a.cgi"; - - my $ret=$url; - if($url =~ /http\:\/\/([0-9.]*)\//){ - #IP address - $ret =~ s|http://([0-9.]+)/.*|$1|; - }else{ - #DNS hostname - $ret =~ s|http://([A-Za-z0-9.-]+)/.*|$1|; - } - - return($ret); - } - - - ######################################################################## - sub URL2path{ - my $url = shift; - $url =~ s|[a-zA-Z]+://[^/]*||; - return($url); - } - - -}#package -1; - -sub a{ -print URL2domain("http://www.a.com/"); print "\n"; -print URL2domain("http://www.a.com/hogehoge"); print "\n"; -print URL2domain("http://www.a.com/hogehoge/"); print "\n"; -print URL2domain("http://www.a.com/hogehoge/aaa"); print "\n"; -print URL2domain("http://www.a.com/hogehoge/aaa/"); print "\n"; - -print URL2path("http://www.a.com/"); print "\n"; -print URL2path("http://www.a.com:8000/a/b/"); print "\n"; -print URL2path("http://localhost:8000/a/b/"); print "\n"; -print URL2path("http://www.a.com/hogehoge"); print "\n"; -print URL2path("http://www.a.com/hogehoge/"); print "\n"; -print URL2path("http://www.a.com/hogehoge/aaa"); print "\n"; -print URL2path("http://www.a.com/hogehoge/aaa/"); print "\n"; -} Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Sanitizer.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Sanitizer.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Sanitizer.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Sanitizer.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Sanitizer.pm Tue Oct 25 04:20:55 2005 @@ -1,96 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Sanitizer.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; - -package Affelio::misc::Sanitizer; - -use Exporter; - @ Affelio::misc::Sanitizer::ISA = "Exporter"; - @ Affelio::misc::Sanitizer::EXPORT = qw (escape_filename sanitize_URL sanitize_HTML sanitize_number); - -######################################################################### - -sub escape_filename { - my $forbedden = '\\\/\*\?\|"<>:,;% '; - my ($filename) = @_; - $filename =~ s/([$forbedden])/'%' . unpack('H2', $1)/eg; - return $filename; -} - -######################################################################### - -# Sanitize in HTML::Template template files. -# -# ESCAPE="HTML" -# ESCAPE="URL" -# - -######################################################################### - -sub sanitize_number { - my $num = shift; - $num =~ s/\D//g; - - return($num); -} - -sub sanitize_URL { - my $url = shift; - - # --- http://www.ietf.org/rfc/rfc2396.txt --- - # uric = reserved | unreserved | escaped - # reserved = ";" | "/" | "?" | ":" | "@" | "&" | "=" | "+" | "$" | "," - # unreserved = alphanum | mark - # mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")" - # escaped = "%" hex hex - - return '' if($url =~ m|[^;/?:@&=+\$,A-Za-z0-9\-_.!~*'()%]|); - - # --- http://www.ietf.org/rfc/rfc2396.txt --- - # scheme = alpha *( alpha | digit | "+" | "-" | "." ) - - if($url =~ /^([A-Za-z][A-Za-z0-9+\-.]*):/) { - my $scheme = lc($1); - my $allowed = 0; - $allowed = 1 if($scheme eq 'http'); - $allowed = 1 if($scheme eq 'https'); - $allowed = 1 if($scheme eq 'mailto'); - return '' if(not $allowed); - } - - $url =~ s/&/&/g; # & -> & - $url =~ s/'/'/g; # ' -> ' - - return $url; -} - -######################################################################### - -sub sanitize_HTML{ - my $str = shift; - - if( $$str ne "" ){ - $$str =~ s/&/&/g; - $$str =~ s/</</g; - $$str =~ s/>/>/g; - $$str =~ s/"/"/g; - } -} - -######################################################################### Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Time.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Time.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Time.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Time.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/Time.pm Tue Oct 25 04:20:55 2005 @@ -1,114 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Time.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::misc::Time; -{ - use strict; - use Exporter; - @Affelio::misc::Time::ISA = "Exporter"; - @Affelio::misc::Time::EXPORT = qw (get_today get_timestamp get_past_timestamp get_expire_stamp timestamp2string timestamp2stringB); - - sub timestamp2string{ - my $timestamp = shift; - - my $year = substr ($timestamp, 0, 4); - my $mon = substr ($timestamp, 4, 2); - my $mday = substr ($timestamp, 6, 2); - my $hour = substr ($timestamp, 8, 2); - my $min = substr ($timestamp, 10, 2); - my $sec = substr ($timestamp, 12, 2); - - return("$year/$mon/$mday $hour:$min"); - } - - sub timestamp2stringB{ - my $timestamp = shift; - - my $mon = substr ($timestamp, 4, 2); - my $mday = substr ($timestamp, 6, 2); - my $hour = substr ($timestamp, 8, 2); - my $min = substr ($timestamp, 10, 2); - my $sec = substr ($timestamp, 12, 2); - - return("$mon/$mday $hour:$min"); - } - - - - sub get_timestamp{ - my ($sec, $min, $hour, $mday, $mon, $year, - $wday, $yday, $isdst) = localtime(time()); - - return sprintf("%04d%02d%02d%02d%02d%02d", - $year+1900, $mon+1, $mday, - $hour, $min, $sec); - } - - - sub get_past_timestamp{ - my $past_sec = shift; - my ($sec, $min, $hour, $mday, $mon, $year, - $wday, $yday, $isdst) = localtime(time()-$past_sec); - - return sprintf("%04d%02d%02d%02d%02d%02d", - $year+1900, $mon+1, $mday, - $hour, $min, $sec); - } - - - sub get_today{ - my ($sec, $min, $hour, $mday, $mon, $year, - $wday, $yday, $isdst) = localtime(time()); - - return sprintf("%04d%02d%02d000000", - $year+1900, $mon+1, $mday); - } - - - sub get_expire_stamp{ - my $p_mday = shift; - my $p_hour = shift; - my $p_min = shift; - - my ($sec, $min, $hour, $mday, $mon, $year, - $wday, $yday, $isdst) = localtime(time()); - - $year+= 1900; - $mon += 1; -# $mday += 1; - - $min += $p_min; - if($min >= 60){ - $min -= 60; - $hour+=1; - } - $hour += $p_hour; - if($hour >= 24){ - $hour -= 24; - $mday+= 1; - } - $mday += $p_mday; - - return sprintf("%04d%02d%02d%02d%02d%02d", - $year, $mon, $mday, - $hour, $min, $sec); - } - - -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/misc/WebInput.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/misc/WebInput.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/misc/WebInput.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/misc/WebInput.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/misc/WebInput.pm Tue Oct 25 04:20:55 2005 @@ -1,228 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: WebInput.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -use strict; - -package Affelio::misc::WebInput; -{ - use lib("../../../lib/"); - use Affelio::exception::TaintedInputException; - use Affelio::misc::Debug qw(debug_print); - - ###################################################################### - sub new{ - my $class = shift; - my %param = @_; - - my $self = {locale => "ja"}; - bless $self, $class; - - return($self); - } - - ###################################################################### - sub PTN_through{ - my $self = shift; - my $in = shift; - - $in =~ /(.*)/; - return ($1); - } - - ###################################################################### - sub PTN_visitor_type{ - my $self = shift; - my $in = shift; - - $in =~ /([A-Za-z0-9]*)/; - return ($1); - } - - ###################################################################### - sub PTN_email{ - my $self = shift; - my $in = shift; - - $in =~ /([A-Za-z0-9\.\+\_\-\@]*)/; - return ($1); - } - - ###################################################################### - sub PTN_password{ - my $self = shift; - my $in = shift; - - return ($in); - } - - ###################################################################### - sub PTN_num{ - my $self = shift; - my $in = shift; - - $in =~ /(\d+)/; - return ($1); - } - - - ###################################################################### - sub PTN_nickname{ - my $self = shift; - my $in = shift; - - $in =~ /([A-Za-z0-9\-\_]*)/; - return ($1); - } - - ###################################################################### - sub PTN_word{ - my $self = shift; - my $in = shift; - - $in =~ /([A-Za-z0-9\-\_\.]*)/; - return ($1); - } - - ###################################################################### - sub PTN_mode{ - my $self = shift; - my $in = shift; - - $in =~ /([A-Za-z0-9\-\_]*)/; - return ($1); - } - - ###################################################################### - sub PTN_getcontent_content{ - my $self = shift; - my $in = shift; - - $in =~ /([A-Za-z0-9\-\_\.\/]*)/; - return ($1); - } - - ###################################################################### - sub PTN_basefilename{ - my $self = shift; - my $in = shift; - $in =~ /([A-Za-z0-9\-\_]+\.[A-Za-z0-9]+)/; -# debug_print("==============$1"); - return ($1); - } - - ###################################################################### - sub PTN_jpg_filename{ - my $self = shift; - my $in = shift; - $in =~ /([A-Za-z0-9\-\_]*\.(jpg)|(JPG)|(JPEG)|(jpeg))/; -# debug_print("==============$1"); - return ($1); - } - - ###################################################################### - sub PTN_dirname{ - my $self = shift; - my $in = shift; - $in =~ /([A-Za-z0-9\-\_\.\/\s]*)/; -# debug_print("==============$1"); - return ($1); - } - - - - ###################################################################### - sub PTN{ - my $in = shift; - - if($in ne ""){ - if ($in =~ /([\w\-\_]+)/){ - return($1); - }else{ - throw Affelio::exception::TaintedInputException("Tainted input!"); - } - } - } - - ###################################################################### - sub PTN_URL{ - my $self = shift; - my $in = shift; - - my @http = $in =~ /s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+/g;#' - return($http[0]); - } - - ###################################################################### - sub translate_URL_to_HTML{ - my $self = shift; - my $in = shift; - - $in =~ s/(s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/<A HREF="$1">$1<\/A>/g;#' - return($in); - } - - - ###################################################################### - sub distill_URL{ - my $text = shift; - if($text =~ /(s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+)/){ #' - return($1); - }else{ - return(""); - } - - } - - ###################################################################### - sub escape_HTML{ - - } - - ###################################################################### - sub escape_filename { - my $forbedden = '\\\/\*\?\|"<>:,;% '; - my ($filename) = @_; - $filename =~ s/([$forbedden])/'%' . unpack('H2', $1)/eg; - return $filename; - } - - ###################################################################### - sub delete_HTML{ - my $str = shift; - my $text_regex = q{[^<]*}; - my $tag_regex = ""; - my $tag_regex_ = ""; - my $text_tmp=""; - - my $result = ''; - while ($str =~ /($text_regex)($tag_regex)?/gso) { - last if $1 eq '' and $2 eq ''; - $result .= $1; - my $tag_tmp = $2; - - if ($tag_tmp =~ /^<(XMP|PLAINTEXT|SCRIPT)(?![0-9A-Za-z])/i) { - $str =~ /(.*?)(?:<\/$1(?![0-9A-Za-z])$tag_regex_|$)/gsi; - ($text_tmp = $1) =~ s/</&lt;/g; - $text_tmp =~ s/>/&gt;/g; - $result .= $text_tmp; - } - } - - return($result); - } -} -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:55 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:55 +0900 Subject: [Affelio-cvs 687] CVS update: affelio_farm/admin/skelton/affelio/lib/Affelio/SNS Message-ID: <20051024192055.0DCB32AC030@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/FriendManager.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/FriendManager.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/FriendManager.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/FriendManager.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/FriendManager.pm Tue Oct 25 04:20:54 2005 @@ -1,777 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: FriendManager.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::SNS::FriendManager; -{ - use strict; - - use lib("../../../extlib"); - use DBI; - use lib("../../"); - use Affelio; - use Affelio::misc::CGIError; - use Affelio::misc::Debug qw(debug_print); - use Affelio::misc::Time; - use Affelio::misc::DBroutines qw(db_value_replace); - use Affelio::exception::DBException; - - ######################################################################## - #Constructor - ######################################################################## - sub new{ - my $class = shift; - my $af = shift; - - debug_print("FriendManager::new: start."); - - my $self = {af => $af - }; - - bless $self, $class; - - debug_print("FriendManager::new: end."); - return $self; - } - - ######################################################################## - #get_F1_count - ######################################################################## - sub get_F1_count{ - my $self = shift; - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $query = 'SELECT count(*) FROM AFuser_CORE_friends'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - return($row[0]); - } - - ######################################################################## - #get_F2_count - ######################################################################## - sub get_F2_count{ - my $self = shift; - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $query = 'SELECT count(*) FROM AFuser_CORE_friendsfriends'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - return($row[0]); - } - - - ######################################################################## - #add_friend - ######################################################################## - sub add_friend{ #returns uid (int) - my $self = shift; - my $af_id = shift; #arg(1) af_id (string) - my $nickname = shift; #arg(2) nickname (string) - my $timestamp = shift; #arg(3) timestamp (int) - my $password = shift; #arg(4) password (string) - - Affelio::misc::Debug::debug_print("FM::add_friend: ($af_id $nickname $timestamp $password)"); - - my $af = $self->{af}; - my $sth; - my $query; - my @row; - my $maxid; - my $newid; - my $old_uid_in_f2tbl=""; - my $old_f1list_in_f2tbl=","; - - ############################## - #Is ($af_id) already in my F1 table? - #If so, we DO NOT ignore him. - #We have to update his information. - # - $query = "SELECT * FROM AFuser_CORE_friends WHERE af_id = '$af_id'"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - @row = $sth->fetchrow_array; - if(@row && @row!=() ){ - - Affelio::misc::Debug::debug_print("FM::add_friend: Already my friend!"); - - $query = "update AFuser_CORE_friends set timestamp = '$timestamp', password = '$password' where af_id = '$af_id'"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - Affelio::misc::Debug::debug_print("FM::add_friend:\tUpdated an existing friend."); - Affelio::misc::Debug::debug_print("FM::add_friend: end($row[0])."); - ################ - #Return - return $row[0]; #return uid. - } - - ############################## - #Get existing max ID - $query = 'SELECT max(uid) FROM AFuser_CORE_friends'; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - @row = $sth->fetchrow_array; - $maxid = $row[0]; - if(defined($row[0])){ - $maxid = $row[0]; - }else{ - $maxid = 0; - } - $newid = $maxid + 1; - Affelio::misc::Debug::debug_print("FM::add_friend: new_ID= [$newid]"); - - ############################## - #Is $af_id already in F2 table? - #If so, we have to move it from F2 table to F1 table. - $query = "SELECT * FROM AFuser_CORE_friendsfriends WHERE af_id = '$af_id'"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - @row = $sth->fetchrow_array; - if(@row && @row !=() ){ - ############################################ - #I found the record in F2 table. - #Let's move it to the F1 table. - Affelio::misnc::Debug::debug_print("FM::add_friend:\t [@row]"); - Affelio::misc::Debug::debug_print("FM::add_friend:\tHe is my friends' friend."); - Affelio::misc::Debug::debug_print("FM::add_friend:\tLet's move him."); - - #Backup data - $old_uid_in_f2tbl = $row[0]; - $old_f1list_in_f2tbl = $row[4]; - - #Delete the record in the F2 table. - $query = "DELETE FROM AFuser_CORE_friendsfriends WHERE uid = $old_uid_in_f2tbl"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - Affelio::misc::Debug::debug_print("FM::add_friend:\tRecord($old_uid_in_f2tbl) in F2 tbl deleted."); - - #Update all other F1 and F2 entries' "flist" column - # from $old_uid_in_f2tbl to $newid - # update sample set data=translate(data,'b','z') - db_value_replace($af->{db}, - "AFuser_CORE_friendsfriends", - "uid", - "f1list", - ",$old_uid_in_f2tbl," , - ",$newid," , - ); - - db_value_replace($af->{db}, - "AFuser_CORE_friends", - "uid", - "f2list", - ",$old_uid_in_f2tbl," , - ",$newid," , - ); - - Affelio::misc::Debug::debug_print("FM::add_friend:\tOverwritten id($old_uid_in_f2tbl) -> id($newid)"); - } - - - ############################## - #Insert a new record into my F1 list. - $query = "insert into AFuser_CORE_friends(uid, af_id, nickname, timestamp, password, intro, option_pid,lastupdated,f2list) values ($newid, '$af_id', '$nickname', $timestamp, '$password', ' ', -1, 0, '$old_f1list_in_f2tbl')"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - Affelio::misc::Debug::debug_print("FM::add_friend:\tInserted a new record."); - Affelio::misc::Debug::debug_print("FM::add_friend: end($newid)."); - return($newid); - } - - - ######################################################################## - #remove_friend - ######################################################################## - sub remove_friend{ #void - my $self = shift; - my $uid = shift; #arg(1) uid (int) - my $af = $self->{af}; - - Affelio::misc::Debug::debug_print("FM::remove_friend:start."); - - #Remove entry(uid) from AFuser_CORE_friends - my $q1 = "DELETE FROM AFuser_CORE_friends WHERE uid = $uid"; - my $s1; - eval{ - $s1 = $af->{db}->prepare($q1); - $s1->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - undef($q1); - undef($s1); - Affelio::misc::Debug::debug_print("FM::remove_friend:\t removed entry($uid) from F1 DB"); - - #Remove uid from friends of others in AFuser_CORE_friends - db_value_replace($af->{db}, - "AFuser_CORE_friends", - "uid", - "f2list", - ",$uid," , - ",," , - ); - Affelio::misc::Debug::debug_print("FM::remove_friend:\t removed entry($uid) from other's F2list in F1 DB"); - - #Remove uid from friends of others in AFuser_CORE_friendsfriends - db_value_replace($af->{db}, - "AFuser_CORE_friendsfriends", - "uid", - "f1list", - ",$uid," , - ",," , - ); - Affelio::misc::Debug::debug_print("FM::remove_friend:\t removed entry($uid) from other's F1list in F2 DB"); - } - - - ######################################################################## - #save_F2List - ######################################################################## - # We retrieve "friend list" from my friends. - # That "friend list" is my "F2 list" (through the friend). - # Then, save_F2list is invoked when the retrieved F2 list gets stored. - sub save_F2List{ - my $self = shift; - my $datain = shift; #arg(1) data input - my $f1_af_id = shift; #arg(2) f1_af_id - my $af = $self->{af}; - - Affelio::misc::Debug::debug_print("FM::save_F2List: start."); - - # Data format: - # - # [ADD|DEL] $timestamp $af_id\n - # - my @datalist = split("\n", $datain); - - my $latest_timestamp =0; - - #While (each line) - foreach my $thisdata (@datalist){ - my ($timestamp, $method, $f2_af_id, $nickname) - = split(" ", $thisdata); - - #If the AF_ID is mine, ignore it. - if($f2_af_id eq $af->{site__web_root}){ - next; - } - - if($timestamp > $latest_timestamp){ - $latest_timestamp = $timestamp; - } - - Affelio::misc::Debug::debug_print("FM::save_F2List: [$method][$f2_af_id]"); - - if($method eq "ADD"){ - ####################### - #ADD - ####################### - my $sth; - my $query; - my @row_in_f1table; - my @row_in_f2table; - - my @row; - my $f1_uid =""; - my $f1_f2list=""; - - my $f2_uid =""; - my $f2_f1list=""; - - my $new_f1_f2list=""; - my $new_f2_f1list=""; - - #Get F1's info - $f1_uid = Affelio::SNS::FriendManager::get_attribute_by_afid($self, $f1_af_id, "uid"); - $f1_f2list = Affelio::SNS::FriendManager::get_attribute_by_afid($self, $f1_af_id, "f2list"); - Affelio::misc::Debug::debug_print("FM::save_F2list: F1's F2list = [$f1_f2list]"); - - #The guy with F2_AF_ID is in the Friend table? - $query = "SELECT * FROM AFuser_CORE_friends WHERE af_id = '$f2_af_id'"; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - @row_in_f1table = $sth->fetchrow_array; - undef($sth); - undef($query); - - if(@row_in_f1table && @row_in_f1table !=()){ - ############################################### - #This $f2_af_id has been FOUND in our Friend DB. - ############################################### - Affelio::misc::Debug::debug_print("FM::save_F2List: \tF2 person is found in our F1 table"); - my $query2=""; - my $sth2=""; - - $f2_uid = $row_in_f1table[0]; - $f2_f1list = $row_in_f1table[8]; - Affelio::misc::Debug::debug_print("FM::save_F2list: F2's F1list = [$f2_f1list]"); - - #Modify "Friend" table - #Add $f2_uid into $f1_af_id's F2list - $new_f1_f2list = $f1_f2list . $f2_uid . ","; - Affelio::misc::Debug::debug_print("FM::save_F2List: \tnew_f1_f2list=[$new_f1_f2list]"); - $query2 = "update AFuser_CORE_friends set f2list = '$new_f1_f2list' where uid = '$f1_uid'"; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - Affelio::misc::Debug::debug_print("FM::save_F2list: New F1($f1_uid)'s F2list = [$new_f1_f2list]"); - - #Modify "Friend" table - #Add $f1_af_id into $f2_uid's F1list - $new_f2_f1list = $f2_f1list . $f1_uid . ","; - Affelio::misc::Debug::debug_print("FM::save_F2List: \tnew_f2_f1list=[$new_f2_f1list]"); - $query2 = "update AFuser_CORE_friends set f2list = '$new_f2_f1list' where uid = $f2_uid"; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - Affelio::misc::Debug::debug_print("FM::save_F2list: New F2($f2_uid)'s F1list = [$new_f2_f1list]"); - - }else{ - my $query2=""; - my $sth2=""; - - #The guy with F2_AF_ID is in the FriendsFriends table? - $query2 = "SELECT * FROM AFuser_CORE_friendsfriends WHERE af_id = '$f2_af_id'"; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - @row_in_f2table = $sth2->fetchrow_array; - - if(!@row_in_f2table || @row_in_f2table==()){ - ############################################### - #This $f2_af_id has NOT been FOUND anywhere - ############################################### - Affelio::misc::Debug::debug_print("FM::save_F2List:\t F2 person is NOT Found anywhere. Brand new!"); - my $query3=""; - my $sth3=""; - - ############################## - #Get existing min ID - $query3 = 'SELECT min(uid) FROM AFuser_CORE_friendsfriends'; - eval{ - $sth3 = $af->{db}->prepare($query3); - $sth3->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - @row = $sth3->fetchrow_array; - my $minid = $row[0]; - if(defined($row[0])){ - $minid = $row[0]; - }else{ - $minid = -1; - } - - ############################## - #Insert a new record - my $tmpnewid = $minid-1; - $query3 = "insert into AFuser_CORE_friendsfriends (uid, af_id, nickname, timestamp, f1list) values ('$tmpnewid', '$f2_af_id', '$nickname', $timestamp, ',')"; - eval{ - $sth3 = $af->{db}->prepare($query3); - $sth3->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - $f2_uid = $minid - 1; #F2 UID is negative! - $f2_f1list = ","; - Affelio::misc::Debug::debug_print("FM::save_F2List:\tCreated F2 entry id=$f2_uid"); - }else{ - ############################################### - #This $f2_af_id has been FOUND in FriendsFriends DB. - ############################################### - $f2_uid = $row_in_f2table[0]; - $f2_f1list = $row_in_f2table[4]; - Affelio::misc::Debug::debug_print("FM::save_F2List:\t F2 person is FOUND in our F2 table."); - Affelio::misc::Debug::debug_print("FM::save_F2List:\t F2uid = [$f2_uid]"); - Affelio::misc::Debug::debug_print("FM::save_F2List:\t F1List = [$f2_f1list]"); - } - - #Modify "Friend" table - #Add $f2_uid into $f1_af_id's F2list - $new_f1_f2list = $f1_f2list . $f2_uid . ","; - Affelio::misc::Debug::debug_print("FM::save_F2List:\tnew_f1_f2list=[$new_f1_f2list]"); - $query2 = "update AFuser_CORE_friends set f2list = '$new_f1_f2list' where uid = $f1_uid"; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - #Modify "FriendsFriends" table - #Add $f1_af_id into $f2_uid's F1list - $new_f2_f1list = $f2_f1list . $f1_uid . ","; - Affelio::misc::Debug::debug_print("FM::save_F2List:\tnew_f2_f1list=[$new_f2_f1list]"); - $query2 = "update AFuser_CORE_friendsfriends set f1list = '$new_f2_f1list' where uid = $f2_uid"; - eval{ - $sth2 = $af->{db}->prepare($query2); - $sth2->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - }#if - Affelio::misc::Debug::debug_print("FM::save_F2List: [$method] DONE."); - - }elsif($method eq "DEL"){ - ####################### - #DEL - ####################### - #XXX Not implemented - - }elsif($method eq "MOV"){ - ####################### - #MOV - ####################### - #XXX Not implemented - - }#if(method) - - }#foreach - - Affelio::misc::Debug::debug_print("FM::save_F2List: Latest timestamp=[$latest_timestamp]"); - #Updating "lastupdated" attribute of this friend... - my $f1_uid = get_attribute_by_afid($self, $f1_af_id, "uid"); - - set_attribute_by_id($self, $f1_uid, "lastupdated", $latest_timestamp); - } - - - ######################################################################## - #get_updated_friends - ######################################################################## - sub get_updated_friends{ #return string result - my $self = shift; - my $req_timestamp = shift; #arg(1) timestamp - my $af = $self->{af}; - - ############################## - #retrieve a friend record from DB - my $query = "SELECT af_id, timestamp, nickname FROM AFuser_CORE_friends WHERE timestamp > " . $req_timestamp; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my $retmsg=""; - my @row=(); - my $af_id=""; - my $timestamp=""; - my $nickname=""; - while( ($af_id, $timestamp, $nickname) = $sth->fetchrow_array){ - $retmsg .= "$timestamp ADD $af_id $nickname\n"; - } - - ############################## - #retrieve erased friend record from DB - #XXX Not implemented - - ############################## - #Sort by time - #XXX Not implemented - - debug_print("FM::get_updated_friends: ret=[$retmsg]"); - return($retmsg); - } - - - ######################################################################## - #get_all_friend_list - ######################################################################## - sub get_all_friend_list{ #return SQL_result - my $self = shift; - my $af = $self->{af}; - - ############################## - #retrieve all friend records from DB - my $query = 'SELECT * FROM AFuser_CORE_friends order by uid desc'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - return($sth); - } - - - ######################################################################## - #get_friend_by_uid - # arg(1) uid - # returns array(0uid, 1af_id, 2nickname, 3timestamp, - # 4password, 5intro, 6option_pid) - ######################################################################## - sub get_friend_by_uid{ #return an SQL array - my $self = shift; - my $uid = shift; #arg(1) uid (int) - - my $af = $self->{af}; - - ############################## - #retrieve a friend record from DB - my $query = "SELECT * FROM AFuser_CORE_friends WHERE uid = $uid"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - my @row = $sth->fetchrow_array; - if(@row==()) {undef @row}; - return(@row); - } - - - ######################################################################## - #get_friend_by_afid - # arg(1) afid - # returns array(0uid, 1af_id, 2nickname, 3timestamp, - # 4password, 5intro, 6option_pid - ######################################################################## - sub get_friend_by_afid{ #return an SQL array - my $self = shift; - my $af_id = shift; #arg(1) afid (string) - - my $af = $self->{af}; - - ############################## - #retrieve a friend record from DB - my $query = "SELECT * FROM AFuser_CORE_friends WHERE af_id = '$af_id'"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - if(@row==()) {undef @row}; - return(@row); - } - - - ######################################################################## - #get_attribute_by_uid - ######################################################################## - sub get_attribute_by_uid{ #return a value - my $self = shift; - my $uid = shift; #arg(1) uid (int) - my $attr = shift; #arg(2) attr (string) - - my $af = $self->{af}; - - ############################## - #retrieve a friend record from DB - Affelio::misc::Debug::debug_print("FM::get_attr_by_uid(uid=$uid, attr=$attr)"); - my $query = "SELECT $attr FROM AFuser_CORE_friends WHERE uid = '$uid'"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - return($row[0]); - } - - - ######################################################################## - #F2_get_attribute_by_uid - ######################################################################## - sub F2_get_attribute_by_uid{ #return a value - my $self = shift; - my $uid = shift; #arg(1) uid (int) - my $attr = shift; #arg(2) attr (string) - - my $af = $self->{af}; - - ############################## - #retrieve a friend record from DB - my $query = "SELECT $attr FROM AFuser_CORE_friendsfriends WHERE uid = $uid"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute(); - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - my @row = $sth->fetchrow_array; - return($row[0]); - } - - ######################################################################## - #get_attribute_by_afid - ######################################################################## - sub get_attribute_by_afid{ #return a value - my $self = shift; - my $af_id = shift; #arg(1) afid (string) - my $attr = shift; #arg(2) attr (string) - - my $af = $self->{af}; - $af_id = $af->{db}->quote($af_id); - - ############################## - #retrieve a friend record from DB - my $query = "SELECT $attr FROM AFuser_CORE_friends WHERE af_id = $af_id"; - - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - my @row = $sth->fetchrow_array; - my $size = @row; - return($row[0]); - } - - ######################################################################## - #set_attribute_by_id - ######################################################################## - sub set_attribute_by_id{ #void - my $self = shift; - my $uid = shift; #arg(1) uid (string) - my $attr = shift; #arg(2) attr (string) - my $value = shift; #arg(3) value (string) - - my $af = $self->{af}; - if(($attr eq "password") - || ($attr eq "af_id") - || ($attr eq "nickname") - || ($attr eq "intro") ){ - $value = $af->{db}->quote($value); - } - - ############################## - #set value into DB - my $query = "update AFuser_CORE_friends set $attr = $value where uid = $uid"; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); - } - - } - - - - ######################################################################## - -}#package -1; - Index: affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_c.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_c.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_c.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_c.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_c.pm Tue Oct 25 04:20:54 2005 @@ -1,285 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Handshaker_c.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Affelio::SNS::Handshaker_c; -{ - #use strict; - use lib("../../../extlib/"); - use XMLRPC::Lite; - use Error qw(:try); - use Crypt::DH; - use MIME::Base64::Perl; - - use lib("../../../lib/"); - use Affelio::misc::CGIError; - use Affelio::misc::Debug; - use Affelio::misc::MyCrypt; - use Affelio::misc::Time; - use Affelio::exception::Exception; - use Affelio::exception::InvalidInputException; - use Affelio::exception::IOException; - use Affelio::exception::NetworkException; - - use Exporter; - @ISA = "Exporter"; - @EXPORT = qw (send_HandShake reply_HandShake get_F2List post_Message); - - ################################################################# - # post_Message - # proto_ver: 1 - ################################################################# - sub post_Message{ - my %arg = @_; - #arg (part 1) - my $proto_ver = 1.0; - my $dest_uri = $arg{dest_uri}; - my $src = $arg{src}; - my $password = $arg{password}; - - #arg (part 2) - my $msg_from = $arg{msg_from}; - my $msg_from_nickname = $arg{msg_from_nickname}; - my $msg_to = $arg{msg_to}; - my $msg_timestamp = $arg{msg_timestamp}; - my $MIMed_msg_title = encode_base64($arg{msg_title}); - my $MIMed_msg_body = encode_base64($arg{msg_body}); - - debug_print("C::post_Message: dest=[$dest_uri]"); - debug_print("C::post_Message: $msg_from, $msg_from_nickname, $msg_to, $msg_timestamp, [$MIMed_msg_title], [$MIMed_msg_body]"); - - ############################ - #Generate XML - ############################ - my $XMLbody = <<EOT; -<message> -<header> -<from>$msg_from</from> -<from_nickname>$msg_from_nickname</from_nickname> -<to>$src</to> -<timestamp>$msg_timestamp</timestamp> -<title>$MIMed_msg_title - - -$MIMed_msg_body - - -$src -EOT - ############################ - #Encryption - ############################ - my $encrypted = msg_encrypt($XMLbody, $password); - - ############################ - #MIME encode - ############################ - my $MIMed = encode_base64($encrypted); - debug_print("C::post_Message: [$MIMed]"); - - ############################ - #Send to the destination through XMLRPC - ############################ - my $result = eval { - XMLRPC::Lite - ->proxy($dest_uri) #XML - ->call( - 'affelio.post_Message', - $proto_ver, - get_timestamp(), - $src, - $MIMed - ) - ->result; - }; - debug_print("C::post_Message: RPC returned.\n"); - if ($@) { - throw Affelio::exception::NetworkException($@); - } - if($result->{flerror} ne "0"){ - throw Affelio::exception::NetworkException("XML-RPC Error: " . $result->{message}); - } - - debug_print("post_Message: OK : $result->{message}\n"); - debug_print("post_Message: OK : [$result->{flerror}]\n"); - return $result; - } - - - ################################################################# - # get_F2List(dest_uri, timestamp) - # proto_ver: 1 - ################################################################# - sub get_F2List { - my %arg = @_; - my $proto_ver = 1.0; - my $dest_uri = $arg{dest_uri}; - my $timestamp = $arg{timestamp}; - - debug_print("get_F2List: $dest_uri $proto_ver $timestamp"); - - if ($dest_uri !~ /^http/) { - throw Affelio::exception::InvalidInputException("dest_url"); - } - - my $result = eval { - XMLRPC::Lite - ->proxy($dest_uri) - ->call( - 'affelio.F2List', - $proto_ver, - $timestamp, - ) - ->result; - }; - debug_print("C::get_F2List: RPC returned.\n"); - if ($@) { - throw Affelio::exception::NetworkException($@); - } - if($result->{flerror} ne "0"){ - throw Affelio::exception::NetworkException($result->{message}); - } - - debug_print("get_F2List: OK : $result->{message}\n"); - debug_print("get_F2List: OK : [$result->{flerror}]\n"); - return $result; - } - - - ################################################################# - # send_HandShake(dest_url => $dest_uri, - # timestamp => $timestamp, - # my_nickname => my_nickname, - # my_AFID => my_AFID, - # DH_pub_key_str => DH_pub_key_str, - # mesg => mesg); - # proto_ver: 1.1 - ################################################################# - sub send_HandShake { - my %arg = @_; - my $dest_uri = $arg{dest_uri}; - # - my $proto_ver = 1.1; - my $timestamp = $arg{timestamp}; - # - my $my_nickname = $arg{my_nickname}; - my $my_AFID = $arg{my_AFID}; - my $my_DH_pub_key_str = $arg{DH_pub_key_str}; - my $my_mesg = $arg{mesg}; - my $MIMed_mesg = encode_base64($my_mesg); - - debug_print("send_HandShake: size=[" . length($my_mesg)); - debug_print("send_HandShake: size=[" . length($MIMed_mesg)); - debug_print("send_HandShake: [$dest_uri $proto_ver $timestamp $my_domain $my_nickname $my_AFID $my_DH_pub_key_str $my_mesg]"); - - ################################# - #Arg check - ################################# - if ($dest_uri !~ /^http/) { - throw Affelio::exception::InvalidInputException("dest_url"); - } - - ################################# - #Execute XMLRPC - ################################# - my $result = eval { - XMLRPC::Lite - ->proxy($dest_uri) - ->call( - 'affelio.HandShake', - $proto_ver, - $timestamp, - $my_nickname, - $my_AFID, - $my_DH_pub_key_str, - $MIMed_mesg) - ->result; - }; - debug_print("send_HandShake: RPC returned.\n"); - if ($@) { - throw Affelio::exception::NetworkException($@); - } - if($result->{flerror} ne "0"){ - throw Affelio::exception::NetworkException($result->{message}); - } - - debug_print("send_HandShake: OK : $result->{message}\n"); - debug_print("send_HandShake: OK : $result->{flerror}\n"); - return $result; - } - - ################################################################# - # reply_HandShake(dest_url => $dest_uri, - # timestamp => $timestamp, - # my_nickname => my_nickname, - # my_AFID => my_AFID, - # DH_pub_key_str => DH_pub_key_str, - # my_mesg => mesg); - # proto_ver: 1.1 - ################################################################# - sub reply_HandShake { - my %arg = @_; - # - my $proto_ver = 1.1; - my $dest_uri = $arg{dest_uri}; - my $timestamp = $arg{timestamp}; - # - my $my_nickname = $arg{my_nickname}; - my $my_AFID = $arg{my_AFID}; - my $my_DH_pub_key_str = $arg{DH_pub_key_str}; - my $my_mesg = $arg{mesg}; - - debug_print("reply_HandShake: [$dest_uri $proto_ver $timestamp $my_domain $my_nickname $my_AFID $my_DH_pub_key_str $my_mesg]"); - - ################################# - #Arg check - ################################# - if ($dest_uri !~ /^http/) { - throw Affelio::exception::InvalidInputException("dest_url"); - } - - ################################# - #Execute XMLRPC - ################################# - my $result = eval { - XMLRPC::Lite - ->proxy($dest_uri) - ->call( - 'affelio.HandShakeReply', - $proto_ver, - $timestamp, - $my_nickname, - $my_AFID, - $my_DH_pub_key_str, - $my_mesg - ) - ->result; - }; - debug_print("reply_HandShake: RPC returned.\n"); - if ($@) { - throw Affelio::exception::NetworkException($@); - } - if($result->{flerror} ne "0"){ - throw Affelio::exception::NetworkException($result->{message}); - } - - debug_print("reply_HandShake: $result->{message}\n"); - debug_print("reply_HandShake: $result->{flerror}\n"); - return $result; - } -} -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_s.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_s.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_s.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_s.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_s.pm Tue Oct 25 04:20:55 2005 @@ -1,451 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Handshaker_s.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use lib("../../../extlib/"); -use XMLRPC::Transport::HTTP; -use DBI; -use Crypt::RC5; -use Crypt::DH; -use MIME::Base64::Perl; -use Error qw(:try); -use lib("../../"); -use Affelio; -use Affelio::SNS::FriendManager; -use Affelio::SNS::Handshaker_tmpDB; -use Affelio::SNS::Handshaker_c qw(get_F2List); -use Affelio::Managing::MessageManager; -use Affelio::misc::CGIError; -use Affelio::misc::Debug; -use Affelio::misc::MyCrypt; -use Affelio::misc::NetMisc; -use Affelio::misc::Time; -use Affelio::misc::Sanitizer; - -######################################################################## -package Affelio::SNS::Handshaker_s::Util; -{ - sub af_new { - my $cfg_dir = $Affelio::SNS::Handshaker_s::AF_DIR . "config/"; - Affelio::misc::Debug::debug_print("Starting AF($cfg_dir)..."); - my $af = Affelio->new( ConfigDir => $cfg_dir ) - or die "Cannot start Affelio"; - return($af); - } -} - -######################################################################## -package Affelio::SNS::Handshaker_s; -{ - use strict; - use Exporter; - @Affelio::SNS::Handshaker_s::ISA = "Exporter"; - @Affelio::SNS::Handshaker_s::EXPORT = qw (HandShake HandShakeReply F2List post_Message get_services); - - use vars qw( $AF_DIR); - - ################################################################## - #server.get_services - # proto_ver: 1 - ################################################################## - sub get_services{ - my $self = shift; - my ($proto_ver) = @_; - - if($proto_ver > 1.0){ - return { - flerror => XMLRPC::Data->type('boolean', 1), - message => "ERR:102 UnsupportedProtoVer 1.0" - }; - } - - my $msg= < - - -1.1 - - -1.0 - - -1.0 - - -EOT - return { - flerror => XMLRPC::Data->type('boolean', 0), - message => $msg - }; - } - - ################################################################## - #server.F2List - # proto_ver: 1 - ################################################################## - sub F2List { - my $self = shift; - my ($proto_ver, $req_timestamp) = @_; - - my $af = Affelio::SNS::Handshaker_s::Util::af_new(); - - $req_timestamp - = Affelio::misc::Sanitizer::sanitize_number($req_timestamp); - - Affelio::misc::Debug::debug_print("server.F2List: proto_ver=$proto_ver, timestamp=$req_timestamp"); - - ################################## - #Retrieve friends whose - # timestamp > req_timestamp - #Retrieve erased friends whose - # timestamp > req_timestamp - my $retmsg = $af->{fm}->get_updated_friends($req_timestamp); - - Affelio::misc::Debug::debug_print("server.F2List: ret=[$retmsg]"); - Affelio::misc::Debug::debug_print("server.F2List: end."); - - return { - flerror => XMLRPC::Data->type('boolean', 0), - message => $retmsg - }; - } - - ################################################################## - #server.post_Message - # proto_ver:1 - ################################################################## - sub post_Message { - my $self = shift; - my $af = Affelio::SNS::Handshaker_s::Util::af_new(); - - Affelio::misc::Debug::debug_print("server.postMesg: starg."); - - ################################################## - #Distill args - ################################################## - my ($proto_ver, - $timestamp, - $peer_afid, - $MIMed_mesg) = @_; - - my $passAB = $af->{fm}->get_attribute_by_afid($peer_afid, "password"); - if(!defined($passAB) || $passAB eq ""){ - return { - flerror => XMLRPC::Data->type('boolean', 1), - message => "ERR:100 Youre not my friend." - }; - } - - ################################################## - #Decode MIME - ################################################## - my $encrypted = MIME::Base64::Perl::decode_base64($MIMed_mesg); - - ################################################## - #Decrypt - ################################################## - my $rc5 = Crypt::RC5->new($passAB, 12 ); - my $plain = $rc5->decrypt($encrypted); - - ################################################## - #Parse XML - ################################################## - my $src; - if($plain =~ /(.+)<\/src>/){ - $src = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: src: $src"); - - my $msg_from; - if($plain =~ /(.+)<\/from>/){ - $msg_from = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: from: $msg_from"); - - my $msg_from_nickname; - if($plain =~ /(.+)<\/from_nickname>/){ - $msg_from_nickname = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: nick: $msg_from_nickname"); - - my $msg_to; - if($plain =~ /(.+)<\/to>/){ - $msg_to = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: to: $msg_to"); - - my $msg_timestamp; - if($plain =~ /(.+)<\/timestamp>/){ - $msg_timestamp = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: TIME: $msg_timestamp"); - - my $msg_MIMed_title; - if($plain =~ /(.*)<\/title>/ms){ - $msg_MIMed_title = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: title: $msg_MIMed_title"); - - my $msg_MIMed_body; - if($plain =~ /<text>(.*)<\/text>/ms){ - $msg_MIMed_body = $1; - } - Affelio::misc::Debug::debug_print("server.postMesg: body: $msg_MIMed_body"); - - ################################################## - #Encryption integrity check - ################################################## - if($src ne $peer_afid){ - return { - flerror => XMLRPC::Data->type('boolean', 1), - message => "ERR:101 Invalid Encryption." - }; - } - - ################################################## - #MIM decode for title and body - ################################################## - my $msg_title = MIME::Base64::Perl::decode_base64($msg_MIMed_title); - my $msg_body = MIME::Base64::Perl::decode_base64($msg_MIMed_body); - - ########################################### - # Post this message to Message Manager - ########################################### - Affelio::misc::Debug::debug_print("server.PostMesg: $proto_ver, $msg_from $msg_from_nickname $msg_to $msg_timestamp $msg_title $msg_body"); - - $msg_from = '<A HREF="' . $msg_from . '">' . $msg_from_nickname . '</A>'; - - $af->{mesgm}->post_message($msg_from, - $msg_title, - "UserToUser/OneToOne", - $msg_body); - undef($af); - - ########################################### - # Reply to client - ########################################### - my $msg = "OK: Thanks for your message."; - return { - flerror => XMLRPC::Data->type('boolean', 0), - message => $msg - }; - } - - - ################################################################## - #server.HandShake - # proto_ver:1.1 - # Accept HandShake from a client - ################################################################## - sub HandShake { - my $self = shift; - - ################################################## - #Distill args - ################################################## - my ($proto_ver, $timestamp, $peer_nickname, - $peer_af_id, $peer_DH_pub_key_str, $MIMed_mesg) = @_; - my $peer_domain = Affelio::misc::NetMisc::get_remote_domain(%ENV); - my $sessionid = "$$" . "$timestamp"; - Affelio::misc::Debug::debug_print("server.HandShake: size=[" - . length($MIMed_mesg)); - - Affelio::misc::Debug::debug_print("server.HandShake: $proto_ver, $timestamp, $peer_domain, $peer_nickname, $peer_af_id, $peer_DH_pub_key_str [$MIMed_mesg]\n"); - ################################################## - #Version check - ################################################## - if($proto_ver > 1.1){ - return { - flerror => XMLRPC::Data->type('boolean', 1), - message => "ERR:102 UnsupportedProtoVer 1.1" - }; - } - - ########################################### - # Instantiate Affelio - ########################################### - my $af = Affelio::SNS::Handshaker_s::Util::af_new(); - - ########################################### - # Send a message to MessageManager - ########################################### - my $message_body= - MIME::Base64::Perl::encode_base64("You got a link request from $peer_nickname ( $peer_af_id ). \n\nMessage from the user is...\n") - . "$MIMed_mesg\n" - . MIME::Base64::Perl::encode_base64("\n\nClick following link to approve this request.\n\n$af->{site__web_root}/bin/recv_mail_ack.cgi?id=$sessionid"); - - $af->{mesgm}->post_message("Your Affelio", - "Link Request from $peer_nickname", - "SystemToUser/LinkRequest/Encode-Base64", - $message_body); - - ########################################### - # Save peer's info into "received_Handshake" DB - ########################################### - my $tmpdb= new Affelio::SNS::Handshaker_tmpDB($af); - $tmpdb->add_received_Handshake($sessionid, - $peer_af_id, - $peer_nickname, - $timestamp, - $peer_DH_pub_key_str); - - Affelio::misc::Debug::debug_print("server.HandShake: DB(W) $sessionid\n"); - - undef($af); - ########################################### - # Reply to client - ########################################### - my $msg = "OK: Thanks for your HandShake."; - return { - flerror => XMLRPC::Data->type('boolean', 0), - message => $msg - }; - - }#method - - - ################################################################## - #server.HandShakeReply - # proto_ver:1.1 - # Accept HandshakeReply from a client - ################################################################## - sub HandShakeReply { - my $self = shift; - - ########################################### - #Distill args - ########################################### - my ($proto_ver, $timestamp, $peer_nickname, - $peer_af_id, $peer_DH_pub_key_str, $mesg) = @_; - Affelio::misc::Debug::debug_print("server.HandShakeReply: $proto_ver, $timestamp, $peer_nickname, $peer_af_id, $peer_DH_pub_key_str $mesg\n"); - - ################################################## - #Version check - ################################################## - if($proto_ver > 1.1){ - return { - flerror => XMLRPC::Data->type('boolean', 1), - message => "ERR:102 UnsupportedProtoVer 1.1" - }; - } - - ########################################### - # Instantiate Affelio - ########################################### - my $af = Affelio::SNS::Handshaker_s::Util::af_new(); - - ########################################### - # check peer's info in "received_Handshake" DB - ########################################### - Affelio::misc::Debug::debug_print("server.HandShakeReply: searching... $peer_af_id => $timestamp\n"); - - my $tmpdb= new Affelio::SNS::Handshaker_tmpDB($af); - my @ret= $tmpdb->remove_sent_Handshake($timestamp); - - my $my_DH_pri_key_str; - my $dummy1; - my $dummy2; - my $dummy3; - my $dummy4; - - if(!defined(@ret)){ - #No such session exists!! - Affelio::misc::Debug::debug_print("server.HandShakeReply: sent-Handshake session NOT Found!\n"); - return { - flerror => XMLRPC::Data->type('boolean', 1), - message => "ERR:103 HandShakeReply denied." - }; - }else{ - ($dummy1, $dummy2, $dummy3, $dummy4, $my_DH_pri_key_str) = @ret; - Affelio::misc::Debug::debug_print("server.HandShakeReply: my DH_pri_key = $my_DH_pri_key_str"); - Affelio::misc::Debug::debug_print("server.HandShakeReply: sent-Handshake session Found. OK. Let's Move on."); - } - - ########################################### - #generate password - ########################################### - my $mydh = Crypt::DH->new; - #RFC 2412 - The OAKLEY Key Determination Protocol - #Group 1: A 768 bit prime - my $DH_g="2"; - my $DH_p="1552518092300708935130918131258481755631334049434514313202351194902966239949102107258669453876591642442910007680288864229150803718918046342632727613031282983744380820890196288509170691316593175367469551763119843371637221007210577919"; - $mydh->g($DH_g); - $mydh->p($DH_p); - - $mydh->priv_key(Math::BigInt->new($my_DH_pri_key_str) ); - my $pass - = $mydh->compute_key(Math::BigInt->new($peer_DH_pub_key_str))->bstr; - Affelio::misc::Debug::debug_print("server.HandShakeReply: PASSWORD=[$pass]\n"); - - ########################################### - #Add peer to my friends list. - ########################################### - my $uid = $af->{fm}->add_friend($peer_af_id, - $peer_nickname, - $timestamp, - $pass); - Affelio::misc::Debug::debug_print("server.HandShakeReply: add_friend finished.\n"); - - eval{ - $af->{db}->commit; - $af->{db}->disconnect; - undef($af); - }; - if($@){ - Affelio::misc::Debug::debug_print($@); - } - - ########################################### - #Get peer's friends list. - ########################################### - # "peer's friends" = my F2 friends - Affelio::misc::Debug::debug_print("server.HandshakeReply: Let's download peer's flist!"); - my $ret = Affelio::SNS::Handshaker_c::get_F2List(dest_uri => "$peer_af_id/bin/xml-rpc-serv.cgi", timestamp => 0); - Affelio::misc::Debug::debug_print("server.HandshakeReply: get_F2List finished."); - Affelio::misc::Debug::debug_print("server.HandshakeReply: List I've got is [$ret]"); - - ########################################### - #Save the F2 list into my DB - ########################################### - $af = Affelio::SNS::Handshaker_s::Util::af_new(); - Affelio::misc::Debug::debug_print("server.HandshakeReply: Let's save peer's flist!"); - $af->{fm}->save_F2List($ret, $peer_af_id); - Affelio::misc::Debug::debug_print("server.HandshakeReply: save_F2List finished."); - #Make a new instance of Affelio - - ########################################### - #Reply to client - ########################################### - return { - flerror => XMLRPC::Data->type('boolean', 0), - message => "OK: Thanks for your HandShakeReply." - }; - } - -} - - -######################################################################## -{ - package affelio; - BEGIN { @affelio::ISA = qw( Affelio::SNS::Handshaker_s ); } -} - - -######################################################################## -1; Index: affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm diff -u affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm:removed --- affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm Tue Oct 25 04:20:55 2005 @@ -1,139 +0,0 @@ -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: Handshaker_tmpDB.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use lib("../../../extlib/"); -use DBI; -use lib("../../"); -use Affelio; -use Affelio::misc::Debug; -use Affelio::misc::CGIError; - -######################################################################## -package Affelio::SNS::Handshaker_tmpDB; -{ - #################################################################### - #Constructor - #################################################################### - sub new{ - my $class = shift; - my $af = shift; - - Affelio::misc::Debug::debug_print("Handshaker_tmpDB::new: start."); - - my $self = {af => $af - }; - - bless $self, $class; - - Affelio::misc::Debug::debug_print("Handshaker_tmpDB::new: end."); - return $self; - } - - #################################################################### - #add_received_Handshake - #################################################################### - sub add_received_Handshake{ - Affelio::misc::Debug::debug_print("add_received_Handshake: start."); - return adddb(@_, "AFuser_SNS_tmp_recvd_hs"); - } - - #################################################################### - #remove_received_Handshake - #################################################################### - sub remove_received_Handshake{ - Affelio::misc::Debug::debug_print("remove_received_Handshake: start."); - return removedb(@_, "AFuser_SNS_tmp_recvd_hs"); - } - - #################################################################### - #add_sent_Handshake - #################################################################### - sub add_sent_Handshake{ - Affelio::misc::Debug::debug_print("add_sent_Handshake: start."); - return adddb(@_, "AFuser_SNS_tmp_sent_hs"); - } - - #################################################################### - #remove_sent_Handshake - #################################################################### - sub remove_sent_Handshake{ - Affelio::misc::Debug::debug_print("remove_sent_Handshake: start."); - return removedb(@_, "AFuser_SNS_tmp_sent_hs"); - } - - #################################################################### - #adddb - #################################################################### - sub adddb{ - my $self = shift; - my $sessionid = shift; #arg(1) session no. (string) - my $af_id = shift; #arg(2) af_id (string) - my $nickname = shift; #arg(3) nickname (string) - my $timestamp = shift; #arg(4) timestamp (string) - my $DH_key_str = shift; #arg(5) DH key (string) - my $dbname = shift; #arg(6) DBname (string) - - Affelio::misc::Debug::debug_print("add: $af_id $nickname $timestamp $DH_key_str $dbname"); - - my $af = $self->{af}; - - my $str = "insert into $dbname (sessionid, timestamp, af_id, nickname, DH_key_str) values ('$sessionid', '$timestamp', '$af_id', '$nickname', '$DH_key_str')"; - my $sth = $af->{db}->prepare($str); - $sth->execute() or die $af->{db}->errstr; - - Affelio::misc::Debug::debug_print("add: end."); - return; - } - - #################################################################### - #removedb - #################################################################### - sub removedb{ - my $self = shift; - my $sessionid = shift; #arg(1) session no. (string) - my $dbname = shift; - - my $af = $self->{af}; - - Affelio::misc::Debug::debug_print("removedb: $sessionid"); - - my $str = "SELECT sessionid, timestamp, af_id, nickname, DH_key_str FROM $dbname WHERE sessionid= '$sessionid'"; - my $sth = $af->{db}->prepare($str) or die $af->{db}->errstr; - $sth->execute() or die $af->{db}->errstr; - my @row = $sth->fetchrow_array; - - if(!defined(@row)){ - Affelio::misc::Debug::debug_print("removedb: No such session."); - return; - } - - my $str = "DELETE FROM $dbname WHERE sessionid=?"; - my $sth = $af->{db}->prepare($str) or die $af->{db}->errstr; - $sth->execute($sessionid); - - Affelio::misc::Debug::debug_print("removedb: end."); - return @row; - } - - -} - - -######################################################################## -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:55 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:55 +0900 Subject: [Affelio-cvs 688] CVS update: affelio_farm/admin/skelton/affelio/session Message-ID: <20051024192055.B68F12AC043@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/session/.htaccess diff -u affelio_farm/admin/skelton/affelio/session/.htaccess:1.1.1.1 affelio_farm/admin/skelton/affelio/session/.htaccess:removed --- affelio_farm/admin/skelton/affelio/session/.htaccess:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/session/.htaccess Tue Oct 25 04:20:55 2005 @@ -1,8 +0,0 @@ -AuthUserFile /dev/null -AuthGroupFile /dev/null -AuthType Basic - -<Limit GET> -order deny,allow -deny from all -</Limit> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:56 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:56 +0900 Subject: [Affelio-cvs 689] CVS update: affelio_farm/admin/skelton/affelio/skins/Xwin_classic Message-ID: <20051024192056.155292AC03A@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/0_face-s.jpg Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/0_face.jpg Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/affelio_top_Xwin.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bg_center.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bg_darklines.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bg_left.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bg_lightlines.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bottom_border_long.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/bottom_border_long2.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn1_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn1_left.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn1a_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn1b_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn2a2_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn2a_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn2b2_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/btn2b_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/right_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/style.css diff -u affelio_farm/admin/skelton/affelio/skins/Xwin_classic/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/skins/Xwin_classic/style.css:removed --- affelio_farm/admin/skelton/affelio/skins/Xwin_classic/style.css:1.1.1.1 Tue Oct 25 04:14:41 2005 +++ affelio_farm/admin/skelton/affelio/skins/Xwin_classic/style.css Tue Oct 25 04:20:55 2005 @@ -1,559 +0,0 @@ -/**********************************************************************/ -/* Main for public pages*/ -/**********************************************************************/ -body { - margin: 0px 0px 20px 0px; - background-color: #000; - text-align: center; -} - -a { - text-decoration: underline; -} -a:link { - color: #DEDADE; -} -a:visited { - color: #DEDADE; -} - -a:active { - color: #DEDADE; -} -a:hover { - color: #555555; -} -h1, h2, h3 { - margin: 0px; - padding: 0px; - font-weight: normal; -} - -/*****************************************/ -/* Container */ -/*****************************************/ -.afPubContainer { - margin-right: auto; - margin-left: auto; - text-align: left; - padding: 0px; - width: 800px; - height: auto; - background-image: url("bg.gif"); - border: 0px solid #FFFFFF; -} - -/*****************************************/ -/* Banner */ -/*****************************************/ -.afPubBanner { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 72px; - background:transparent url("affelio_top_Xwin.gif") left top; - background-color: #B43062; - border: 2px solid #DEDADE; - text-align: right; -} -.afPubBanner iframe{ - align: right; -} - -/*****************************************/ -/* Main */ -/*****************************************/ -.afPubMain { - margin: 0px 0px 0px 0px; - padding: 10px 0px 10px 10px; - width: 780px; - height: auto; - float: left; - background-color: #000; - font-family: Verdana, Arial, sans-serif; - border: 2px #DEDADE solid; -} - - -/*****************************************/ -/* Content Heading */ -/*****************************************/ -.afPubContentHeading{ - color: #DEDADE; - border: 2px solid; - border-color: #DEDADE; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 1; - padding: 3px 0px 3px 5px; - margin: -12px 0px 0px -12px; - background: #B43062; -} -.afPubContentHeading td{ - color: #DEDADE; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - font-weight: bold; - line-height: 100%; - background: transparent; -} -.afPubContentHeading a{ color: #DEDADE; } -.afPubContentHeading a:link{ color: #DEDADE; } -.afPubContentHeading a:visited{ color: #DEDADE; } -.afPubContentHeading a:active{ color: #DEDADE; } -.afPubContentHeading a:hover{ color: #555555; } - -.sidehide{ - background-color: #DEDADE; - color: #000; - font-family: Verdana, Arial, sans-serif; - font-size: small; - text-align: left; - font-weight: normal; - line-height: 100%; - padding: 3px 3px 3px 3px; - margin: 5px 3px 3px 5px; -} - -/*****************************************/ -/* loginarea */ -/*****************************************/ -.afPubLoginarea{ - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; -} - -/*****************************************/ -/* Mode List */ -/*****************************************/ -.afPubModeList { - margin: 0px 0px 0px -10px; - padding: 0px 0px 0px 5px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - border: 2px #DEDADE solid; - background-color: #DEDADE; -} - -.afPubModeList a{ - color: #000; -} -.afPubModeList a:link { - color: #000; -} -.afPubModeList a:visited { - color: #000; -} - -.afPubModeList a:active { - color: #000; -} -.afPubModeList a:hover { - color: #555555; -} - -/*****************************************/ -/* Content */ -/*****************************************/ -.afPubContent { - padding: 20px 0px 0px 0px; - background: transparent; - border: 0px solid #027BF4; -} - -.afPubContent h2 { - color: #DEDADE; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 10px;*/ -} - -.afPubContent table { - width: 100%; - background-color: #000; - padding: 0px; - border: 0px solid; - border-color: #DEDADE; -} - -.afPubContent td { - padding: 0px 0px 10px 0px; - background-color: #000; - border: 2px #DEDADE solid; -} - -/*****************************************/ -/* Content block*/ -/*****************************************/ -.afPubContentBlock { - height: auto; - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - color: #fff; - background: none; - background-color: #000; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 100%; - text-align: left; -} - -.afPubContentBlock a{ - color: #DEDADE; - text-decoration: none; -} - -.afPubContentBlock table { - border: none; -} - - -.afPubContentBlock td,th { - color: white; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - font-size: small; - border: none - text-align: left; -} - -.afPubContentBlock thead { - color: white; - background-color: #555; -} - - -/*****************************************/ -/* Message block*/ -/*****************************************/ - -.afPubMessageTable table { - border: none; - border-collapse: collapse; -} - - -.afPubMessageTable td { - color: white; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-color: #000; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable th { - color: white; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable thead { - color: black; - background-color: #555; -} - - - -/*****************************************/ -/* Content block title*/ -/*****************************************/ -.afPubContentBlockTitle{ - color: #DEDADE; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - text-align: left; - font-weight: bold; - line-height: 100%; - padding: 5px 5px 5px 5px; - margin: -2px -2px 0px -2px; - background: #B43062; - border: 2px solid; - border-color: #DEDADE; -} -.afPubContentBlockTitle a{ color: #DEDADE; text-decoration: none;} -.afPubContentBlockTitle a:link{ color: #DEDADE; } -.afPubContentBlockTitle a:visited{ color: #DEDADE; } -.afPubContentBlockTitle a:active{ color: #DEDADE; } -.afPubContentBlockTitle a:hover{ color: #DEDADE; } - - -/*****************************************/ -/* Footer */ -/*****************************************/ -.afPubFooter { - width: 800px; - background: #DADEDA; - text-align: center; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 170%; - color: #000; -} - -.afPubFooter a { - color: #B43062; - clear:both; - text-decoration: none; -} - -/**************************************************************************/ -/*Styles for each <AF_*> TAG*/ -/**************************************************************************/ -.aftag__friendlist_5{ - width: 100%; -} -.aftag__friendlist_5__field{ - background: #000; - width: 145px; - height: 150px; - vertical-align: top; - text-align: center; - float:left; -} -.aftag__friendlist_5__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_5__status{ - width: 130px; - line-height: 100%; - margin: 0px; - padding: 0px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_5__image{ - width: 100px; - height: 100px; - text-align: center; - overflow: hidden; -} - - -/*******************************************/ -.aftag__friendlist_all__field{ - width: 130px; - height: 180px; - - float: left; - background: #000; - vertical-align: top; - text-align: center; -} -.aftag__friendlist_all__name{ - width: 130px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_all__status{ - line-height: 100%; - margin: 0px; - padding: 0px; - width: 130px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; -/* background-color: #D4ECF9;*/ - background-color: #000; - font-weight: normal; -} - -.aftag__friendlist_all__intro{ - width: 120px; - padding: 5px 0px 5px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: xx-small; - font-weight: normal; - text-align: left; - line-height: 110%; -} - -/*******************************************/ -.aftag__profile_table{ - width: 600px; - margin: 20px 5px 5px 5px; - border: 0px; -} - -.aftag__profile_table__th{ - width: 30%; - padding: 5px 10px 0px 5px; - float: left; - text-align: right; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: bold; - line-height: 110%; -} -.aftag__profile_table__td{ - width: 65%; - padding: 5px 10px 0px 5px; - float: right; - text-align: left; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 110%; -} - -/*******************************************/ -/* unified_imgtab_h */ -/*******************************************/ -.aftag__unified_imgtab_h{ - margin: 0px 0px 0px 0px; - padding: 0px 48px 0px 48px; - overflow: hidden; - height: 33px; - background-image: url("bg.gif"); -} -.aftag__unified_imgtab_h__left_field{ - margin: 6px 1px 0px 1px; - padding: 0px 0px 0px 0px; - height: 33px; - float:left; - overflow: hidden; -} -.aftag__unified_imgtab_h__right_field{ - margin: 6px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 33px; - float:right; - overflow: hidden; -} - -/*ICON*/ -.aftag__unified_imgtab_h__icon{ - /* Does NOT print */ - display: none; -} - -/*TEXT NAME*/ -.aftag__unified_imgtab_h__text{ - color: #FFF; -} -.aftag__unified_imgtab_h__text a{ - position: relative; - Top: 3px; - height: 19px; - width: 20px; - min-height: 19px; - min-width: 19px; - text-align: justify; - text-justify: distribute-all-lines; - text-decoration: none; - white-space: nowrap; - padding: 0px 15px; - background-color: #B43062; - border: 2px solid #DEDADE; - font-family: Arial; - font-size: x-small; - text-align: center; - vertical-align: middle; - color: #FFF; -} - -.aftag__unified_imgtab_h__text_selected{ - color: #FFF; -} -.aftag__unified_imgtab_h__text_selected a{ - position: relative; - Top: 3px; - height: 19px; - width: 20px; - min-height: 19px; - min-width: 19px; - text-align: justify; - text-justify: distribute-all-lines; - text-decoration: none; - white-space: nowrap; - padding: 0px 15px; - background-color: #B43062; - border: 2px solid #DEDADE; - font-family: Arial; - font-size: x-small; - text-align: center; - vertical-align: middle; - color: #FFF; -} - -/**************************************************************************/ -/* div ID afMenu */ -/**************************************************************************/ -.afAdminMenu { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 10px; - width:130px; - height: auto; - float: left; - border-right: 2px solid #DEDADE; - color: #DEDADE; - font-family: Verdana, Arial, sans-serif; -} - - -.adAdminSubMenu{ - font-size: small; - text-align: left; - font-weight: normal; - line-height: 100%; - padding: 0px 0px 0px 0px; - margin: 0px 0px 0px 0px; -} - - -.afAdminMenu ul { - margin: 0px; - padding: 3px 0px 15px 10px; - list-style-type: none; -} - -.afAdminMenu li { -/* position: relative;*/ - text-align: justify; - text-justify: distribute-all-lines; - text-decoration: none; - white-space: nowrap; - padding-left: 0px; - padding-top: 5px; - border: 1px solid; - border-color: #DEDADE; - background-color: #B43062; - font-family: Arial; - font-size: x-small; - text-align: center; - vertical-align: middle; - line-height: 140% -} - -.afAdminMenu a:link{ - text-decoration: none; - color: #DEDADE; -} -.afAdminMenu a:visited{ - text-decoration: none; - color: #DEDADE; -} -.afAdminMenu a:hover{ - text-decoration: none; - color: black; -} Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/tab_guest.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/tab_owner.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/titlebar-back.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/titlebar-back2.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/top_border.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/top_border_long.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/top_border_long2.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/top_left_corner.gif Index: affelio_farm/admin/skelton/affelio/skins/Xwin_classic/top_right_corner.gif From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:56 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:56 +0900 Subject: [Affelio-cvs 690] CVS update: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1 Message-ID: <20051024192056.74A5D2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/0_face-s.jpg Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/0_face.jpg Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/affelio_top_aqua.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/bg_center.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/bg_darklines.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/bg_left.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/bg_lightlines.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/bottom_border_long.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/bottom_border_long2.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn1_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn1_left.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn1a_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn1b_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn2a2_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn2a_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn2b2_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/btn2b_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/right_bg.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/style.css diff -u affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/style.css:removed --- affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/style.css:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/style.css Tue Oct 25 04:20:56 2005 @@ -1,544 +0,0 @@ -/**********************************************************************/ -/* Main for public pages*/ -/**********************************************************************/ -body { - margin: 0px 0px 20px 0px; - background-color: #FFF; - text-align: center; -} - -a { - text-decoration: underline; -} -a:link { - color: #8FABBE; -} -a:visited { - color: #8FABBE; -} - -a:active { - color: #8FABBE; -} -a:hover { - color: #006699; -} -h1, h2, h3 { - margin: 0px; - padding: 0px; - font-weight: normal; -} - -/*****************************************/ -/* Container */ -/*****************************************/ -.afPubContainer { - margin-right: auto; - margin-left: auto; - text-align: left; - padding: 0px; - width: 800px; - height: auto; - background-image: url("bg_center.gif"); - border: 0px solid #FFFFFF; -} - -/*****************************************/ -/* Banner */ -/*****************************************/ -.afPubBanner { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 72px; - background-color: #3A99F9; - background:transparent url("affelio_top_aqua.gif") left top; - border-bottom: 1px solid #FFFFFF; - text-align: right; -} -.afPubBanner iframe{ - align: right; -} - -/*****************************************/ -/* Main */ -/*****************************************/ -.afPubMain { - margin: 0px 0px 0px 0px; - padding: 10px 0px 10px 30px; - width: 750px; - height: auto; - float: left; - background: transparent; - font-family: Verdana, Arial, sans-serif; -} - - -/*****************************************/ -/* Content Heading */ -/*****************************************/ -.afPubContentHeading{ - color: #000000; - border: 1px solid; - border-color: #808080; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 1; - padding: 5px 0px 0px 5px; - margin: 0px 0px 0px 0px; - background:transparent url("titlebar-back2.gif") repeat-x left top; - background-color: #eee; -} -.afPubContentHeading td{ - color: #00000; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - font-weight: bold; - line-height: 100%; -} -.afPubContentHeading a{ color: #000000; } -.afPubContentHeading a:link{ color: #000000; } -.afPubContentHeading a:visited{ color: #000000; } -.afPubContentHeading a:active{ color: #000000; } -.afPubContentHeading a:hover{ color: #555555; } - -.sidehide{ - color: #000; - font-family: Verdana, Arial, sans-serif; - font-size: small; - text-align: left; - font-weight: normal; - padding: 3px 3px 3px 3px; - margin: 5px 3px 3px 5px; -} - -/*****************************************/ -/* loginarea */ -/*****************************************/ -.afPubLoginarea{ - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; -} - -/*****************************************/ -/* Mode List */ -/*****************************************/ -.afPubModeList { - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; -} - -.afPubModeList a{ - color: #333; -} - -/*****************************************/ -/* Content */ -/*****************************************/ -.afPubContent { - padding: 20px 0px 0px 0px; - background: transparent; - border: 0px solid #027BF4; -} - -.afPubContent h2 { - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 10px;*/ -} - -.afPubContent table { - width: 100%; - background-color: #FFF; - padding: 0px; - border: 1px solid; - border-color: #808080; -} - -.afPubContent td { - padding: 0px 0px 10px 0px; - background-color: #FFF; -} - -/*****************************************/ -/* Content block*/ -/*****************************************/ -.afPubContentBlock { - height: auto; - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - color: black; - background: none; - background-color: #FFF; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 100%; - text-align: left; - -} - -.afPubContentBlock a{ - color: #333; - text-decoration: none; -} - -.afPubContentBlock table { - border: none; -} - - -.afPubContentBlock td,th { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - font-size: small; - border: none - text-align: left; -} - -.afPubContentBlock thead { - color: black; - background-color: #aaa; -} - -/*****************************************/ -/* Content block title*/ -/*****************************************/ -.afPubContentBlockTitle{ - color: #000; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - text-align: left; - font-weight: bold; - line-height: 100%; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background:transparent url("titlebar-back.gif") repeat-x left top; - background-color: #eee; - border: 1px solid; - border-color: #808080; -} -.afPubContentBlockTitle a{ color: #333; text-decoration: none;} -.afPubContentBlockTitle a:link{ color: #333; } -.afPubContentBlockTitle a:visited{ color: #333; } -.afPubContentBlockTitle a:active{ color: #333; } -.afPubContentBlockTitle a:hover{ color: #555; } - -/*****************************************/ -/* Message block*/ -/*****************************************/ - -.afPubMessageTable table { - border: none; - border-collapse: collapse; -} - - -.afPubMessageTable td { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-color: #fff; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable th { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable thead { - color: black; - background-color: #bbb; -} - -/*****************************************/ -/* Footer */ -/*****************************************/ -.afPubFooter { - width: 800px; - background-image: url("bottom_border_long2.gif"); - text-align: center; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 170% -} - -.afPubFooter a { - color: #000000; - clear:both; - text-decoration: none; -} - -/**************************************************************************/ -/*Styles for each <AF_*> TAG*/ -/**************************************************************************/ -.aftag__friendlist_5{ - width: 100%; -} -.aftag__friendlist_5__field{ - background: #FFF; - width: 145px; - height: 150px; - vertical-align: top; - text-align: center; - float:left; -} -.aftag__friendlist_5__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_5__status{ - width: 130px; - line-height: 100%; - margin: 0px; - padding: 0px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_5__image{ - width: 100px; - height: 100px; - text-align:center; - overflow: hidden; -} - -/*******************************************/ -.aftag__friendlist_all{ - width: 100%; -} -.aftag__friendlist_all__field{ - background: #FFF; - width: 145px; - vertical-align: top; - text-align: center; - float: left; -} -.aftag__friendlist_all__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_all__status{ - width: 130px; - line-height: 100%; - margin: 0px; - padding: 0px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_all__image{ - width: 100px; - height: 100px; - text-align:center; - overflow: hidden; -} -.aftag__friendlist_all__intro{ - width: 120px; - padding: 5px 0px 5px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: xx-small; - font-weight: normal; - text-align: left; - line-height: 110%; -} - - -/*******************************************/ -.aftag__profile_table{ - width: 600px; - margin: 20px 5px 5px 5px; - border: 0px; -} - -.aftag__profile_table__th{ - width: 30%; - padding: 5px 10px 0px 5px; - float: left; - text-align: right; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: bold; - line-height: 110%; -} -.aftag__profile_table__td{ - width: 65%; - padding: 5px 10px 0px 5px; - float: right; - text-align: left; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 110%; -} - - -/*******************************************/ -/* unified_imgtab_h */ -/*******************************************/ -.aftag__unified_imgtab_h{ - margin: 0px 0px 0px 0px; - padding: 0px 48px 0px 48px; - overflow: hidden; - height: 33px; - background-image: url("top_border_long2.gif"); -} -.aftag__unified_imgtab_h__left_field{ - margin: 6px 1px 0px 1px; - padding: 0px 0px 0px 0px; - height: 33px; - float:left; - overflow: hidden; -} -.aftag__unified_imgtab_h__right_field{ - margin: 6px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 33px; - float:right; - overflow: hidden; -} - -/*ICON*/ -.aftag__unified_imgtab_h__icon{ - /* Does NOT print */ - display: none; -} - -/*TEXT NAME*/ -.aftag__unified_imgtab_h__text{ - color: #000; -} -.aftag__unified_imgtab_h__text a{ - position: relative; - Top: 3px; - height: 19px; - text-align: justify; - text-justify: distribute-all-lines; - text-decoration: none; - white-space: nowrap; - padding: 0px 15px; - border: 1px solid; - border-color: #808080; - background-image: url("btn1a_bg.gif"); - font-family: Arial; - font-size: small; - text-align: center; - vertical-align: middle; - color: #666; -} - -.aftag__unified_imgtab_h__text_selected{ - color: #000; -} -.aftag__unified_imgtab_h__text_selected a{ - position: relative; - Top: 3px; - height: 19px; - text-align: justify; - text-justify: distribute-all-lines; - text-decoration: none; - white-space: nowrap; - padding: 0px 15px; - border: 1px solid; - border-color: #808080; - background-image: url("btn1b_bg.gif"); - font-family: Arial; - font-size: small; - text-align: center; - vertical-align: middle; - color: #aaa; -} - - -/**************************************************************************/ -/* div ID afMenu */ -/**************************************************************************/ -.afAdminMenu { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 10px; - width:130px; - height: auto; - float: left; - border-right: 1px solid #aaa; -/* background-color: #fff;*/ - font-family: Verdana, Arial, sans-serif; -} - - -.afAdminMenu ul { - margin: 0px; - padding: 3px 0px 15px 10px; - list-style-type: none; -} - -.afAdminMenu li { -/* position: relative;*/ -/* Top: 3px;*/ -/* height: 19px;*/ - text-align: justify; - text-justify: distribute-all-lines; - text-decoration: none; - white-space: nowrap; - padding-left: 0px; - padding-top: 5px; - border: 1px solid; - border-color: #808080; - background-image: url("btn1a_bg.gif"); - font-family: Arial; - font-size: x-small; - text-align: center; - vertical-align: middle; - line-height: 140%; - color: #666; -} - - -.adAdminSubMenu{ - font-size: small; - text-align: left; - font-weight: normal; - line-height: 100%; - padding: 0px 0px 0px 0px; - margin: 0px 0px 0px 0px; -} - -.afAdminMenu a:link{ - text-decoration: none; - color: #333; -} -.afAdminMenu a:visited{ - text-decoration: none; - color: #333; -} -.afAdminMenu a:hover{ - text-decoration: none; - color: black; -} - Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/tab_guest.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/tab_owner.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/titlebar-back.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/titlebar-back2.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/top_border.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/top_border_long.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/top_border_long2.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/top_left_corner.gif Index: affelio_farm/admin/skelton/affelio/skins/aqualike-1.1/top_right_corner.gif From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:56 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:56 +0900 Subject: [Affelio-cvs 691] CVS update: affelio_farm/admin/skelton/affelio/skins/simple Message-ID: <20051024192056.C344B2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/skins/simple/0_face-s.jpg Index: affelio_farm/admin/skelton/affelio/skins/simple/0_face.jpg Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top1.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top2.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top3.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top4.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top5.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top6.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/affelio_top7.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/arrow.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/bg.jpg Index: affelio_farm/admin/skelton/affelio/skins/simple/footer.jpg Index: affelio_farm/admin/skelton/affelio/skins/simple/h_bg.jpg Index: affelio_farm/admin/skelton/affelio/skins/simple/header.jpg Index: affelio_farm/admin/skelton/affelio/skins/simple/js_common.js diff -u affelio_farm/admin/skelton/affelio/skins/simple/js_common.js:1.1.1.1 affelio_farm/admin/skelton/affelio/skins/simple/js_common.js:removed --- affelio_farm/admin/skelton/affelio/skins/simple/js_common.js:1.1.1.1 Tue Oct 25 04:14:41 2005 +++ affelio_farm/admin/skelton/affelio/skins/simple/js_common.js Tue Oct 25 04:20:56 2005 @@ -1,23 +0,0 @@ - -function MM_swapImgRestore() { //v3.0 - var i,x,a=document.MM_sr; for(i=0;a&&i<a.length&&(x=a[i])&&x.oSrc;i++) x.src=x.oSrc; -} - -function MM_preloadImages() { //v3.0 - var d=document; if(d.images){ if(!d.MM_p) d.MM_p=new Array(); - var i,j=d.MM_p.length,a=MM_preloadImages.arguments; for(i=0; i<a.length; i++) - if (a[i].indexOf("#")!=0){ d.MM_p[j]=new Image; d.MM_p[j++].src=a[i];}} -} - -function MM_findObj(n, d) { //v4.01 - var p,i,x; if(!d) d=document; if((p=n.indexOf("?"))>0&&parent.frames.length) { - d=parent.frames[n.substring(p+1)].document; n=n.substring(0,p);} - if(!(x=d[n])&&d.all) x=d.all[n]; for (i=0;!x&&i<d.forms.length;i++) x=d.forms[i][n]; - for(i=0;!x&&d.layers&&i<d.layers.length;i++) x=MM_findObj(n,d.layers[i].document); - if(!x && d.getElementById) x=d.getElementById(n); return x; -} - -function MM_swapImage() { //v3.0 - var i,j=0,x,a=MM_swapImage.arguments; document.MM_sr=new Array; for(i=0;i<(a.length-2);i+=3) - if ((x=MM_findObj(a[i]))!=null){document.MM_sr[j++]=x; if(!x.oSrc) x.oSrc=x.src; x.src=a[i+2];} -} Index: affelio_farm/admin/skelton/affelio/skins/simple/spacer.gif Index: affelio_farm/admin/skelton/affelio/skins/simple/style.css diff -u affelio_farm/admin/skelton/affelio/skins/simple/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/skins/simple/style.css:removed --- affelio_farm/admin/skelton/affelio/skins/simple/style.css:1.1.1.1 Tue Oct 25 04:14:41 2005 +++ affelio_farm/admin/skelton/affelio/skins/simple/style.css Tue Oct 25 04:20:56 2005 @@ -1,519 +0,0 @@ -/**********************************************************************/ -/* Main for public pages*/ -/**********************************************************************/ -body { - margin: 0px 0px 20px 0px; - background-color: #8FABBE; - text-align: center; -} - -a { - text-decoration: underline; -} -a:link { - color: #8FABBE; -} -a:visited { - color: #8FABBE; -} - -a:active { - color: #8FABBE; -} -a:hover { - color: #006699; -} -h1, h2, h3 { - margin: 0px; - padding: 0px; - font-weight: normal; -} - -/*****************************************/ -/* Container */ -/*****************************************/ -.afPubContainer { - margin-right: auto; - margin-left: auto; - text-align: left; - padding: 0px; - width: 800px; - height: auto; - background-color: #D7D7D7; - border: 1px solid #FFFFFF; -} - -/*****************************************/ -/* Banner */ -/*****************************************/ -.afPubBanner { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 72px; - background-color: #3A99F9; - background:transparent url("affelio_top1.gif") left top; - border-bottom: 1px solid #FFFFFF; - text-align: right; -} -.afPubBanner iframe{ - align: right; -} - -/*****************************************/ -/* Main */ -/*****************************************/ -.afPubMain { - margin: 0px 0px 0px 0px; - padding: 10px 10px 10px 10px; - width: 780px; - height: auto; - float: left; - background-color: #FFF; - font-family: Verdana, Arial, sans-serif; -} - -/*****************************************/ -/* Content Heading */ -/*****************************************/ -.afPubContentHeading{ - color: #FFFFFF; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - padding: 5px 5px 5px 5px; - width: 100%; - margin: 0px 0px 0px 0px; - background:transparent url("titlebar-back.png") repeat-x left top; - background-color: #eee; -} -.afPubContentHeading td{ - color: #FFFFFF; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - font-weight: bold; - line-height: 100%; -} -.afPubContentHeading a{ color: #FFFFFF; } -.afPubContentHeading a:link{ color: #FFFFFF; } -.afPubContentHeading a:visited{ color: #FFFFFF; } -.afPubContentHeading a:active{ color: #FFFFFF; } -.afPubContentHeading a:hover{ color: #cccccc; } - -.sidehide{ - color: #000; - font-family: Verdana, Arial, sans-serif; - font-size: small; - text-align: left; - font-weight: normal; - padding: 3px 3px 3px 3px; - margin: 5px 3px 3px 5px; -} - -/*****************************************/ -/* loginarea */ -/*****************************************/ -.afPubLoginarea{ - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; -} - -/*****************************************/ -/* Content */ -/*****************************************/ -.afPubContent { - width: 100% - padding: 20px 0px 0px 5px; - margin: 0px 0px 0px 0px; - background-color: #FFF; - border: 0px solid #027BF4; - background: white; -} - -.afPubContent h2 { - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 10px;*/ -} - -.afPubContent table { - width: 100%; - margin: 0px 0px 0px 0px; - padding: 5px 5px 5px 5px; -} - - -/*****************************************/ -/* Content block*/ -/*****************************************/ -.afPubContentBlock { - height: auto; - margin: 0px 0px 10px 0px; - padding: 5px 5px 5px 5px; - width: 100%; - color: black; - background: none; - background-color: #eee; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 130%; - text-align: left; -} - -.afPubContentBlock table { - border: none; - margin: 0px 0px 0px 0px; -} - -.afPubContentBlock td,th { - color: black; - margin: 0px 0px 0px 0px; - font-size: small; - border: none - text-align: left; -} - -.afPubContentBlock thead { - color: black; - background-color: #aaa; -} - -div#IDbMyOverview{ -} -div#IDMyFriends{ -background: #FC0864; -} -div#IDMyReference{ -background: #69C367; -} -div#IDMyProfile{ -background: #69C367; -} - -/*****************************************/ -/* Content block title*/ -/*****************************************/ -.afPubContentBlockTitle{ - color: #FFF; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - text-align: left; - font-weight: bold; - line-height: 100%; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - width: 100%; - background-color: #7297CE; -} -.afPubContentBlockTitle a{ color: #FFFFFF; } -.afPubContentBlockTitle a:link{ color: #FFFFFF; } -.afPubContentBlockTitle a:visited{ color: #FFFFFF; } -.afPubContentBlockTitle a:active{ color: #FFFFFF; } -.afPubContentBlockTitle a:hover{ color: #cccccc; } - - -/*****************************************/ -/* Message block*/ -/*****************************************/ - -.afPubMessageTable table { - border: none; - border-collapse: collapse; -} - - -.afPubMessageTable td { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-color: #fff; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable th { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable thead { - color: black; - background-color: #bbb; -} - - -/*****************************************/ -/* Mode List */ -/*****************************************/ -.afPubModeList { - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; -} - - -/*****************************************/ -/* Footer */ -/*****************************************/ -.afPubFooter { - width: 800px; - background-color: #cccccc; - text-align: center; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 170% -} - -.afPubFooter a { - color: #000000; - clear:both; - text-decoration: none; -} - - -/**************************************************************************/ -/*Styles for each <AF_*> TAG*/ -/**************************************************************************/ -.aftag__friendlist_5{ - width: 100%; -} -.aftag__friendlist_5__field{ - background: #eee; - width: 145px; - height: 150px; - vertical-align: top; - text-align: center; - float:left; -} -.aftag__friendlist_5__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_5__status{ - width: 130px; - line-height: 100%; - margin: 0px; - padding: 0px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_5__image{ - width: 100px; - height: 100px; - text-align:center; - overflow: hidden; -} - -/*******************************************/ -.aftag__friendlist_all{ - width: 100%; -} -.aftag__friendlist_all__field{ - background: #eee; - width: 149px; - vertical-align: top; - text-align: center; - float: left; -} -.aftag__friendlist_all__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_all__status{ - width: 130px; - line-height: 100%; - margin: 0px; - padding: 0px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_all__image{ - width: 100px; - height: 100px; - text-align:center; - overflow: hidden; -} -.aftag__friendlist_all__intro{ - width: 120px; - padding: 5px 0px 5px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: xx-small; - font-weight: normal; - text-align: left; - line-height: 110%; -} - -/*******************************************/ -.aftag__profile_table{ - width: 600px; - margin: 20px 5px 5px 5px; - border: 0px; -} - -.aftag__profile_table__th{ - width: 30%; - padding: 5px 10px 0px 5px; - float: left; - text-align: right; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: bold; - line-height: 110%; -} -.aftag__profile_table__td{ - width: 65%; - padding: 5px 10px 0px 5px; - float: right; - text-align: left; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 110%; -} - -/*******************************************/ -/* unified_imgtab_h */ -/*******************************************/ -.aftag__unified_imgtab_h{ - margin: 0px 0px 0px 0px; - padding: 0px 48px 0px 48px; - overflow: hidden; - height: 22px; -} -.aftag__unified_imgtab_h__left_field{ - width: 80px; - margin: 6px 1px 0px 1px; - padding: 0px 0px 0px 0px; - background-color: #FF0; - float:left; - overflow: hidden; -} -.aftag__unified_imgtab_h__right_field{ - width: 80px; - margin: 6px 1px 0px 1px; - padding: 0px 0px 0px 0px; - background-color: #FF0; - float: right; - overflow: hidden; -} - -/*ICON*/ -.aftag__unified_imgtab_h__icon{ - /* Does NOT print = size 0 */ - width: 0px; - height: 0px; -} - -/*TEXT NAME*/ -.aftag__unified_imgtab_h__text{ - padding: 3px 0px 3px 0px; - border: 0px solid; - border-color: #808080; - background-image: url("btn1a_bg.gif"); - font-family: Arial; - font-size: x-small; - text-align: center; - color: #666; -} -.aftag__unified_imgtab_h__text a{ - color: #666; -} - -.aftag__unified_imgtab_h__text_selected{ - padding: 3px 0px 3px 0px; - border: 0px solid; - border-color: #808080; - background-image: url("btn1b_bg.gif"); - font-family: Arial; - font-size: x-small; - text-align: center; - color: #000; - font-weight: bold; -} -.aftag__unified_imgtab_h__text_selected a{ - color: #000; - font-weight: bold; -} - -/**************************************************************************/ -/* div ID afMenu */ -/**************************************************************************/ -.afAdminMenu { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - width:150px; - height: auto; - float: left; - border-right: 1px solid #aaa; - background-color: #d7d7d7; - font-family: Verdana, Arial, sans-serif; -} - - -.adAdminSubMenu{ - font-size: small; - text-align: left; - font-weight: normal; - line-height: 100%; - padding: 0px 0px 0px 0px; - margin: 0px 0px 0px 0px; -} - -.afAdminMenu ul { - margin: 0px; - padding: 5px 0px 10px 10px; - list-style-type: none; -} - -.afAdminMenu li { - padding-left: 0px; - padding-top: 5px; - text-align: left; - font-family: Verdana, Arial, sans-serif; - font-size: small; - line-height: 140%; - border-bottom: 1px solid #aaa; -} - -.afAdminMenu a:link{ - text-decoration: none; - color: #333; -} -.afAdminMenu a:visited{ - text-decoration: none; - color: #333; -} -.afAdminMenu a:hover{ - text-decoration: none; - color: black; -} - - - -/**************************************************************************/ Index: affelio_farm/admin/skelton/affelio/skins/simple/titlebar-back.png From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:56 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:56 +0900 Subject: [Affelio-cvs 692] CVS update: affelio_farm/admin/skelton/affelio/skins/standard Message-ID: <20051024192056.F11DA2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/skins/standard/0_face-s.jpg Index: affelio_farm/admin/skelton/affelio/skins/standard/0_face.jpg Index: affelio_farm/admin/skelton/affelio/skins/standard/arrow.gif Index: affelio_farm/admin/skelton/affelio/skins/standard/bg.jpg Index: affelio_farm/admin/skelton/affelio/skins/standard/footer.jpg Index: affelio_farm/admin/skelton/affelio/skins/standard/h_bg.jpg Index: affelio_farm/admin/skelton/affelio/skins/standard/header.jpg Index: affelio_farm/admin/skelton/affelio/skins/standard/js_common.js diff -u affelio_farm/admin/skelton/affelio/skins/standard/js_common.js:1.1.1.1 affelio_farm/admin/skelton/affelio/skins/standard/js_common.js:removed --- affelio_farm/admin/skelton/affelio/skins/standard/js_common.js:1.1.1.1 Tue Oct 25 04:14:41 2005 +++ affelio_farm/admin/skelton/affelio/skins/standard/js_common.js Tue Oct 25 04:20:56 2005 @@ -1,23 +0,0 @@ - -function MM_swapImgRestore() { //v3.0 - var i,x,a=document.MM_sr; for(i=0;a&&i<a.length&&(x=a[i])&&x.oSrc;i++) x.src=x.oSrc; -} - -function MM_preloadImages() { //v3.0 - var d=document; if(d.images){ if(!d.MM_p) d.MM_p=new Array(); - var i,j=d.MM_p.length,a=MM_preloadImages.arguments; for(i=0; i<a.length; i++) - if (a[i].indexOf("#")!=0){ d.MM_p[j]=new Image; d.MM_p[j++].src=a[i];}} -} - -function MM_findObj(n, d) { //v4.01 - var p,i,x; if(!d) d=document; if((p=n.indexOf("?"))>0&&parent.frames.length) { - d=parent.frames[n.substring(p+1)].document; n=n.substring(0,p);} - if(!(x=d[n])&&d.all) x=d.all[n]; for (i=0;!x&&i<d.forms.length;i++) x=d.forms[i][n]; - for(i=0;!x&&d.layers&&i<d.layers.length;i++) x=MM_findObj(n,d.layers[i].document); - if(!x && d.getElementById) x=d.getElementById(n); return x; -} - -function MM_swapImage() { //v3.0 - var i,j=0,x,a=MM_swapImage.arguments; document.MM_sr=new Array; for(i=0;i<(a.length-2);i+=3) - if ((x=MM_findObj(a[i]))!=null){document.MM_sr[j++]=x; if(!x.oSrc) x.oSrc=x.src; x.src=a[i+2];} -} Index: affelio_farm/admin/skelton/affelio/skins/standard/spacer.gif Index: affelio_farm/admin/skelton/affelio/skins/standard/style.css diff -u affelio_farm/admin/skelton/affelio/skins/standard/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/skins/standard/style.css:removed --- affelio_farm/admin/skelton/affelio/skins/standard/style.css:1.1.1.1 Tue Oct 25 04:14:41 2005 +++ affelio_farm/admin/skelton/affelio/skins/standard/style.css Tue Oct 25 04:20:56 2005 @@ -1,513 +0,0 @@ -/**********************************************************************/ -/* Main for public pages*/ -/**********************************************************************/ -body { - margin: 0px 0px 0px 0px; - background-color: #FFFFFF; - text-align: center; - background-repeat: repeat-y; - background-position: center top; -} - -a { - text-decoration: underline; -} -a:link { - color: #1169A4; -} -a:visited { - color: #1169A4; -} - -a:active { - color: #1169A4; -} -a:hover { - color: #1169A4; -} -h1, h2, h3 { - margin: 0px; - padding: 0px; - font-weight: normal; -} - -/*****************************************/ -/* Container */ -/*****************************************/ -.afPubContainer { - width: 800px; - margin-left: auto; - margin-right: auto; - padding: 0px 0px 0px 0px; -/* background-image: url(bg.jpg);*/ - border-left: 2px solid #cccccc; - border-right: 2px solid #cccccc; - text-align: left; - height: auto; - background-color: #FFF; -} - -/*****************************************/ -/* Banner */ -/*****************************************/ -.afPubBanner { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 106px; - width: 800px; - background:#1169A3 url(header.jpg) left top; - text-align: right; -} -.afPubBanner iframe{ - align: right; - margin-top: 10px; - margin-right: 10px; -} - -/*****************************************/ -/* Main */ -/*****************************************/ -.afPubMain { - margin: 0px 0px 0px 0px; - padding: 10px 10px 10px 10px; - width: 780px; - height: auto; - float: left; - background-color: #FFF; - font-family: Verdana, Arial, sans-serif; -} - -/*****************************************/ -/* Content Heading */ -/*****************************************/ -.afPubContentHeading{ - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - width:100%; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-color: #ddd; -} -.afPubContentHeading td{ - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - font-weight: bold; - line-height: 100%; -} -.afPubContentHeading a{ color: #666666; } -.afPubContentHeading a:link{ color: #1169A4; } -.afPubContentHeading a:visited{ color: #1169A4; } -.afPubContentHeading a:active{ color: #1169A4; } -.afPubContentHeading a:hover{ color: #1169A4; } - -.sidehide{ - color: #000; - font-family: Verdana, Arial, sans-serif; - font-size: small; - text-align: left; - font-weight: normal; - padding: 5px 5px 5px 5px; - margin: 3px; -} - - -/*****************************************/ -/* loginarea */ -/*****************************************/ -.afPubLoginarea{ - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; -} - -/*****************************************/ -/* Mode List */ -/*****************************************/ -.afPubModeList { - margin: 5px 0px 0px 0px; - padding: 0px 0px 0px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; -} - - -/*****************************************/ -/* Content */ -/*****************************************/ -.afPubContent { - padding: 20px 0px 0px 0px; - margin: 0px 0px 0px 0px; - width:100%; - background-color: #1169A4; - border: 0px solid #027BF4; - background: white; -} - -.afPubContent h2 { - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 10px;*/ -} - -.afPubContent table { - width: 100%; -} - - -/*****************************************/ -/* Content block*/ -/*****************************************/ -.afPubContentBlock { - height: auto; - margin: 0px 0px 10px 0px; - padding: 5px 5px 5px 5px; - color: black; - width:100%; - background: none; - background-color: #eee; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 130%; - text-align: left; - -} - -.afPubContentBlock table { - border: none; - margin: 0px 0px 0px 0px; -/* padding: 5px 5px 5px 5px;*/ -} - - -.afPubContentBlock td,th { - color: black; -/* padding: 5px 5px 5px 5px;*/ - margin: 0px 0px 0px 0px; - font-size: small; - border: none - text-align: left; -} - -.afPubContentBlock thead { - color: black; - background-color: #aaa; -} - -div#IDbMyOverview{ -} -div#IDMyFriends{ -} -div#IDMyReference{ -} -div#IDMyProfile{ -} - - -/*****************************************/ -/* Content block title*/ -/*****************************************/ -.afPubContentBlockTitle{ - color: #666; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - text-align: left; - font-weight: bold; - line-height: 100%; - width:auto; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-image: url(h_bg.jpg); - background-repeat: repeat-x; - border: 1px solid #B7B7BF; -} -.afPubContentBlockTitle a{ color: #1169A4; } -.afPubContentBlockTitle a:link{ color: #1169A4; } -.afPubContentBlockTitle a:visited{ color: #1169A4; } -.afPubContentBlockTitle a:active{ color: #1169A4; } -.afPubContentBlockTitle a:hover{ color: #1169A4; } - - -/*****************************************/ -/* Message block*/ -/*****************************************/ - -.afPubMessageTable table { - border: none; - border-collapse: collapse; -} - - -.afPubMessageTable td { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-color: #fff; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable th { - color: black; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - font-size: small; - border: 1px solid #aaa; - text-align: left; -} - -.afPubMessageTable thead { - color: black; - background-color: #bbb; -} - -/*****************************************/ -/* Footer */ -/*****************************************/ -.afPubFooter { - width: 800px; - background-color: #cccccc; - text-align: center; - font-family: Verdana, Arial, sans-serif; - font-size: small; - line-height: 170% -} - -.afPubFooter a { - color: #000000; - clear:both; - text-decoration: none; -} - - -/**************************************************************************/ -/*Styles for each <AF_*> TAG*/ -/**************************************************************************/ -.aftag__friendlist_5{ - width: 100%; -} -.aftag__friendlist_5__field{ - background: #eee; - width: 145px; - height: 150px; - vertical-align: top; - text-align: center; - float:left; -} -.aftag__friendlist_5__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_5__status{ - margin: 0px; - padding: 0px; - width: 130px; - line-height: 100%; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_5__image{ - width: 100px; - height: 100px; - text-align:center; - overflow: hidden; -} - -/*******************************************/ -.aftag__friendlist_all{ - width: 100%; -} -.aftag__friendlist_all__field{ - background: #eee; - width: 149px; - vertical-align: top; - text-align: center; - float: left; -} -.aftag__friendlist_all__name{ - width: 130px; - height: 20px; - overflow: hidden; - font-family: Arial; - font-size: x-small; - font-weight: bold; -} -.aftag__friendlist_all__status{ - width: 130px; - line-height: 100%; - margin: 0px; - padding:0px; - overflow: hidden; - font-family: Arial; - font-size: xx-small; - font-weight: normal; -} -.aftag__friendlist_all__image{ - width: 100px; - height: 100px; - text-align:center; - overflow: hidden; -} -.aftag__friendlist_all__intro{ - width: 120px; - padding: 5px 0px 5px 0px; - font-family: Verdana, Arial, sans-serif; - font-size: xx-small; - font-weight: normal; - text-align: left; - line-height: 110%; -} - -/*******************************************/ -.aftag__profile_table{ - width: 600px; - margin: 20px 5px 5px 5px; - border: 0px; -} - -.aftag__profile_table__th{ - width: 30%; - padding: 5px 10px 0px 5px; - float: left; - text-align: right; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: bold; - line-height: 110%; -} -.aftag__profile_table__td{ - width: 65%; - padding: 5px 10px 0px 5px; - float: right; - text-align: left; - vertical-align: top; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 110%; -} - -/*******************************************/ -/* unified_imgtab_h */ -/*******************************************/ -.aftag__unified_imgtab_h{ - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 9px; - background-color: #FFF; - overflow: hidden; - height: 52px; -} -.aftag__unified_imgtab_h__left_field{ - margin: 0px 5px 0px 0px; - padding: 0px 0px 0px 0px; - float:left; - overflow: hidden; -} -.aftag__unified_imgtab_h__right_field{ - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - float:right; - overflow: hidden; -} - -/*ICON*/ -.aftag__unified_imgtab_h__icon{ - /* Does NOT print = size 0 */ - /*width: 0px;*/ - /*height: 0px;*/ - /*******************/ - /* Does print */ - width: 50px; - height: 50px; -} - -/*TEXT NAME*/ -.aftag__unified_imgtab_h__text{ - /* Does NOT print */ - display: none; -} -.aftag__unified_imgtab_h__text a{ - color: #FFF; -} - -.aftag__unified_imgtab_h__text_selected{ - /* Does NOT print */ - display: none; -} -.aftag__unified_imgtab_h__text_selected a{ - color: #FFF; -} - -/**************************************************************************/ -/**************************************************************************/ -/* div ID afMenu */ -/**************************************************************************/ -.afAdminMenu { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - width:150px; - height: auto; - float: left; - border-right: 1px solid #aaa; - background-color: #fff; - font-family: Verdana, Arial, sans-serif; -} - - -.adAdminSubMenu{ - font-size: small; - text-align: left; - font-weight: normal; - line-height: 100%; - padding: 0px 0px 0px 0px; - margin: 0px 0px 0px 0px; -} - -.afAdminMenu ul { - margin: 0px; - padding: 5px 0px 10px 10px; - list-style-type: none; -} - -.afAdminMenu li { - padding-left: 0px; - padding-top: 5px; - text-align: left; - font-family: Verdana, Arial, sans-serif; - font-size: small; - line-height: 140%; - border-bottom: 1px solid #aaa; -} - -.afAdminMenu a:link{ - text-decoration: none; - color: #333; -} -.afAdminMenu a:visited{ - text-decoration: none; - color: #333; -} -.afAdminMenu a:hover{ - text-decoration: none; - color: black; -} - - - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:57 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:57 +0900 Subject: [Affelio-cvs 693] CVS update: affelio_farm/admin/skelton/affelio/templates Message-ID: <20051024192057.1C4102AC01F@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:57 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:57 +0900 Subject: [Affelio-cvs 694] CVS update: affelio_farm/admin/skelton/affelio/templates/default/email Message-ID: <20051024192057.41B7B2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/templates/default/email/invitation_email.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/email/invitation_email.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/email/invitation_email.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/email/invitation_email.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/email/invitation_email.tmpl Tue Oct 25 04:20:57 2005 @@ -1,15 +0,0 @@ -[TO_ADDR]?????- -???????純??激????????????ffelio?吾??????? - -[FROM_NICKNAME]([FROM_ADDR])????????????Affelio??-???????????? - -??????????????ffelio?泣???????????????? -[FROM_NICKNAME]?????ffelio?泣???[FROM_URL] ??-?脂?????帥???????? - -??????????????ffelio??????????????????篁ヤ?????潟?????????-?????ffelio??????荀????????????? - -[INTRO_URL] From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:58 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:58 +0900 Subject: [Affelio-cvs 695] CVS update: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images Message-ID: <20051024192058.5040A2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/0.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/10.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/100.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/200.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/30.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/350.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/400.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/50.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/500.jpg Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/bullet-blue.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/bullet-green.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/bullet-red.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/content_block_BG.png Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/icon-info.png Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/icon_del.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/icon_home.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/logo-box-200x200.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/titlebar-back.png From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:58 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:58 +0900 Subject: [Affelio-cvs 696] CVS update: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo Message-ID: <20051024192058.7D0512AC04F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top1.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top2.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top3.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top4.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top5.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top6.gif Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/images/toplogo/affelio_top7.gif From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:58 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:58 +0900 Subject: [Affelio-cvs 697] CVS update: affelio_farm/admin/skelton/affelio/templates_dyn Message-ID: <20051024192058.A1B9B2AC020@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:58 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:58 +0900 Subject: [Affelio-cvs 698] CVS update: affelio_farm/admin/skelton/affelio/tests Message-ID: <20051024192058.D0C7A2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/tests/dbtest.cgi diff -u affelio_farm/admin/skelton/affelio/tests/dbtest.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/tests/dbtest.cgi:removed --- affelio_farm/admin/skelton/affelio/tests/dbtest.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/tests/dbtest.cgi Tue Oct 25 04:20:58 2005 @@ -1,31 +0,0 @@ -#!/usr/bin/perl - -use strict; -use lib("../extlib"); -use Fcntl qw( :DEFAULT :flock); -use MLDBM qw( DB_File Storable); - -my $db_file = "hoge.dat"; -my %hash; - -####################### -#DB File open -my $db = tie(%hash, "MLDBM", $db_file, O_CREAT|O_RDWR, 0644) - or die "DB [$db_file] tie failed"; -my $fd = $db->fd; -open DBM, "+<&=$fd" or die "DBM open failed"; -flock DBM, LOCK_EX; -undef $db; - -####################### -#$hash{'123456789'}= { -# name => "Tadashi Okoshi", -# email => "tadashi\@okoshi.org" -# }; - -print "$hash{'123456789'}{'name'}\n"; -print "$hash{'123456789'}{'email'}\n"; - -####################### -#DB close -untie %hash; Index: affelio_farm/admin/skelton/affelio/tests/hoge.dat Index: affelio_farm/admin/skelton/affelio/tests/package_list.cgi diff -u affelio_farm/admin/skelton/affelio/tests/package_list.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/tests/package_list.cgi:removed --- affelio_farm/admin/skelton/affelio/tests/package_list.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/tests/package_list.cgi Tue Oct 25 04:20:58 2005 @@ -1,20 +0,0 @@ -#!/usr/bin/perl - -use XML::Parser::Lite; -print "$XML::Parser::Lite::VERSION\n"; - -use CGI; -print "$CGI::VERSION\n"; - -use lib("./extlib/"); - - -use File::Copy; -print "File::Copy $File::Copy::VERSION\n"; - - -use Data::Dumper; -print "Data::Dumper $Data::Dumper::VERSION\n"; - -use MLDBM; -print "MLDBM $MLDBM::VERSION\n"; Index: affelio_farm/admin/skelton/affelio/tests/rc5test.cgi diff -u affelio_farm/admin/skelton/affelio/tests/rc5test.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/tests/rc5test.cgi:removed --- affelio_farm/admin/skelton/affelio/tests/rc5test.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/tests/rc5test.cgi Tue Oct 25 04:20:58 2005 @@ -1,14 +0,0 @@ -#!/usr/bin/perl -use lib "../lib"; -use Crypt::RC5; - -$plaintext = "test test."; - -$ref = Crypt::RC5->new("keykey", 12 ); -$ciphertext = $ref->encrypt( $plaintext ); - -$ref2 = Crypt::RC5->new( "keykey", 12 ); -$plaintext2 = $ref2->decrypt( $ciphertext ); - - -print "plaintext2: $plaintext\n"; Index: affelio_farm/admin/skelton/affelio/tests/session_test.cgi diff -u affelio_farm/admin/skelton/affelio/tests/session_test.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/tests/session_test.cgi:removed --- affelio_farm/admin/skelton/affelio/tests/session_test.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/tests/session_test.cgi Tue Oct 25 04:20:58 2005 @@ -1,30 +0,0 @@ -#!/usr/bin/perl -use lib "../lib"; -use lib "../extlib"; -use Walrus::Session::Lite; - -my %session; -my $session_dir = "../session/"; - -#?祉??激??潟?????????-tie(%session, 'Walrus::Session::Lite', $session_dir); -$session{'latest_login'} = time(); - -#??????????с?ID???? -# -> cookie????????拭?????-my $session_id = $session{'_session_id'}; - -#?祉??激??潟?腟?????絖????? -untie %session; -my $result = tied(%session)->delete_expired(3 * 24 * 60 * 60); # 3?ヤ札筝???違?????祉??激??潟??贋? - - -#cokie??????client?????????session ID??戎?c? session??? -tie(%session, 'Walrus::Session::Lite', $session_dir, $session_id); -$session{'latest_login'} = time(); - - - - - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:58 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:58 +0900 Subject: [Affelio-cvs 699] CVS update: affelio_farm/admin/skelton/affelio/userdata Message-ID: <20051024192058.F27892AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/userdata/.htaccess diff -u affelio_farm/admin/skelton/affelio/userdata/.htaccess:1.1.1.1 affelio_farm/admin/skelton/affelio/userdata/.htaccess:removed --- affelio_farm/admin/skelton/affelio/userdata/.htaccess:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/userdata/.htaccess Tue Oct 25 04:20:58 2005 @@ -1,8 +0,0 @@ -AuthUserFile /dev/null -AuthGroupFile /dev/null -AuthType Basic - -<Limit GET> -order deny,allow -deny from all -</Limit> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:42 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:42 +0900 Subject: [Affelio-cvs 700] CVS update: affelio_farm/admin/skelton/affelio Message-ID: <20051024192042.6D1D92AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/CHANGES diff -u affelio_farm/admin/skelton/affelio/CHANGES:1.1.1.1 affelio_farm/admin/skelton/affelio/CHANGES:removed --- affelio_farm/admin/skelton/affelio/CHANGES:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/CHANGES Tue Oct 25 04:20:42 2005 @@ -1,218 +0,0 @@ -1.0.1 (July 12, 2005) - Debug: Setup Wizard - Error-handling has been revised. - Probably we don't have just "500 error" any more. - (We can have more detailed error messages) - - -1.0.0 (July 4, 2005) - -1.0RC2 (July 4, 2005) - - Debug: Handshaking error - RID:0000047 - Handshake reply back to Affelio with MySQL did not - finish correctly due to MySQL error. - - - Debug: Affelio's Session forwarding - -Symptom: Access from the owner was sometimes recognized as - "friend of friend" access, when the owner goes from own - page, to friend's page and go back to own page. - - -Symptom: Large number of tmp files was created in - session/ directory. - - Debug: Link to other Affelio's - Change hyperlink URL to link through outgoing.cgi - Messaging - AccessLog - App: Diary - - Debug: Profile editting - Profile value did not appear on the page after user - upload profile image to the server. - - Brushup - Core/public/friendlist - Only for owner, show [edit] and [mail] - -1.0RC1.1 (July 2, 2005) - Debug: - AccessLog did not work well with mySQL - -1.0RC1 (July 1, 2005) - - Feature: - -Messaging among Affelio - -notification to email - -Removal of friend - -Affelio News - -You can set the "top page" to application, not to Affelio - -Free-format message in friend link request. - -Access log (a.k.a. ASHIATO in Japanese) - -Show number of friends, and friends of friends (roughly) - - Brush-up - Page design - - Setup Wizard - Note: install wizard is only for "new setup" - Note: only one DB modules is needed out of two. - - Debug: MacOSX - Template system now works fine on MacOSX - - Feature: Mixi App - If the owner accesses the Mixi app, show actual - image files from Mixi. - - Feature: Diary - RSS import functionality. - (This will be available only if the web server - has XML::Parser module installed.) - -0.9.5.4 (June 22, 2005) - Feature: Photo Album application - Now we have Phot Album Application!!! - - Debug: Setup Wizard - -JavaScript for checking nickname input value - was not working correctly. - -New scheme on checking file permission - in order to install smoothly on several hosting web site. - -0.9.5.3 (June 22, 2005) - Misc: CGI::Session - Added auto/CGI/Session to extlib/ - -0.9.5.2 (June 22, 2005) - Debug: setup.cgi - Without DBD::SQLite, setup did not proceed further... - -0.9.5.1 (June 22, 2005) - Misc: CGI::Session - Added CGI::Session to extlib/ - -0.9.5 (June 22, 2005) - Feature: MySQL support - RID:0000026 - Now we experimentally support MySQL. - - Feature: Built-in Crypt::DH - RID:0000023 - We don't need Crypt::DH and Math::Pari any more as install - requirement. Everything is in extlib - - Feature: Skin System 1.1 - - Skin System 1.1 - - Skins: "Standard", "Aqua", and "XwinClassic" - - Debug: Mixi application - - Login failure - - Error message - - some style thing - - Debug: Skin uploading - RID:0000013 - We had a problem in uploading skin zip file. - - Debug: Typo - RID:0000022 - Typo in ManageGroup.pm - - Debug: Setup.cgi - Now setup.cgi works fine on MacOS X. - - -0.9.4.2 (May 15, 2005) - RID:0000018 - Debug: Added I18N::LangTags module in extlib/ - - RID:0000016 - Debug: Affelio did not work correctly if it was installed at - http://localhost:8000/ - - RID:0000017 - Debug: Typo in setup.cgi - - - - -0.9.4.1 (May 13, 2005) - Debug: Session, Cookie, Login problem - Fixed a problem that user cannot logon from Internet - Explorer. - - -0.9.4 (May 12, 2005) - Feature: Affelio API 1.0 - - Feature: "Simple Diary" application now works! - - Feature: Access control for Affelio applications - - Structure: Now using CGI::Session as session/cookie management - - Misc: skins: new default images - Misc: templates: new default image size - - RID:0000014 - Debug: Moji-bake in "Given name" field. (in Edit Profile) - - Debug: Session: - Session module has been replaced by CGI::Session - - Debug: Affelio Session forwarding - get_content.cgi: a program to get remote content with - Affelio session forwarding had a big bug. now fixed. - - -0.9.3 (May 7, 2005) - Feature: New skin editting menu - - Feature: Warn user when she is accessing from a private IP address - and when she tries to fowward session to another Affelio. - - RID:0000004 - Debug: Modify FriendManager:add() so that, when two already-friends - Affelio exhange another friend link communication, the - FriendManager update their newly-generated passwords - respectively. - - RID:0000009 - Debug: An error screen appears when login fails. - (A bug introduced in 0.9.2) - - RID:0000008 - Debug: An error screen appears when link request is sent. - (A bug introduced in 0.9.2) - - RID:0000008 - Debug: An error screen appears when link approval is sent. - (A bug introduced in 0.9.2) - - RID:0000010 - Debug: CGI goes into infinite loop in friend edit mode. - - RID:0000011 - Debug: Permission table in "Edit Friend" was somewhat broken. - - -0.9.2 (May 6, 2005) - Feature: Added Japanese and American English support. - - Structure: Localization (with Locale::Maketext) - - Debug: Affelio could not be installed without DBD::CSV. - - -0.9.1 (May 1, 2005) - Include "Error" module in extlib/ - Include "Config::IniFiles" module in extlib/ - Renew the version of "Config::Tiny" module from 2.00 to 2.01 - - Added Perl module checking in setup.cgi setup wizard. - -0.9 (April 27, 2005) - Initial release Index: affelio_farm/admin/skelton/affelio/COPYING diff -u affelio_farm/admin/skelton/affelio/COPYING:1.1.1.1 affelio_farm/admin/skelton/affelio/COPYING:removed --- affelio_farm/admin/skelton/affelio/COPYING:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/COPYING Tue Oct 25 04:20:42 2005 @@ -1,352 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA - - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -Preamble -======== - -The licenses for most software are designed to take away your freedom -to share and change it. By contrast, the GNU General Public License is -intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - -When we speak of free software, we are referring to freedom, not price. -Our General Public Licenses are designed to make sure that you have -the freedom to distribute copies of free software (and charge for this -service if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs; and that you know you can do these things. - -To protect your rights, we need to make restrictions that forbid anyone -to deny you these rights or to ask you to surrender the rights. These -restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - -For example, if you distribute copies of such a program, whether gratis -or for a fee, you must give the recipients all the rights that you -have. You must make sure that they, too, receive or can get the source -code. And you must show them these terms so they know their rights. - -We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - -Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - -Finally, any free program is threatened constantly by software patents. -We wish to avoid the danger that redistributors of a free program will -individually obtain patent licenses, in effect making the program -proprietary. To prevent this, we have made it clear that any patent -must be licensed for everyone's free use or not licensed at all. - -The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - 0. This License applies to any program or other work which contains a - notice placed by the copyright holder saying it may be distributed - under the terms of this General Public License. The "Program", - below, refers to any such program or work, and a "work based on - the Program" means either the Program or any derivative work under - copyright law: that is to say, a work containing the Program or a - portion of it, either verbatim or with modifications and/or - translated into another language. (Hereinafter, translation is - included without limitation in the term "modification".) Each - licensee is addressed as "you". - - Activities other than copying, distribution and modification are - not covered by this License; they are outside its scope. The act - of running the Program is not restricted, and the output from the - Program is covered only if its contents constitute a work based on - the Program (independent of having been made by running the - Program). Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's - source code as you receive it, in any medium, provided that you - conspicuously and appropriately publish on each copy an appropriate - copyright notice and disclaimer of warranty; keep intact all the - notices that refer to this License and to the absence of any - warranty; and give any other recipients of the Program a copy of - this License along with the Program. - - You may charge a fee for the physical act of transferring a copy, - and you may at your option offer warranty protection in exchange - for a fee. - - 2. You may modify your copy or copies of the Program or any portion - of it, thus forming a work based on the Program, and copy and - distribute such modifications or work under the terms of Section 1 - above, provided that you also meet all of these conditions: - - a. You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b. You must cause any work that you distribute or publish, that - in whole or in part contains or is derived from the Program - or any part thereof, to be licensed as a whole at no charge - to all third parties under the terms of this License. - - c. If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display - an announcement including an appropriate copyright notice and - a notice that there is no warranty (or else, saying that you - provide a warranty) and that users may redistribute the - program under these conditions, and telling the user how to - view a copy of this License. (Exception: if the Program - itself is interactive but does not normally print such an - announcement, your work based on the Program is not required - to print an announcement.) - - These requirements apply to the modified work as a whole. If - identifiable sections of that work are not derived from the - Program, and can be reasonably considered independent and separate - works in themselves, then this License, and its terms, do not - apply to those sections when you distribute them as separate - works. But when you distribute the same sections as part of a - whole which is a work based on the Program, the distribution of - the whole must be on the terms of this License, whose permissions - for other licensees extend to the entire whole, and thus to each - and every part regardless of who wrote it. - - Thus, it is not the intent of this section to claim rights or - contest your rights to work written entirely by you; rather, the - intent is to exercise the right to control the distribution of - derivative or collective works based on the Program. - - In addition, mere aggregation of another work not based on the - Program with the Program (or with a work based on the Program) on - a volume of a storage or distribution medium does not bring the - other work under the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, - under Section 2) in object code or executable form under the terms - of Sections 1 and 2 above provided that you also do one of the - following: - - a. Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of - Sections 1 and 2 above on a medium customarily used for - software interchange; or, - - b. Accompany it with a written offer, valid for at least three - years, to give any third-party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a - medium customarily used for software interchange; or, - - c. Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with - such an offer, in accord with Subsection b above.) - - The source code for a work means the preferred form of the work for - making modifications to it. For an executable work, complete - source code means all the source code for all modules it contains, - plus any associated interface definition files, plus the scripts - used to control compilation and installation of the executable. - However, as a special exception, the source code distributed need - not include anything that is normally distributed (in either - source or binary form) with the major components (compiler, - kernel, and so on) of the operating system on which the executable - runs, unless that component itself accompanies the executable. - - If distribution of executable or object code is made by offering - access to copy from a designated place, then offering equivalent - access to copy the source code from the same place counts as - distribution of the source code, even though third parties are not - compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program - except as expressly provided under this License. Any attempt - otherwise to copy, modify, sublicense or distribute the Program is - void, and will automatically terminate your rights under this - License. However, parties who have received copies, or rights, - from you under this License will not have their licenses - terminated so long as such parties remain in full compliance. - - 5. You are not required to accept this License, since you have not - signed it. However, nothing else grants you permission to modify - or distribute the Program or its derivative works. These actions - are prohibited by law if you do not accept this License. - Therefore, by modifying or distributing the Program (or any work - based on the Program), you indicate your acceptance of this - License to do so, and all its terms and conditions for copying, - distributing or modifying the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the - Program), the recipient automatically receives a license from the - original licensor to copy, distribute or modify the Program - subject to these terms and conditions. You may not impose any - further restrictions on the recipients' exercise of the rights - granted herein. You are not responsible for enforcing compliance - by third parties to this License. - - 7. If, as a consequence of a court judgment or allegation of patent - infringement or for any other reason (not limited to patent - issues), conditions are imposed on you (whether by court order, - agreement or otherwise) that contradict the conditions of this - License, they do not excuse you from the conditions of this - License. If you cannot distribute so as to satisfy simultaneously - your obligations under this License and any other pertinent - obligations, then as a consequence you may not distribute the - Program at all. For example, if a patent license would not permit - royalty-free redistribution of the Program by all those who - receive copies directly or indirectly through you, then the only - way you could satisfy both it and this License would be to refrain - entirely from distribution of the Program. - - If any portion of this section is held invalid or unenforceable - under any particular circumstance, the balance of the section is - intended to apply and the section as a whole is intended to apply - in other circumstances. - - It is not the purpose of this section to induce you to infringe any - patents or other property right claims or to contest validity of - any such claims; this section has the sole purpose of protecting - the integrity of the free software distribution system, which is - implemented by public license practices. Many people have made - generous contributions to the wide range of software distributed - through that system in reliance on consistent application of that - system; it is up to the author/donor to decide if he or she is - willing to distribute software through any other system and a - licensee cannot impose that choice. - - This section is intended to make thoroughly clear what is believed - to be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in - certain countries either by patents or by copyrighted interfaces, - the original copyright holder who places the Program under this - License may add an explicit geographical distribution limitation - excluding those countries, so that distribution is permitted only - in or among countries not thus excluded. In such case, this - License incorporates the limitation as if written in the body of - this License. - - 9. The Free Software Foundation may publish revised and/or new - versions of the General Public License from time to time. Such - new versions will be similar in spirit to the present version, but - may differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the - Program specifies a version number of this License which applies - to it and "any later version", you have the option of following - the terms and conditions either of that version or of any later - version published by the Free Software Foundation. If the Program - does not specify a version number of this License, you may choose - any version ever published by the Free Software Foundation. - - 10. If you wish to incorporate parts of the Program into other free - programs whose distribution conditions are different, write to the - author to ask for permission. For software which is copyrighted - by the Free Software Foundation, write to the Free Software - Foundation; we sometimes make exceptions for this. Our decision - will be guided by the two goals of preserving the free status of - all derivatives of our free software and of promoting the sharing - and reuse of software generally. - - NO WARRANTY - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO - WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE - LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT - HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT - WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT - NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE - QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE - PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY - SERVICING, REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN - WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY - MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE - LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, - INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR - INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF - DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU - OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY - OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN - ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS -How to Apply These Terms to Your New Programs -============================================= - -If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these -terms. - -To do so, attach the following notices to the program. It is safest to -attach them to the start of each source file to most effectively convey -the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - ONE LINE TO GIVE THE PROGRAM'S NAME AND A BRIEF IDEA OF WHAT IT DOES. - Copyright (C) YYYY NAME OF AUTHOR - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - 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. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19YY NAME OF AUTHOR - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the -appropriate parts of the General Public License. Of course, the -commands you use may be called something other than `show w' and `show -c'; they could even be mouse-clicks or menu items--whatever suits your -program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - SIGNATURE OF TY COON, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, -you may consider it more useful to permit linking proprietary -applications with the library. If this is what you want to do, use the -GNU Library General Public License instead of this License. - Index: affelio_farm/admin/skelton/affelio/LICENSE-sjis.txt diff -u affelio_farm/admin/skelton/affelio/LICENSE-sjis.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/LICENSE-sjis.txt:removed --- affelio_farm/admin/skelton/affelio/LICENSE-sjis.txt:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/LICENSE-sjis.txt Tue Oct 25 04:20:42 2005 @@ -1,9 +0,0 @@ -Affelio?純?????с?????ゃ??潟??????? - -??????????≪???PL?????ffelio?潟??若??c?????祉??鴻?????≪?????祉???-?с??????????affelio.jp??? http://affelio.jp/modules/tinyd5/ ?????? -??????? - - -Affelio Project -April 2005 Index: affelio_farm/admin/skelton/affelio/LICENSE.txt diff -u affelio_farm/admin/skelton/affelio/LICENSE.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/LICENSE.txt:removed --- affelio_farm/admin/skelton/affelio/LICENSE.txt:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/LICENSE.txt Tue Oct 25 04:20:42 2005 @@ -1,11 +0,0 @@ -On the Lisence of the Affelio Software - -This software, Affelio, is a software with dual license based on GPL and -the Affelio commercial lisence. For more detaile, Please refer the Affelio -web page. - -Affelio Project -April 2005 - -http://affelio.jp/ (Japan) -http://affelio.us/ (USA and other countries) Index: affelio_farm/admin/skelton/affelio/README-sjis.txt diff -u affelio_farm/admin/skelton/affelio/README-sjis.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/README-sjis.txt:removed --- affelio_farm/admin/skelton/affelio/README-sjis.txt:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/README-sjis.txt Tue Oct 25 04:20:42 2005 @@ -1,95 +0,0 @@ -Affelio: The Open Social Network - - Version: 1.0.0 July 4, 2005 - - -??????????????? - - ????????GPL2.0????????????????????? - ???????? - - ???A????????GPL2.0???????????B??? - GPL2.0???????????????????? - ================================================================ - ???????- ??????????????????????????????? - ???????????????????????????????B - ?????q????????A???メ???????????? - ??????????????????????????I???? - ???????????????I?????(??????)??? - ????????u????????????????????ソ? - ??????????????????????????????? - ????????????A??????????????A???- ?????????????????????? - - ???????????????????????A???メ??? - ??L???????????????????????????? - ??????????????????????????????? - ?????????Q???????????????(?????- ク???????A??????メ?????ク????????? - ????????????????????????s?????? - ??????????)???????????????????? - ?????????????????????????????? - ================================================================ - - -??????????? - - http://affelio.jp ?????????????????ヲ?? - ????????????????????ソ?????????? - ???????????????? - - ????????????????http://affelio.jp ??????? - ??????????????????? - - -???????? - - ?Unix?Web??? - ?CGI??????? -? ?Perl verion.5.6??- ????Perl????? - LWP - URI - DBI - - ???2????????? - DBD::mysql (MySQL4.1?????????????????? - DBD::SQLite (SQLite???????????????? - - -???????? - - (1)????????FTP?Web?????A???????????? - ??????????UTF-8????????B - ??FTP????????????????????? - ??.cgi????????タ?????????????????? - - (2)??????setup.cgi?タ??????????????????? - ? ??????????ヲ????i??????? - - ???????RL????????? - http://affelio.jp/modules/tinyd9/ - - -??? - ????????Affelio??????????Affelio????? - http://affelio.jp ?????????????????????- ???? - - -???? - ??????Affelio????????????????????fヲ? - ???????????????? - - -?????????? - Affelio??GPL???Affelio???????????????? - ?????????????????GPL???????? - ??????????????????Aaffelio.jp? - http://affelio.jp/modules/tinyd5/ ????????B - - -?????W - Affelio????????ミ???????????L???? - Affelio????ミ???????????W??? Index: affelio_farm/admin/skelton/affelio/README.txt diff -u affelio_farm/admin/skelton/affelio/README.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/README.txt:removed --- affelio_farm/admin/skelton/affelio/README.txt:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/README.txt Tue Oct 25 04:20:42 2005 @@ -1,78 +0,0 @@ -Affelio: The Open Social Network - - Version: 1.0.0 July 4, 2005 - - -Caution! - This version is a "RC" (Release Candidate) version of Affelio. - Users need to understand following points. - - * You may encounter some problem in install and use of this - software. - - * NO WARRANTY. - - * This version is "GPL version". Please understand the policy - of GPL, especially the following paragraphs from GPL 2.0. - ---------------------------------------------------------- - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE - IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY - APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE - COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM - "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR - IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE - OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE - DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, - REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO - IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO - MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED - ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, - SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF - THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT - LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR - LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE - PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH - HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF - SUCH DAMAGES. - ---------------------------------------------------------- - -Install Requirement - - * UNIX/Linux-based web server - * CGI environment - * Perl 5.6 and later - * Following Perl modules - - -LWP - -URI - -DBI - - (One of the following) - -DBD::mysql for MySQL use - -DBD::SQLite for SQLite use - -How to Install - - (1)Upload all files to the web server via FTP - - - We recommend you use "binary" mode since - some files are written in UTF-8. - - Set executable permission for all .cgi files. - - (2)Access setup.cgi from your browser. - - That's it! :) - - -Support - Please visit our website for more information! - http://affelio.us is our web site in USA and other countries. - http://affelio.jp is our web site in Japan. - - -Copyright (C)2005 FishGrove Inc. - Index: affelio_farm/admin/skelton/affelio/admin.cgi diff -u affelio_farm/admin/skelton/affelio/admin.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/admin.cgi:removed --- affelio_farm/admin/skelton/affelio/admin.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/admin.cgi Tue Oct 25 04:20:42 2005 @@ -1,832 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: admin.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use lib("./extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 0; -$CGI::POST_MAX = 1024_000; -use Error qw(:try); -use CGI::Session qw(-ip_match); -use HTML::Template; -use Fcntl; - -use lib("./lib"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::Debug qw( debug_print); -use Affelio::misc::Time; -use Affelio::misc::NetMisc; -use Affelio::misc::WebInput; -use Affelio::exception::CommunicationException; - -############################################################################ -#Load Affelio -############################################################################ -debug_print("admin.cgi: start."); - -my $cfg_dir = "./config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print "<HTML><PRE>Affelio load error.<BR>$e<BR><BR>" . $e->stacktrace . "</PRE></HTML>"; - exit(1); -}; -debug_print("admin.cgi: AF loaded."); -my $wi = new Affelio::misc::WebInput(); - -############################################################################ -#Check session w/ cookie -############################################################################ -my $TMPL_FILE=""; -my $q = new CGI; -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -debug_print("admin.cgi: sid from cookie = $sid"); -my $session=""; -if($sid){ - $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - debug_print("admin:cgi Existing session: [" . $session->id . "]"); -} - -if( (!$session) || ($session->param("type") ne "self") ){ - # Is the session alive? - # Is the user the admin of this site? - # if not.... - debug_print("admin.cgi: login is needed."); - - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print get_HTML_header(); - - $TMPL_FILE = "$af->{site__fs_root}/templates/$af->{site__template}/owner_side/login.tmpl"; - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - $tmpl->param(reason_msg => "You haven't been authenticated."); - $tmpl->param("tmpl_path" => "$af->{site__web_root}/templates/$af->{site__template}/owner_side/"); - $tmpl->param("style_path" => $af->{site__web_root} . "/skins/" . $af->{userpref__skin}); - $tmpl->param("forward_URL" => $q->self_url); - - print $af->translate_templateL10N($tmpl->output); - print get_HTML_footer(); - exit(1); -} - -debug_print("admin.cgi: Session as the admin is OK."); -$session->expire('+12h'); - -############################################################################ -#Going to the owner mode -############################################################################ -#Set this Affelio as owner mode. -$af->set_owner_mode(); - - -############################################################################ -#Invoking models -############################################################################ -use Affelio::App::Admin::Messaging; -my %output_data = ("tmpl_path", "$af->{site__web_root}/templates/$af->{site__template}/owner_side/", - "style_path", $af->{site__web_root} . "/skins/" . $af->{userpref__skin}, - "site_web_root", "$af->{site__web_root}", - "my_nickname", $af->{user__nickname}, - "my_currentstatus", $af->{user__currentstatus}, - "new_messages", Affelio::App::Admin::Messaging::get_new($af) - ); - -my $HTTP_forward_flag = 0; -my $forward_URL = ""; -my $ret_msg=""; -my $err_msg=""; - -my $admin_mode = $wi->PTN_mode($q->url_param("mode")); - -##################################################################### -#Affelio Configuration -##################################################################### -if($admin_mode eq "config_affelio"){ - - use Affelio::App::Admin::Configuration; - - my $sub_mode = $wi->PTN_mode($q->url_param("action")); - if($sub_mode eq "submit" ){ - try{ - Affelio::App::Admin::Configuration::configure($af, $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_affelio_config.tmpl"; - Affelio::App::Admin::Configuration::show($af,\%output_data); - -##################################################################### -#Access Log -##################################################################### -}elsif($admin_mode eq "accesslog"){ - - use Affelio::App::Admin::AccessLog; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_access_log.tmpl"; - try{ - Affelio::App::Admin::AccessLog::show($af,$q,\%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - -##################################################################### -#Upload Image -##################################################################### -}elsif($admin_mode eq "uploadimage"){ - - use Affelio::App::Admin::EditProfile; - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_editprofile.tmpl"; - - my $sub_mode = $wi->PTN_mode($q->url_param("action")); - if($sub_mode eq "submit" ){ - try{ - $q->cgi_error - and error($q, "File transfer failed." . $q->cgi_error); - - my $uploaded_filename = $wi->PTN_jpg_filename($q->param("file")) - || error($q, "File has not been transfered to server."); - my $fh = $q->upload( "file" ); - - sysopen(OUT, "$af->{site__user_dir}/profile_face.jpg", - O_WRONLY|O_TRUNC|O_CREAT, 0755); - binmode $fh; - binmode OUT; - my $buffer=""; - while (read ($fh, $buffer, 16384)){ - print OUT $buffer; - } - close OUT; - }catch Error with{ - my $e = shift; - $err_msg='<AF_M text="Error in uploading the image"><BR>' . $e; - }; - - Affelio::App::Admin::EditProfile::show_profileeditor($af, \%output_data); - }else{ - } - -##################################################################### -#Messages -##################################################################### -}elsif($admin_mode eq "messages"){ - - use Affelio::App::Admin::Messaging; - - if( $q->url_param("action") eq "send_message" ){ - - try{ - $ret_msg=Affelio::App::Admin::Messaging::send_message($af, $q); - $ret_msg='<AF_M text="You message has been sent successfuly.">'; - }catch Affelio::exception::CommunicationException with{ - my $E = shift; - $err_msg='<AF_M text="Could not send message."><BR>' . $E; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_showmessage_list.tmpl"; - - try{ - Affelio::App::Admin::Messaging::show_message_list($af, - \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif( $q->url_param("action") eq "compose" ){ - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_composemessage.tmpl"; - - try{ - Affelio::App::Admin::Messaging::compose($af, - $q, - \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif( $q->url_param("action") eq "show" ){ - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_showmessage.tmpl"; - try{ - Affelio::App::Admin::Messaging::mark_as_read($af, - $q->url_param("mid")); - - Affelio::App::Admin::Messaging::show_message($af, - $q->url_param("mid"), - \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }else{ - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_showmessage_list.tmpl"; - - try{ - Affelio::App::Admin::Messaging::show_message_list($af, - \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - -##################################################################### -#Edit skin -##################################################################### -}elsif($admin_mode eq "edit_skins"){ - - use Affelio::App::Admin::EditSkins; - - if( $q->url_param("action") eq "submitcss" ){ - debug_print("admin.cgi: action=[submitcss]"); - try{ - Affelio::App::Admin::EditSkins::save_css($af, $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif( $q->url_param("action") eq "chooseskin" ){ - #Choose skin - debug_print("admin.cgi: action=[chooseskin]"); - try{ - Affelio::App::Admin::EditSkins::choose_skin($af, $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif( $q->url_param("action") eq "backup" ){ - #backup skin - debug_print("admin.cgi: action=[backup]"); - try{ - Affelio::App::Admin::EditSkins::backup($af,$q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif( $q->url_param("action") eq "upload" ){ - #backup skin - debug_print("admin.cgi: action=[upload]"); - try{ - Affelio::App::Admin::EditSkins::upload($af,$q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_edit_skins.tmpl"; - try{ - Affelio::App::Admin::EditSkins::show($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; -##################################################################### -#Edit templates -##################################################################### -}elsif($admin_mode eq "edit_templates"){ - - use Affelio::App::Admin::EditTemplates; - - if( $q->url_param("action") eq "submit" ){ - #Retrieve the latest data from friends' sites. - debug_print("admin.cgi: action=[submit]"); - - try{ - Affelio::App::Admin::EditTemplates::save_templates($af,$q); - Affelio::App::Admin::EditTemplates::rebuild($af); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - }elsif( $q->url_param("action") eq "rebuild" ){ - - #Retrieve the latest data from friends' sites. - debug_print("admin.cgi: action=[rebuild]"); - try{ - Affelio::App::Admin::EditTemplates::rebuild($af); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_edit_templates.tmpl"; - - try{ - Affelio::App::Admin::EditTemplates::show_templates($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - -##################################################################### -#Friends graph -##################################################################### -}elsif($admin_mode eq "friendsgraph"){ - - use Affelio::App::Admin::FriendsGraph; - - if( $q->url_param("action") eq "retrieve" ){ - #Retrieve the latest data from friends' sites. - debug_print("admin.cgi: action=[retrieve]"); - - try{ - Affelio::App::Admin::FriendsGraph::retrieve($af); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_friendsgraph.tmpl"; - try{ - Affelio::App::Admin::FriendsGraph::show_friendsgraph($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; -##################################################################### -#Edit Profile -##################################################################### -}elsif($admin_mode eq "editprofile"){ - - use Affelio::App::Admin::EditProfile; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_editprofile.tmpl"; - - if( $q->url_param("mode2") eq "submit" ){ - #Profile data is being submitted. - debug_print("admin.cgi: mode2=[submit]"); - - try{ - Affelio::App::Admin::EditProfile::save_profile($af,$q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - Affelio::App::Admin::EditProfile::show_profileeditor($af, \%output_data); - -##################################################################### -#Group Member Table -##################################################################### -}elsif($admin_mode eq "group_member_table"){ - - use Affelio::App::Admin::GroupMemberTable; - - debug_print("admin.cgi: mode2=[" . $q->url_param("mode2")); - if($q->url_param("mode2") eq "submit"){ - try{ - save_GroupMember_table($af, $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_groupmember_table.tmpl"; - try{ - show_GroupMember_table($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; -##################################################################### -#Manage Friend -##################################################################### -}elsif($admin_mode eq "manage_friends"){ - - use Affelio::App::Admin::ManageFriend; - - debug_print("admin.cgi: mode2=[" . $q->url_param("mode2")); - if($q->url_param("mode2") eq "delete"){ - try{ - Affelio::App::Admin::ManageFriend::remove_member($af, $q->url_param("uid"), $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managefriends_top.tmpl"; - try{ - Affelio::App::Admin::ManageFriend::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - }elsif($q->url_param("mode2") eq "show_member"){ - ##Show member############# - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managefriends_showmember.tmpl"; - try{ - Affelio::App::Admin::ManageFriend::show_member($af, $q->url_param("uid"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif($q->url_param("mode2") eq "modify_member"){ - ##Modify member########### - - try{ - Affelio::App::Admin::ManageFriend::modify_member($af, $q->url_param("uid"), $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managefriends_showmember.tmpl"; - try{ - Affelio::App::Admin::ManageFriend::show_member($af, $q->url_param("uid"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif($q->url_param("mode2") eq "unsubscribe_group"){ - ##Unsubscribe group####### - - try{ - Affelio::App::Admin::ManageFriend::unsubscribe_group($af, $q->url_param("gid"), $q->url_param("uid")); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managefriends_showmember.tmpl"; - - try{ - Affelio::App::Admin::ManageFriend::show_member($af, $q->url_param("uid"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif($q->url_param("mode2") eq "subscribe_group"){ - ##Subscribe group######### - my @add_group_inputs = $q->param("add_group"); - foreach my $i (@add_group_inputs){ - try{ - Affelio::App::Admin::ManageFriend::subscribe_group($af, $i, $q->url_param("uid")); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managefriends_showmember.tmpl"; - try{ - Affelio::App::Admin::ManageFriend::show_member($af, $q->url_param("uid"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }else{ - ##TOP##################### - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managefriends_top.tmpl"; - - try{ - Affelio::App::Admin::ManageFriend::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - } - -##################################################################### -#Manage Groups -##################################################################### -}elsif($admin_mode eq "manage_groups"){ - - use Affelio::App::Admin::ManageGroup; - - debug_print("admin.cgi: mode2=[" . $q->url_param("mode2")); - if($q->url_param("mode2") eq "show_group"){ - ##Show member############# - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managegroups_showgroup.tmpl"; - try{ - Affelio::App::Admin::ManageGroup::show_group($af, $q->url_param("gid"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif($q->url_param("mode2") eq "rename"){ - ##Modify member########### - try{ - Affelio::App::Admin::ManageGroup::rename_group($af, $q->url_param("gid"), $q->param("new_name")); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managegroups_top.tmpl"; - - try{ - Affelio::App::Admin::ManageGroup::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif($q->url_param("mode2") eq "add_group"){ - try{ - Affelio::App::Admin::ManageGroup::add_group($af, $q->param("new_group_name")); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managegroups_top.tmpl"; - - try{ - Affelio::App::Admin::ManageGroup::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - }elsif($q->url_param("mode2") eq "remove_group"){ - try{ - Affelio::App::Admin::ManageGroup::remove_group($af, $q->url_param("gid"), $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managegroups_top.tmpl"; - try{ - Affelio::App::Admin::ManageGroup::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - - }else{ - ##TOP##################### - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_managegroups_top.tmpl"; - try{ - Affelio::App::Admin::ManageGroup::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - -##################################################################### -#Access Control -##################################################################### -}elsif($admin_mode eq "access_control"){ - - use Affelio::App::Admin::AccessControl; - - if($q->url_param("mode2") eq "submit"){ - try{ - save_GroupAttribute_table($af, $q); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_accesscontrol.tmpl"; - - try{ - show_GroupAttribute_table($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - -##################################################################### -#Application Access Control -##################################################################### -}elsif($admin_mode eq "access_control_apps"){ - - use Affelio::App::Admin::ManageApplication; - - if($q->url_param("mode2") eq "modify_app"){ - ##Show app############# - - try{ - Affelio::App::Admin::ManageApplication::save_permission($af, $q, $q->url_param("app_name")); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_accesscontrol_apps_showapp.tmpl"; - try{ - Affelio::App::Admin::ManageApplication::show_app($af, $q->url_param("app_name"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }elsif($q->url_param("mode2") eq "show_app"){ - ##Show app############# - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_accesscontrol_apps_showapp.tmpl"; - try{ - Affelio::App::Admin::ManageApplication::show_app($af, $q->url_param("app_name"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - }else{ - ##TOP##################### - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_accesscontrol_apps_top.tmpl"; - - try{ - Affelio::App::Admin::ManageApplication::manage_top($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - } - - -##################################################################### -#Send Invitation -##################################################################### -}elsif($admin_mode eq "send_invitation"){ - - use Affelio::App::Admin::SendInvitation; - try{ - send_invitation($af, $q->param("dest_address"), \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_top.tmpl"; - - -##################################################################### -#Send Handshake -##################################################################### -}elsif($admin_mode eq "send_handshake"){ - - use Affelio::App::Admin::SendHandshake; - try{ - Affelio::App::Admin::SendHandshake::send($af, $q, \%output_data); - }catch Error with{ - my $e = shift; - $err_msg='<AF_M text="Error in handshaking"><BR>' . $e; - }; - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/handshake_sent.tmpl"; - -##################################################################### -#MyStatus -##################################################################### -}elsif($admin_mode eq "post_mystatus"){ - - use Affelio::App::Admin::MyStatus; - - try{ - Affelio::App::Admin::MyStatus::post($af, $q->param("my_currentstatus")); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - - $HTTP_forward_flag = 1; - $forward_URL = "$af->{site__web_root}/admin.cgi"; - - -##################################################################### -#Top -##################################################################### -}else{ - - $TMPL_FILE = "$af->{site__fs_root}/templates/" . - "$af->{site__template}/owner_side/admin_top.tmpl"; - - use Affelio::App::Admin::AffelioNews; - try{ - Affelio::App::Admin::AffelioNews::getnews($af, \%output_data); - }catch Error with{ - my $e = shift; $err_msg .= $e->stacktrace; - }; - -}#if - - -############################################################################ -#Output View -############################################################################ -if( $HTTP_forward_flag==1 ){ - print "Location: $forward_URL", "\n\n"; - -}else{ - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print get_HTML_header(); - - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - foreach my $data_key (keys(%output_data)) { - $tmpl->param($data_key => $output_data{$data_key}); - #debug_print("$data_key ... $output_data{$data_key}"); - } - $tmpl->param("err_msg" => $err_msg); - $tmpl->param("ret_msg" => $ret_msg); - $tmpl->param("site__locale" => $af->{site__locale}); - - print $af->translate_templateL10N($tmpl->output); - - print get_HTML_footer(); -} - - - -#################### -#Hmmmmmm -#################### - - ###################################################################### - #Get_HTML_header - ###################################################################### - sub get_HTML_header{ - my $self = shift; - my $app__page_title = shift; - -# my $af = $self->{af}; - - #Set template file name - my $TMPL_FILE = "$af->{site__fs_root}/templates_dyn/_header.tmpl"; - #Set data for template - my %output_data = (); - $output_data{'app__css_path'} = $af->{site__web_root}."/templates/default/owner_side"; - $output_data{'app__page_title'} = "Affelio Owner's page"; - $output_data{"site__skin_dir"} = $af->{site__web_root} . "/skins/" . $af->{userpref__skin}; - $output_data{'site__web_root'} = $af->{site__web_root}; - $output_data{'site__locale'} = $af->{site__locale}; - - $af->get_module_list(\%output_data, $af->{site__web_root},"self"); - $af->get_guest_owner_list(\%output_data); - - #Initiate Template - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - foreach my $data_key (keys(%output_data)) { - debug_print("$data_key = $output_data{$data_key}"); - $tmpl->param($data_key => $output_data{$data_key}); - } - - my $final_out = $af->translate_templateL10N($tmpl->output) - . '<div class="afMain">' . "\n"; - - return($final_out); - - } - - ###################################################################### - #get_HTML_footer - ###################################################################### - sub get_HTML_footer{ - my $self = shift; -# my $af = $self->{af}; - - #Set template file name - my $TMPL_FILE = "$af->{site__fs_root}/templates_dyn/_footer.tmpl"; - my $tmpl = new HTML::Template(filename => $TMPL_FILE); - - my $final_out = "</div><!--afPubMain-->" - . $af->translate_templateL10N($tmpl->output); - - return($final_out); - } - - - - Index: affelio_farm/admin/skelton/affelio/incoming.cgi diff -u affelio_farm/admin/skelton/affelio/incoming.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/incoming.cgi:removed --- affelio_farm/admin/skelton/affelio/incoming.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/incoming.cgi Tue Oct 25 04:20:42 2005 @@ -1,226 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: incoming.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use lib("./extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Error qw(:try); - -use lib("./lib"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::Debug qw(debug_print); -use Affelio::misc::Time qw(get_timestamp get_expire_stamp); -use Affelio::misc::MyCrypt qw(msg_decrypt url_decode); -use Affelio::misc::NetMisc; -use Affelio::SNS::Handshaker_c; -use Affelio::misc::WebInput; - -debug_print("incoming.cgi: start."); -my $q = new CGI; - -############################################################################ -#Load Affelio, CGI -############################################################################ -my $cfg_dir = "./config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e); -}; -my $wi = new Affelio::misc::WebInput(); -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -debug_print("incoming.cgi: sid from cookie = $sid"); -my $session=""; -if($sid){ - $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); -} - -############################################################################ -#Get args -############################################################################ -my $forward_id = $q->url_param("forward_id"); -my $referrer = $q->param("referrer"); -debug_print("incoming.cgi: forward_id =$forward_id"); - -############################################################################ -#Load Friend manager and get passAB -############################################################################ -my $passAB; -try{ - $passAB = $af->{fm}->get_attribute_by_afid($referrer, "password"); -}catch Error with{ - my $e = shift; - error($q, "Error from FriendManager.\n" . $e); -}; -debug_print("incoming.cgi: passAB=$passAB\n"); -if(!defined($passAB) || $passAB eq ""){ - error($q, "Affelio: Invalid forwarding. Shared key not found!"); -} - - -############################################################################ -#Decrypt the forward_id message; -############################################################################ -my ($FID_timestamp, $FID_expire, $FID_remoteip, $FID_visitorAFID, $FID_visitor_nickname, $FID_visitor_type) - =split('\*', msg_decrypt( url_decode($forward_id), $passAB ) ); - -$FID_visitorAFID = url_decode($FID_visitorAFID); -$FID_visitor_nickname = url_decode($FID_visitor_nickname); - -debug_print("incoming.cgi: timestamp =$FID_timestamp"); -debug_print("incoming.cgi: expire =$FID_expire"); -debug_print("incoming.cgi: remote_ip =$FID_remoteip"); -debug_print("incoming.cgi: visitor_afid =$FID_visitorAFID"); -debug_print("incoming.cgi: visitor_nickname =$FID_visitor_nickname"); -debug_print("incoming.cgi: visitor_type(original) =$FID_visitor_type"); - -if((my $i=index($FID_visitor_type, "self"))==0){ - $FID_visitor_type = "f1"; -}elsif((my $i=index($FID_visitor_type, "f1"))==0){ - $FID_visitor_type = "f2"; -}else{ - $FID_visitor_type = "pb"; -} -debug_print("incoming.cgi: visitor_type(decreased) =$FID_visitor_type"); - - -############################################################################ -#Error detection -############################################################################ -my $errormsg=""; -if(($FID_timestamp eq "") || ($FID_remoteip eq "") || - ($FID_visitorAFID eq "") || ($FID_expire eq "") || - ($FID_visitor_type eq "") ){ - $errormsg .= "Forward_Id data is invalid! \n"; -}else{ - if($FID_remoteip ne $q->remote_addr){ - $errormsg .= "Your remote IP address does not match! \n"; - } - if($FID_expire < get_timestamp() ){ - $errormsg .= "This forward_id is too late to start. \n"; - } -} -if($errormsg){ - #error $errormsg; - debug_print("incoming.cgi: ERROR! : $errormsg"); - debug_print("incoming.cgi: Just go to my Affelio without any cookie."); - print $q->redirect( -url => $af->{site__web_root}); -} - -############################################################################ -#Check current session -############################################################################ -#If a cookie is set already, check it and reuse it if we can. -my $ck_visitor_type="pb"; -my $ck_visitor_nickname="anonymous"; -my $ck_visitor_afid=""; -if($session){ - debug_print("incoming.cgi: Found a pre-existing session!"); - $ck_visitor_type = $session->param("type"); - $ck_visitor_nickname = $session->param("user_nickname"); - $ck_visitor_afid = $session->param("user_afid"); -} -debug_print("incoming.cgi: cookie visitor_type = $ck_visitor_type"); -debug_print("incoming.cgi: cookie visitor_nickname = $ck_visitor_nickname"); -debug_print("incoming.cgi: cookie visitor_afid = $ck_visitor_afid"); - -if($session && - ( (($ck_visitor_type eq "self") && ( $FID_visitor_type ne "self") ) - || ( ($ck_visitor_type eq "f1") && - (( $FID_visitor_type eq "f2") || ( $FID_visitor_type eq "pb") ) ) - || ( ($ck_visitor_type eq "f2") && ( $FID_visitor_type eq "pb") ) - ) - ){ - ######################### - # OK. - # This visitor is already authenticated as a closer visitor. - # Use existing session. - ######################### - debug_print("incoming.cgi: OK. You already have a cookie, and"); - debug_print("incoming.cgi: the existing session has higher right!"); - debug_print("incoming.cgi: end. Forwarding to my homepage."); - print $q->redirect( -url => $af->{site__web_root}); - -}else{ - ######################### - # Startup a new session - ######################### - debug_print("incoming.cgi: You don't have a cookie, or you have"); - debug_print("incoming.cgi: a cookie with the same or lower rights."); - debug_print("incoming.cgi: "); - debug_print("incoming.cgi: Let's start up a session with a cooike."); - - #lookup our friend table with FID_visitorAFID - my $tmp1; - try{ - $tmp1 = $af->{fm}->get_attribute_by_afid($FID_visitorAFID, "password"); - }catch Error with{ - my $e = shift; - error($q, "Error from FriendManager.\n" . $e); - }; - if($tmp1 ne ""){ $FID_visitor_type="f1"; } - - #Start up a sesion - my $ss = new CGI::Session("driver:File", - undef, - {Directory=> $af->{site__session_dir}}); - #Set values into session - $ss->param("user_afid", $FID_visitorAFID); - $ss->param("user_nickname", $FID_visitor_nickname); - $ss->param("type", $FID_visitor_type); - #current time - #expire time - $ss->expire('+1h'); - - debug_print("incoming.cgi: startup_session finished.\n"); - - #Retrieve a sesion_id - my $session_id = $ss->id(); - debug_print("incoming.cgi: session_id = [$session_id]\n"); - - #Prepare a cookie with the session_id - my $cookie = $q->cookie ( -name => "affelio-$af->{user__nickname}", - -value => $session_id, - -path => URL2path($af->{site__web_root})); - - debug_print("incoming.cgi: new cookie [$session_id]\n"); - debug_print("incoming.cgi: new cookie [" . URL2domain($af->{site__web_root}) . "]\n"); - debug_print("incoming.cgi: new cookie [" . URL2path($af->{site__web_root}) . "]\n"); - debug_print("incoming.cgi: New session has been established."); - debug_print("incoming.cgi: user_type: " . $ss->param("type") ); - debug_print("incoming.cgi: user_afid: " . $ss->param("user_afid") ); - debug_print("incoming.cgi: user_nickname:" . $ss->param("user_nickname") ); - - debug_print("incoming.cgi: end. Forwarding to my homepage."); - print $q->redirect( -url => $af->{site__web_root}, - -cookie => $cookie); -} - -exit(1); Index: affelio_farm/admin/skelton/affelio/index.cgi diff -u affelio_farm/admin/skelton/affelio/index.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/index.cgi:removed --- affelio_farm/admin/skelton/affelio/index.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/index.cgi Tue Oct 25 04:20:42 2005 @@ -1,265 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: index.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use lib("./extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Error qw(:try); - -use lib("./lib"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::Debug qw(debug_print); -use Affelio::misc::NetMisc; -use Affelio::misc::Time; -use Affelio::misc::WebInput; -use Affelio::SNS::Handshaker_c; - -debug_print("index.cgi: start."); -my $q = new CGI; - -############################################################################ -#Load Affelio -############################################################################ -my $wi = new Affelio::misc::WebInput(); -my $cfg_dir = "./config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e); -}; - -############################################################################ -#Check session w/ cookie -############################################################################ -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -debug_print("index.cgi: sid from cookie = $sid"); -my $session; -if($sid){ - $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); -} - -my $visitor_type="pb"; -my $visitor_nickname="anonymous"; -my $visitor_afid=""; - -if($session){ - $visitor_type - = $wi->PTN_visitor_type($session->param("type")); - $visitor_nickname - = $wi->PTN_nickname($session->param("user_nickname")); - - $visitor_afid - = $wi->PTN_URL($session->param("user_afid")); -} -if($visitor_type eq ""){ - $visitor_type="pb"; - $visitor_nickname="anonymous"; -} -debug_print("index.cgi: visitor_type= $visitor_type"); -debug_print("index.cgi: visitor_nickname= $visitor_nickname"); -debug_print("index.cgi: visitor_afid= $visitor_afid"); - - -############################################################################ -#Main -############################################################################ -my %output_data = (); -my $TMPL_FILE =""; - -###################################################### -#Template file -###################################################### -my $mode = $wi->PTN_mode($q->url_param("mode")); -debug_print("================$mode"); - -if(($mode eq "") || !defined($mode)){ - #If "mode" is not set, we will look at $self->{userpref__toppage_app_path} - #value. - my $abs_next_URL = $af->{site__web_root} . "/" . $af->{userpref__toppage_app_path}; - - print "Location: $abs_next_URL", "\n\n"; - exit(1); -} -$TMPL_FILE = "$af->{site__fs_root}/templates_dyn/" . $mode . ".tmpl"; - - -###################################################### -#Data prep (1) -###################################################### - -################# -#Site info -################# -$output_data{"site__web_root"} = $af->{site__web_root}; -$output_data{"site__skin_dir"} = $af->{site__web_root} . "/skins/" . $af->{userpref__skin}; -$output_data{"site__locale"} = $af->{site__locale}; - -try{ - $af->get_module_list(\%output_data, $visitor_afid, $visitor_type); - $af->get_guest_owner_list(\%output_data); -}catch Error with{ - my $e = shift; - error($q, "Affelio init error.\n" . $e); -}; - - -################# -#Client info -################# -$output_data{'client_afid'}= $visitor_afid; -# -my $relation; -if($visitor_type eq "self"){ - $relation = $af->{lh}->maketext("_VISITOR_TYPE_SELF"); -}elsif($visitor_type eq "f1"){ - $relation = $af->{lh}->maketext("_VISITOR_TYPE_F1"); -}elsif($visitor_type eq "f2"){ - $relation = $af->{lh}->maketext("_VISITOR_TYPE_F2"); -}else{ - $relation = $af->{lh}->maketext("_VISITOR_TYPE_PB"); -} -$output_data{'client_relationship'}= $relation; - -$output_data{'client_type'}= $visitor_type; -$output_data{'client_nickname'}= $visitor_nickname; -$output_data{'client_type_' . $visitor_type}= "true"; - -################# -#Default profile info -################# -$output_data{'profile_nickname'} = $af->{user__nickname}; -$output_data{"profile_intromesg1"} = $af->{user__intromesg1}; -$output_data{'profile_myimage_path'} = - "./bin/get_content.cgi?module=core&content=/profile/profile_face.jpg"; - -###################################################### -#Data prep from Models -###################################################### -#Inject Profile Data -use Affelio::App::ShowProfile; -try{ - Affelio::App::ShowProfile::show_profile($af, - \%output_data, - $visitor_type, - $visitor_afid); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; - -#Friendlist -use Affelio::App::FriendRoutines; -my @friendlist_5; -try{ - @friendlist_5 = get_friends_list($af, $visitor_afid, $visitor_type, 5); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_5"} = \@friendlist_5; - -my @friendlist_5_IF; -try{ - @friendlist_5_IF = get_friends_list_IF($af,$visitor_afid, $visitor_type,5); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_5_IF"} = \@friendlist_5_IF; - -my @friendlist_all; -try{ - @friendlist_all = get_friends_list($af, $visitor_afid, $visitor_type, -1); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_all"} = \@friendlist_all; - -my @friendlist_all_IF; -try{ - @friendlist_all_IF=get_friends_list_IF($af,$visitor_afid,$visitor_type,-1); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_all_IF"} = \@friendlist_all_IF; - -try{ - $output_data{"friend__F1count"} = $af->{fm}->get_F1_count(); - $output_data{"friend__F2count"} = $af->{fm}->get_F2_count(); -}catch Error with{ - my $e = shift; - error($q, "Affelio: error from FriendManager\n" . $e); -}; - -########################################################################### -#Inject data into template -########################################################################### -my $tmpl; -try{ - $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); -}catch Error with{ - my $e = shift; - error($q, "Affelio: error in HTML::Template init.\n" . $e); -}; - -foreach my $data_key (keys(%output_data)) { - debug_print("index.cgi: $data_key = $output_data{$data_key}"); - $tmpl->param($data_key => $output_data{$data_key}); -} - -########################################################################### -#AccessLog -########################################################################### -if($visitor_type ne "self"){ - my $afid; - if($visitor_afid eq ""){ - $afid = $q->remote_host; - }else{ - $afid = $visitor_afid; - } - - try{ - $af->{alm}->save_log($afid, $visitor_nickname, $visitor_type); - }catch Error with{ - my $e = shift; - error($q, "Affelio: error in AccessLogging\n" . $e); - }; - -} - -########################################################################### -#Output -########################################################################### -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; -print $af->translate_templateL10N($tmpl->output); Index: affelio_farm/admin/skelton/affelio/outgoing.cgi diff -u affelio_farm/admin/skelton/affelio/outgoing.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/outgoing.cgi:removed --- affelio_farm/admin/skelton/affelio/outgoing.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/outgoing.cgi Tue Oct 25 04:20:42 2005 @@ -1,198 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: outgoing.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use lib("./extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Error qw(:try); - -use lib("./lib"); -use Affelio; -use Affelio::SNS::Handshaker_c; -use Affelio::misc::CGIError; -use Affelio::misc::Debug; -use Affelio::misc::Time; -use Affelio::misc::MyCrypt; -use Affelio::misc::NetMisc; -use Affelio::misc::WebInput; - -debug_print("outgoing.cgi: start.\n"); -my $q = new CGI; - -############################################################################ -#Load Affelio -############################################################################ -my $cfg_dir = "./config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e); -}; -my $wi = new Affelio::misc::WebInput(); - -############################################################################ -#Check session w/ cookie -############################################################################ -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -my $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - -my $visitor_type="pb"; -my $visitor_nickname="anonymous"; -my $visitor_afid=""; - -if($session){ - $visitor_type = $session->param("type"); - $visitor_nickname = $session->param("user_nickname"); - $visitor_afid = $session->param("user_afid"); -} -debug_print("outgoing.cgi: visitor_type= $visitor_type"); -debug_print("outgoing.cgi: visitor_nickname= $visitor_nickname"); -debug_print("outgoing.cgi: visitor_afid= $visitor_afid"); - -############################################################################ -#Main -############################################################################ - -######################################### -# Retrieve user's IP current address -my $user_addr = $q->remote_addr; -my $user_addr_is_private = check_private_IP_addr($user_addr); -debug_print("outgoing.cgi: user's IP= $user_addr\n"); -debug_print("outgoing.cgi: user's IP privateflag= $user_addr_is_private\n"); - -######################################### -# Retrieve destination URL -my $dest_URL = $wi->PTN_URL($q->param("dest_url")); -debug_print("outgoing.cgi: dst_URL=$dest_URL"); - -######################################### -# retrieve passAB -my $passAB=""; -try{ - $passAB = $af->{fm}->get_attribute_by_afid($dest_URL, "password"); -}catch Error with{ - my $e = shift; - error($q, "Error from FriendManager.\n" . $e); -}; -debug_print("outgoing.cgi: passAB=$passAB\n"); -if(!defined($passAB) || $passAB eq ""){ - print $q->redirect($dest_URL); - exit(1); -} - -######################################### -# Put this forwarding information into my DB -# so that we can logout this session in the future. -# XXX - -######################################### -#Output HTTP reply (Location header). -# -# Location-header: -# http://siteB.com/bin/incoming.cgi?session=(1)&referrer=(2) -# -#1.PassAB(timestamp, -# expire, -# browser's IP, -# AF_ID, Who is accessing? -# nickname, Who is accessing? -# type) -# -#2.URL(A) Where is this forwarding from? - -my $plain_msg = ""; -if($visitor_type eq "self"){ - $plain_msg = get_timestamp() . "*" . - get_expire_stamp(1,0,0) . "*" . - $q->remote_addr . "*" . - url_encode($visitor_afid) . "*" . - url_encode($visitor_nickname) . "*" . - "self" .'*'; -}elsif($visitor_type eq "f1"){ - $plain_msg = get_timestamp() . "*" . - get_expire_stamp(1,0,0) . "*" . - $q->remote_addr . "*" . - url_encode($visitor_afid) . "*" . - url_encode($visitor_nickname) . "*" . - "f1" . '*'; -}elsif($visitor_type eq "f2"){ - $plain_msg = get_timestamp() . "*" . - get_expire_stamp(1,0,0) . "*" . - $q->remote_addr . "*" . - url_encode($visitor_afid) . "*" . - url_encode($visitor_nickname) . "*" . - "f2" . '*'; -}else{ - $plain_msg = get_timestamp() . "*" . - get_expire_stamp(1,0,0) . "*" . - $q->remote_addr . "*" . - url_encode($visitor_afid) . "*" . - url_encode($visitor_nickname) . "*" . - "pb" . '*'; -} -debug_print("outgoing.cgi: plain_msg= $plain_msg\n"); - -#Encrypt -my $cipher_msg = url_encode( msg_encrypt( $plain_msg, $passAB ) ); -debug_print("outgoing.cgi: cipher_msg= $cipher_msg\n"); - -#Build up URL -my $forwarding_to = "$dest_URL/incoming.cgi?" - . "forward_id=$cipher_msg" - . "&" - . "referrer=$af->{site__web_root}"; -debug_print("outgoing.cgi: forwarding_to= $forwarding_to\n"); - - -############################################################################ -#Output -############################################################################ -if($user_addr_is_private){ - #This access is from some private IP address. - #It means the user may have some problem in - #session forwarding when the user is forwarded - #to the destination Affelio. So warn the user. - - my $TMPL_FILE = "$af->{site__fs_root}/templates/$af->{site__template}/" - ."owner_side/outgoing_warn.tmpl"; - - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - - my $warning_message = "<AF_M text='_SYS_WARN_OUTGOING_PRIV_IP' param='$user_addr'><P><A HREF=\"$forwarding_to\">Destination Affelio</A>: <AF_M text='_SYS_WARN_OUTGOING_PRIV_IP2'>"; - $tmpl->param(message => $warning_message); - $tmpl->param(forwarding_to => $forwarding_to); - $tmpl->param(tmpl_path => "$af->{site__web_root}/templates/$af->{site__template}/owner_side/"); - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print $af->translate_templateL10N($tmpl->output); - -}else{ - print $q->redirect($forwarding_to); -} Index: affelio_farm/admin/skelton/affelio/setup.cgi diff -u affelio_farm/admin/skelton/affelio/setup.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/setup.cgi:removed --- affelio_farm/admin/skelton/affelio/setup.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/setup.cgi Tue Oct 25 04:20:42 2005 @@ -1,572 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: setup.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use Cwd; -use DBI; -use lib("./extlib"); -use HTML::Template; -use Error qw(:try); - -use lib("./lib"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::MyCrypt; -use Affelio::misc::L10N; -use Affelio::misc::InitAffelio; -use Affelio::misc::Debug qw(debug_print); - -############################################################################ -#Main -############################################################################ -my $g_username=""; -my $g_password=""; -my $g_nickname=""; -my $g_email=""; -my $g_crypted_password=""; -my $cgi = new CGI; -my $g_fsroot = cwd(); -my $g_webroot = $cgi->self_url(); -my $g_lh = ""; -my $g_locale =""; -my $g_actionurl=""; -my $g_btn_name_accept=""; -my $g_err=""; -my $g_msg=""; -my $g_img=""; -my $g_title=""; -my $TMPL_FILE=""; -my %output_data=(); - -$g_webroot =~ s|/setup\.cgi.*||; -$g_locale = $cgi->param("locale"); - -my $g_stage = $cgi->url_param("stage"); -if($g_stage eq "") { $g_stage =0}; - -if($g_locale ne ""){ - load_locale($g_locale); -} - -############################################ -if($g_stage ==0){ - show_0(); - -}elsif($g_stage ==10){ - show_10(); - - -}elsif($g_stage ==30){ - show_30(); - -}elsif($g_stage ==50){ - show_50(); - -}elsif($g_stage ==100){ - $g_err= check_50(); - if($g_err ne ""){ - show_50(); - }else{ - show_100(); - } - -}elsif($g_stage ==200){ - $g_err= check_100(); - if($g_err ne ""){ - show_100(); - }else{ - show_200(); - } - -}elsif($g_stage ==350){ - $g_err= check_200(); - if($g_err ne ""){ - show_200(); - }else{ - show_350(); - } - -}elsif($g_stage ==400){ - $g_err= check_350(); - if($g_err ne ""){ - show_350(); - }else{ - show_400(); - } - -}elsif($g_stage==500){ - $g_err= check_400(); - if($g_err ne ""){ - show_400(); - }else{ - show_500(); - } -} - -######################################### -#HTML::Template processing -######################################### -%output_data = ("msg", $g_msg, - "title", $g_title, - "btn_name_accept", $g_btn_name_accept, - "err_msg", $g_err, - "tmpl_path", "$g_webroot/templates/default/owner_side", - "locale", $g_locale, - "action_url", $g_actionurl, - "img_filename", $g_img - ); - -my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); -foreach my $data_key (keys(%output_data)) { - $tmpl->param($data_key => $output_data{$data_key}); -} -my $out_msg = $tmpl->output; - -######################################### -#<AF_M> L10N Template processing -######################################### -$out_msg = translate_templateL10N_for_setup($out_msg); - -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; -print $out_msg; -exit(1); - - - -############################################################################ -#Sub routines -############################################################################ -sub show_0{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_0.tmpl"; - $g_title =""; - $g_msg=""; - $g_img= "0.gif"; - $g_actionurl="setup.cgi?stage=10"; -} - -######################################### -sub show_10{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_10"); - $g_msg= $g_lh->maketext("_SETUP_msg_10"); - $g_img= "10.jpg"; - $g_actionurl="setup.cgi?stage=30"; -} - -######################################### -sub show_30{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_30"); - $g_msg= $g_lh->maketext("_SETUP_msg_30"); - $g_img= "30.jpg"; - $g_btn_name_accept="true"; - $g_actionurl="setup.cgi?stage=50"; -} - -######################################### -sub show_50{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_50"); - $g_msg= msg_50(); - $g_img= "50.jpg"; - $g_actionurl="setup.cgi?stage=100"; -} - -sub msg_50{ - my $msg = $g_lh->maketext("_SETUP_msg_50_1"); - $msg .= '<blockquote>'; - $msg .= check_module("CGI"); - $msg .= check_module("CGI::Session"); - $msg .= check_module("LWP"); - $msg .= check_module("URI"); - $msg .= check_module("DBI"); - $msg .= $g_lh->maketext("_SETUP_msg_50_3"); - $msg .= check_module("DBD::SQLite"); - $msg .= check_module("DBD::mysql"); - $msg .= '</blockquote>'; - $msg .= $g_lh->maketext("_SETUP_msg_50_2"); -} - -sub check_50{ - my $err=0; - my $err_msg=""; - - $err += load_module("CGI"); - $err += load_module("CGI::Session"); - $err += load_module("LWP"); - $err += load_module("URI"); - $err += load_module("DBI"); -# my $err_sqlite = load_module("DBD::SQLite"); -# my $err_mysql = load_module("DBD::mysql"); - - if($err < 0){ - $err_msg = $g_lh->maketext("_SETUP_check_50_err1"); - } - return $err_msg; -} - -######################################### -sub show_100{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_100"); - $g_msg= $g_lh->maketext("_SETUP_msg_100"); - $g_img= "100.jpg"; - $g_actionurl="setup.cgi?stage=200"; -} - -sub check_100{ - my $err_msg=""; - - if(! -w "config"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "config"); - } - if(! -w "userdata"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "userdata"); - } - if(! -r "userdata"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err5", "userdata"); - } - if(! -w "session"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "session"); - } - if(! -r "session"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err5", "session"); - } - if(! -w "skins"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "skins"); - } - if(! -r "skins"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err5", "skins"); - } - if(! -w "templates_dyn"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err4", "templates_dyn"); - } - if(! -r "templates_dyn"){ - $err_msg .= $g_lh->maketext("_SETUP_check_100_err5", "templates_dyn"); - } - if($err_msg ne ""){ - return $err_msg; - } - - #make userdata/xxxxx session/yyyy directories - Affelio::misc::InitAffelio::create_userdir("./"); - - return(""); -} - -######################################### -sub show_200{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_200"); - $g_msg= msg_200(); - $g_img= "200.jpg"; - $g_actionurl="setup.cgi?stage=350"; -} - -sub msg_200{ - my $sendmail_path=""; - if(-f "/usr/sbin/sendmail"){ - $sendmail_path = "/usr/sbin/sendmail"; - } - if(-f "/usr/lib/sendmail"){ - $sendmail_path = "/usr/lib/sendmail"; - } - - my $msg = $g_lh->maketext("_SETUP_msg_200"); - $msg .= '<P><TABLE BORDR="0"><TR><TD>Sendmail: </TD>'; - $msg .= '<TD><INPUT TYPE="text" NAME="sendmail_path" SIZE="40" VALUE="'; - $msg .= $sendmail_path; - $msg .= '"></TD></TR>'; - $msg .= '</TABLE>'; - return($msg); -} - -sub check_200{ - my $err_msg=""; - - my $sendmail_path = $cgi->param("sendmail_path"); - if(-f $sendmail_path){ - }else{ - $err_msg .= $g_lh->maketext("_SETUP_check_200_err1", $sendmail_path); - return $err_msg; - } - - Affelio::misc::InitAffelio::create_af_cfg("$g_fsroot/config/affelio.cfg", - $g_fsroot, - $g_webroot, - $g_locale, - "default", - $sendmail_path); - chmod 0700, "$g_fsroot/config"; - return(""); -} - -######################################### -sub show_350{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_350"); - $g_msg= $g_lh->maketext("_SETUP_msg_350"); - $g_img= "350.jpg"; - $g_actionurl="setup.cgi?stage=400"; -} - -sub check_350{ - my $db_type = $cgi->param("dbtype"); - my $db_dbname =""; - my $db_username =""; - my $db_password = ""; - my $db_hostname =""; - my $db_port =""; - - if((!$db_type) || ($db_type eq "")){ - return("invlalid input."); - } - if($db_type eq "mysql"){ - if(load_module("DBD::mysql") < 0){ - return("Perl module not found."); - } - $db_dbname = $cgi->param("mysql_dbname"); - $db_username = $cgi->param("mysql_username"); - $db_password = $cgi->param("mysql_password"); - $db_hostname = $cgi->param("mysql_hostname"); - $db_port = $cgi->param("mysql_port"); - }else{ - if(load_module("DBD::SQLite") < 0){ - return("Perl module not found."); - } - } - - #determine userdata/xxx/ directory - my $userdata_dir = ""; - try{ - $userdata_dir = Affelio::misc::InitAffelio::get_userdir("./userdata"); - }catch Error with{ - my $e = shift; - error $cgi, "Error in check350: $e"; - }; - - debug_print("check_350: userdata dir = [$userdata_dir]"); - - #Generate db.cfg file - try{ - Affelio::misc::InitAffelio::create_db_cfg("$userdata_dir/db.cfg", - $db_type, - $db_dbname, - $db_username, - $db_password, - $db_hostname, - $db_port); - }catch Error with{ - my $e = shift; - error $cgi, "Error in check350: $e"; - }; - - return(""); -} - -######################################### -sub show_400{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_400"); - $g_msg= $g_lh->maketext("_SETUP_msg_400"); - $g_img= "400.jpg"; - $g_actionurl="setup.cgi?stage=500"; -} - -sub check_400{ - $g_username = $cgi->param("username"); - $g_password = $cgi->param("password"); - $g_nickname = $cgi->param("nickname"); - $g_email = $cgi->param("email"); - - ########################################################## - #Input check - ########################################################## - my @salts = ( "A".."Z", "a".."z", "0".."9", ".", "/" ); - my $salt = $salts[int(rand(64))] . $salts[int(rand(64))]; - try{ - $g_crypted_password = crypt($g_password, $salt); - }catch Error with{ - my $e = shift; - error($cgi, "Check400-1: password generation : $e"); - }; - - ########################################################## - #Determine userdata/..../ directory - ########################################################## - #determine userdata/xxx/ directory - my $userdata_dir = ""; - try{ - $userdata_dir = Affelio::misc::InitAffelio::get_userdir("./userdata"); - }catch Error with{ - my $e = shift; - error $cgi, "Error in check400-2: $e"; - }; - - ########################################################## - #Create login.cfg - ########################################################## - try{ - Affelio::misc::InitAffelio::create_login_cfg("$userdata_dir/login.cfg", - $g_username, - $g_crypted_password); - }catch Error with{ - my $e = shift; - error $cgi, "Error in check400-8: $e"; - }; - - ########################################################## - #Copy default files to user directory - ########################################################## - try{ - Affelio::misc::InitAffelio::copy_def_files(".", - $userdata_dir, - $g_locale); - }catch Error with{ - my $e = shift; - error($cgi, "Error in copying default files: $e"); - }; - - ########################################################## - #DB initialization - ########################################################## - try{ - Affelio::misc::InitAffelio::init_db(".", - $g_nickname, - $g_email, - $g_lh); - }catch Error with{ - my $e = shift; - error($cgi, "Error in init_db: $e"); - }; - - ########################################################## - #Rebuild templates_dyn - ########################################################## - use Affelio::App::Admin::EditTemplates qw(rebuild); - my $af; - try{ - $af = new Affelio(ConfigDir => "./config/"); - Affelio::App::Admin::EditTemplates::rebuild($af); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-36: Template rebuild error: $e"; - }; - - ########################################################## - #Check and set data directory permission - ########################################################## - try{ - Affelio::misc::InitAffelio::set_datadir_perm("."); - }catch Error with{ - my $e = shift; - error $cgi, "Check400-37: $e"; - }; - return(""); -} - -######################################### -sub show_500{ - $TMPL_FILE = "$g_fsroot/templates/default/owner_side/setup_1.tmpl"; - $g_title= $g_lh->maketext("_SETUP_title_500"); - $g_msg= $g_lh->maketext("_SETUP_msg_500", $g_webroot); - $g_img= "500.jpg"; - $g_actionurl=""; -} - - -######################################### -#Perl module -######################################### -sub check_module{ - my $mod_name = shift; - my $mod_ver=""; - my $err=0; - - $err = load_module($mod_name); - if ($err < 0) { - return( $g_lh->maketext("_SETUP_err_module_notfound", $mod_name) ); - } else { - $mod_ver = $mod_name->VERSION; - return( $g_lh->maketext("_SETUP_module_found", $mod_name, $mod_ver) ); - } -} - -sub load_module{ - my $mod_name = shift; - - $mod_name =~ s!::!/!g; - eval { - require "$mod_name.pm"; - }; - if($@){ - return -1; - }else{ - return 0; - } -} - -######################################### -#Locale -######################################### -sub load_locale{ - my $locale_name = shift; - $g_lh = Affelio::misc::L10N->get_handle(($locale_name)); - error $cgi, "Couldn't make a language handle. \n$@" unless $g_lh; -} - -sub translate_templateL10N_for_setup { - #my $af=shift; - my $mesg = shift; - - my $tag_body =""; - my $text_value=""; - my $param_value=""; - - while( $mesg =~ /<AF_M ([^>]+)>/ ){ - $tag_body = $1; - - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["'](\s*)param(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - $param_value=$7; - if($text_value eq ""){ - $tag_body =~ /text(\s*)=(\s*)["']([^"']*)["']/; - $text_value=$3; - } - - #print "[$tag_body]\n"; - #print "[$text_value]\n"; - #print "[$param_value]\n"; - - my $sbst = $g_lh->maketext($text_value, $param_value); - - $mesg =~ s/<AF_M $tag_body>/$sbst/g; - } - - return($mesg); -} - - Index: affelio_farm/admin/skelton/affelio/upgrade-0954-10RC1.cgi diff -u affelio_farm/admin/skelton/affelio/upgrade-0954-10RC1.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/upgrade-0954-10RC1.cgi:removed --- affelio_farm/admin/skelton/affelio/upgrade-0954-10RC1.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/upgrade-0954-10RC1.cgi Tue Oct 25 04:20:42 2005 @@ -1,74 +0,0 @@ -#!/usr/bin/perl - -use strict; - -use CGI qw(-unique_headers); -use Cwd; -use DBI; -use lib("./extlib"); -use HTML::Template; -use Error qw(:try); -use lib("./lib"); -use Affelio; -use Affelio::misc::MyCrypt; -use Affelio::misc::Debug qw(debug_print); - -############################################################################ -#Main -############################################################################ -my $g_username=""; -my $g_password=""; -my $g_nickname=""; -my $g_email=""; -my $g_crypted_password=""; -my $q = new CGI; -my $g_fsroot = cwd(); -my $g_webroot = $q->self_url(); - -if($q->url_param("mode") eq "go"){ -################################ -#Start Affelio -################################ -my $af; -try{ - $af = new Affelio(ConfigDir => "."); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e->stacktrace); -}; - -################################ -#Copy default template files -################################ -my $g_locale = $af->{site__locale}; -try{ - system("cp -fr defaults/af_templates/$g_locale/*.aftmpl ./$af->{site__user_dir}/af_templates/"); -}catch Error with{ - my $e = shift; - error($q, "Could not copy default templates.\n" . $e->stacktrace); -}; - -################################ -#Rebuild templates_dyn -################################ -try{ - use Affelio::App::Admin::EditTemplates qw(rebuild); - Affelio::App::Admin::EditTemplates::rebuild($af); -}catch Error with{ - my $e = shift; - error($q, "Could not rebuild templates.\n" . $e->stacktrace); -}; - -print "Content-type: text/html; charset=UTF-8\n"; -print "Pragma: no-cache", "\n\n"; -print 'OK. Successfuly done.<P><B>Delete this CGI immediately!!</B>'; -exit(1); - - -}else{ - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print '<HTML><B>Upgrade Affelio from 0.9.5.4 to 1.0RC1</B><P><FORM ACTION="upgrade-0954-10RC1.cgi?mode=go" method=POST><INPUT TYPE="submit" VALUE="Go"></FORM></HTML>'; - exit(1); -} - Index: affelio_farm/admin/skelton/affelio/upgrade-10RC1-10RC11.cgi diff -u affelio_farm/admin/skelton/affelio/upgrade-10RC1-10RC11.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/upgrade-10RC1-10RC11.cgi:removed --- affelio_farm/admin/skelton/affelio/upgrade-10RC1-10RC11.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/upgrade-10RC1-10RC11.cgi Tue Oct 25 04:20:42 2005 @@ -1,70 +0,0 @@ -#!/usr/bin/perl - -use strict; - -use CGI qw(-unique_headers); -use Cwd; -use DBI; -use lib("./extlib"); -use HTML::Template; -use Error qw(:try); -use lib("./lib"); -use Affelio; -use Affelio::misc::MyCrypt; -use Affelio::misc::Debug qw(debug_print); - -############################################################################ -#Main -############################################################################ -my $g_username=""; -my $g_password=""; -my $g_nickname=""; -my $g_email=""; -my $q = new CGI; -my $g_fsroot = cwd(); -my $g_webroot = $q->self_url(); - -######################################################################### -#1st screen -######################################################################### -if($q->url_param("mode") ne "go"){ - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print '<HTML><B>Upgrade Affelio from 1.0RC1 to 1.0RC1.1</B><P>????鴻?????????.0RC1?т??桁??????恭莊<??若?????鴻?????????????<bR>1.0RC1??ySQL????????戎?????恭莊<?茵?ず???????翫????絎????????????<P><FORM ACTION="upgrade-10RC1-10RC11.cgi?mode=go" method=POST><INPUT TYPE="submit" VALUE="Go"></FORM></HTML>'; - exit(1); - -######################################################################### -#Do upgrade -######################################################################### -}else{ - ################################ - #Start Affelio - ################################ - my $af; - try{ - $af = new Affelio(ConfigDir => "."); - }catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e->stacktrace); - }; - - my $query = 'drop table AFuser_CORE_accesslog'; - my $sth; - eval{ - $sth = $af->{db}->prepare($query); - $sth->execute; - }; - if($@){ - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print 'Error!<BR><BR>' . $@; - exit(1); - } - - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache", "\n\n"; - print 'OK. Successfuly done.<P><B>Delete this CGI immediately!!</B>'; - exit(1); -} - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 701] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW Message-ID: <20051024192043.7DCEA2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi.pm Tue Oct 25 04:20:43 2005 @@ -1,3031 +0,0 @@ -package WWW::Mixi; - -use strict; -use Carp (); -use vars qw($VERSION @ISA); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); - -require LWP::RobotUA; - @ ISA = qw(LWP::RobotUA); -require HTTP::Request; -require HTTP::Response; - -use LWP::Debug (); -use HTTP::Cookies; -use HTTP::Request::Common; - -sub new { - my ($class, $email, $password, %opt) = @_; - my $base = 'http://mixi.jp/'; - - # オプションの処理 - Carp::croak('WWW::Mixi mail address required') unless $email; - # Carp::croak('WWW::Mixi password required') unless $password; - - # オブジェクトの生成 - my $name = "WWW::Mixi/" . $VERSION; - my $rules = WWW::Mixi::RobotRules->new($name); - my $self = LWP::RobotUA->new($name, $email, $rules); - $self = bless $self, $class; - $self->from($email); - $self->delay(1/60); - - # 独自変数の設定 - $self->{'mixi'} = { - 'base' => $base, - 'email' => $email, - 'password' => $password, - 'response' => undef, - 'log' => $opt{'-log'} ? $opt{'-log'} : \&callback_log, - 'abort' => $opt{'-abort'} ? $opt{'-abort'} : \&callback_abort, - 'rewrite' => $opt{'-rewrite'} ? $opt{'-rewrite'} : \&callback_rewrite, - }; - - return $self; -} - -sub login { - my $self = shift; - my $page = 'login.pl'; - my $next = ($self->{'mixi'}->{'next_url'}) ? $self->{'mixi'}->{'next_url'} : '/home.pl'; - my $password = (@_) ? shift : $self->{'mixi'}->{'password'}; - return undef unless (defined($password) and length($password)); - my %form = ( - 'email' => $self->{'mixi'}->{'email'}, - 'password' => $password, - 'next_url' => $self->absolute_url($next), - ); - $self->enable_cookies; - # ログイン - $self->log("[info] 再ログインします。\n") if ($self->session); - my $res = $self->post($page, %form); - $self->{'mixi'}->{'refresh'} = ($res->is_success and $res->headers->header('refresh') =~ /url=([^ ;]+)/) ? $self->absolute_url($1) : undef; - $self->{'mixi'}->{'password'} = $password if ($res->is_success); - return $res; -} - -sub is_logined { - my $self = shift; - return ($self->session and $self->stamp) ? 1 : 0; -} - -sub is_login_required { - my $self = shift; - my $res = (@_) ? shift : $self->{'mixi'}->{'response'}; - if (not $res) { return "ページを取得できていません。"; } - elsif (not $res->is_success) { return sprintf('ページ取得に失敗しました。(%s)', $res->message); } - else { - my $re_attr = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s+'; - my $content = $res->content; - return 0 if ($content !~ /<form (?:$re_attr)*action=("[^""]+"|'[^'']+'|[^\s<>]+)/); - return 0 if ($self->absolute_url($1) ne $self->absolute_url('login.pl')); - $self->{'mixi'}->{'next_url'} = ($content =~ /<input type=hidden name=next_url value="(.*?)">/) ? $1 : '/home.pl'; - return "Login Failed ($1)" if ($content =~ /<b><font color=#DD0000>(.*?)<\/font><\/b>/); - return 'Login Required'; - } - return 0; -} - -sub session { - my $self = shift; - if (@_) { - my $session = shift; - $self->enable_cookies; - $self->cookie_jar->set_cookie(undef, 'BF_SESSION', $session, '/', 'mixi.jp', undef, 1, undef, undef, 1); - } - return undef unless ($self->cookie_jar); - return ($self->cookie_jar->as_string =~ /\bSet-Cookie.*?:.*? BF_SESSION=(.*?);/) ? $1 : undef; -} - -sub stamp { - my $self = shift; - if (@_) { - my $stamp = shift; - $self->enable_cookies; - $self->cookie_jar->set_cookie(undef, 'BF_STAMP', $stamp, '/', 'mixi.jp', undef, 1, undef, undef, 1); - } - return undef unless ($self->cookie_jar); - return ($self->cookie_jar->as_string =~ /\bSet-Cookie.*?:.*? BF_STAMP=(.*?);/) ? $1 : undef; -} - -sub refresh { return $_[0]->{'mixi'}->{'refresh'}; } - -sub request { - my $self = shift; - my @args = @_; - my $res = $self->SUPER::request(@args); - - if ($res->is_success) { - # check contents existence - if ($res->content and $res->content =~ /^\Qデータはありません。\E<html>/) { - $res->code(400); - $res->message('No Data'); - # check rejcted by too frequent requests. - } elsif ($res->content and $res->content =~ /^\Q間隔を空けない連続的なページの遷移・更新を頻繁におこなわれている\E/) { - $res->code(503); - $res->message('Too frequently requests'); - # check rejcted since content is closed. - } elsif ($res->content and $res->content =~ /^\Qアクセスできません\E<html>/) { - $res->code(403); - $res->message('Closed content'); - # check login form existence - } elsif (my $message = $self->is_login_required($res)) { - $res->code(401); - $res->message($message); - } - } - - # store and return response - $self->{'mixi'}->{'response'} = $res; - return $res; -} - -sub get { - my $self = shift; - my $url = shift; - $url = $self->absolute_url($url); - $self->log("[info] GETメソッドで\"${url}\"を取得します。\n"); - # 取得 - my $res = $self->request(HTTP::Request->new('GET', $url)); - $self->log("[info] リクエストが処理されました。\n"); - return $res; -} - -sub post { - my $self = shift; - my $url = shift; - $url = $self->absolute_url($url); - $self->log("[info] POSTメソッドで\"${url}\"を取得します。\n"); - # リクエストの生成 - my @form = @_; - my $req = (grep {ref($_) eq 'ARRAY'} @form) ? - &HTTP::Request::Common::POST($url, Content_Type => 'form-data', Content => [@form]) : - &HTTP::Request::Common::POST($url, [@form]); - $self->log("[info] リクエストが生成されました。\n"); - # 取得 - my $res = $self->request($req); - $self->log("[info] リクエストが処理されました。\n"); - return $res; -} - -sub response { - my $self = shift; - return $self->{'mixi'}->{'response'}; -} - -sub parse_main_menu { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<map name=mainmenu>(.*?)<\/map>/s) { - $content = $1; - while ($content =~ s/<area .*?alt=([^\s<>]*?) .*?href=([^\s<>]*?)>//) { - my $item = { 'link' => $self->absolute_url($2, $base), 'subject' => $self->rewrite($1) }; - push(@items, $item); - } - } - return @items; -} - -sub parse_banner { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - while ($content =~ s/<a href=(".*?"|'.*?'|[^<> ]*).*?><img src=["']?([^<>]*?)['"]? border=0 width=468 height=60 alt=["']?([^<>]*?)['"]?><\/a>//is) { - my ($link, $image, $subject) = ($1, $2, $3); - $link = $1 if ($link =~ /^"(.*?)"$/ or /^'(.*?)'$/); - $link = $self->absolute_url($link, $base); - $image = $self->absolute_url($image, $base); - $subject = $self->rewrite($subject); - my $item = { 'link' => $link, 'image' => $image, 'subject' => $subject }; - push(@items, $item); - } - return @items; -} - -sub parse_tool_bar { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<td><img src=http:\/\/img.mixi.jp\/img\/b_left.gif WIDTH=22 HEIGHT=23><\/td>(.*?)<td><img src=http:\/\/img.mixi.jp\/img\/b_right.gif WIDTH=23 HEIGHT=23><\/td>/s) { - $content = $1; - while ($content =~ s/<a HREF=([^<> ]*?) .*?><img .*?ALT=([^<> ]*?) .*?><\/a>//) { - my $item = { 'link' => $self->absolute_url($1, $base), 'subject' => $self->rewrite($2) }; - push(@items, $item); - } - } - return @items; -} - -sub parse_information { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<img src=[^ <>]+ ALT=お知らせ VSPACE=1 WIDTH=100 HEIGHT=37>.*?<table BORDER=0 CELLSPACING=0 CELLPADDING=0>(.*?)<\/table>/is) { - $content = $1; - $content =~ s/[\r\n]+//gs; - $content =~ s/<!--.*?-->//g; - while ($content =~ s/<tr><td>(.*?)<\/td><td>(.*?)<\/td><td>(.*?)<\/td><\/tr>//i) { - my ($subject, $linker) = ($1, $3); - my $re_attr_val = '(?:"[^"]+"|\'[^\']+\'|[^\s<>]+)\s*'; - my $style = {}; - $subject =~ s/^.*?・<\/font>(?: | )//; - while ($subject =~ s/^\s*<([^<>]*)>\s*//) { - my $tag = lc($1); - my ($tag_part, $attr_part) = split(/\s+/, $tag, 2); - $style->{'font-weight'} = 'bold' if ($tag_part eq 'b'); - while ($attr_part =~ s/([^\s<>=]+)(?:=($re_attr_val))?//) { - my ($attr, $val) = ($1, $2); - $val =~ s/^"(.*)"$/$1/ or $val =~ s/^'(.*)'$/$1/; - $val = $self->unescape($val); - if ($attr eq 'style') { $style->{$1} = $2 while ($val =~ s/([^\s:]+)\s*:\s*([^\s:]+)//); } - elsif ($attr eq 'color') { $style->{'color'} = $val; } - } - } - $subject =~ s/\s*<.*?>\s*//g; - my ($link, $description) = ($1, $2) if ($linker =~ /<a href=(.*?) .*?>(.*?)<\/a>/i); - my $item = { - 'subject' => $self->rewrite($subject), - 'style' => $style, - 'link' => $self->absolute_url($link, $base), - 'description' => $self->rewrite($description) - }; - push(@items, $item); - } - } - return @items; -} - -sub parse_home_new_album { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /マイミクシィ最新アルバム(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=300>/s) { - $content = $1; - while ($content =~ s/<img src=.*?>(\d{2})月(\d{2})日.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br CLEAR=all>//is) { - my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); - $subj = $self->rewrite($subj); - $name = $self->rewrite($name); - $link = $self->absolute_url($link, $base); - push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); - } - } - return @items; -} - -sub parse_home_new_bbs { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /コミュニティ最新書き込み(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=300>/s) { - $content = $1; - while ($content =~ s/<img src=.*?>(\d{2})月(\d{2})日.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br CLEAR=all>//is) { - my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); - $subj = $self->rewrite($subj); - $name = $self->rewrite($name); - $link = $self->absolute_url($link, $base); - push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); - } - } - return @items; -} - -sub parse_home_new_comment { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /日記コメント記入履歴(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=300>/s) { - $content = $1; - while ($content =~ s/<img src=.*?>(\d{2})月(\d{2})日.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br CLEAR=all>//is) { - my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); - $subj = $self->rewrite($subj); - $name = $self->rewrite($name); - $link = $self->absolute_url($link, $base); - push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); - } - } - return @items; -} - -sub parse_home_new_friend_diary { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<td BGCOLOR=#F2DDB7 WIDTH=80 NOWRAP><font COLOR=#996600>マイミクシィ最新日記<\/font>.*?<\/td>(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=300>/s) { - $content = $1; - while ($content =~ s/<img src=.*?>(\d{2})月(\d{2})日.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br CLEAR=all>//is) { - my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); - $subj = $self->rewrite($subj); - $name = $self->rewrite($name); - $link = $self->absolute_url($link, $base); - push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); - } - } - return @items; -} - -sub parse_home_new_review { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /マイミクシィ最新レビュー(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=300>/s) { - $content = $1; - while ($content =~ s/<img src=.*?>(\d{2})月(\d{2})日.*?<a href=(.+?)>(.*?)<\/a>.*?\((.+?)\)<br CLEAR=all>//is) { - my ($date, $link, $subj, $name) = ((sprintf('%02d/%02d', $1, $2)), $3, $4, $5); - $subj = $self->rewrite($subj); - $name = $self->rewrite($name); - $link = $self->absolute_url($link, $base); - push(@items, {'time' => $date, 'link' => $link, 'subject' => $subj, 'name' => $name}); - } - } - return @items; -} - -sub parse_ajax_new_diary { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '(\d{1,2})月(\d{1,2})日'; - my $re_link = '<a [^<>]*href="?([^<> ]*?)"?(?: [^<>]*)?>(.*?)<\/a>'; - my $re_name = '\((.*?)\)'; - my @today = reverse((localtime)[3..5]); - $today[0] += 1900; - $today[1] += 1; - foreach my $row ($content =~ /<div align=left>(.*?)<\/div>/isg) { - next unless ($row =~ /$re_date … $re_link/); - my $item = {}; - my @date = (undef, $1, $2); - $item->{'link'} = $self->absolute_url($3, $base); - $item->{'subject'} = (defined($4) and length($4)) ? $self->rewrite($4) : '(削除)'; - $date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0])); - $item->{'time'} = sprintf('%04d/%02d/%02d', @date); - map { $item->{$_} =~ s/^\s+|\s+$//gs } (keys(%{$item})); - push(@items, $item); - } - return @items; -} - -sub parse_community_id { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my $item; - if ($content =~ /view_community.pl\?id=(\d+) /) { - $item = $1; - } - return $item; -} - -sub parse_list_bbs { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '<td ALIGN=center ROWSPAN=3 NOWRAP bgcolor=#FFD8B0>(\d{2})月(\d{2})日<br>(\d{1,2}):(\d{2})</td>'; - my $re_subj = '<td bgcolor=#FFF4E0> (.+?)</td>'; - my $re_desc = '<td CLASS=h120>(.*?)\n</td>'; - my $re_name = '\((.*?)\)'; - my $re_link = '<a href="?(.+?)"?>書き込み\((\d+)\)<\/a>'; - if ($content =~ /<table BORDER=0 cellspacing=1 cellpadding=3 width=630>(.+)<\/table>/s) { - $content = $1 ; - while ($content =~ s/<tr VALIGN=top>.*?${re_date}.*?${re_subj}(.*?)${re_desc}.*?${re_link}.*?<\/tr>//is) { - my $time = sprintf('%02d/%02d %02d:%02d', $1, $2, $3, $4); - my ($subj, $thumbs, $desc, $link, $count) = ($5, $6, $7, $8, $9); - $subj = $self->rewrite($subj); - $desc = $self->rewrite($desc); - $desc =~ s/^$//g; - $link = $self->absolute_url($link, $base); - my @images = (); - while ($thumbs =~ s/MM_openBrWindow\('(.*?)',.+?<img src=["']?([^<>]*?)['"]? border//is){ - my $img = $self->absolute_url($1, $base); - my $thumbimg = $self->absolute_url($2, $base); - push(@images, {'thumb_link' => $thumbimg, 'link' => $img}); - } - push(@items, {'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $link, 'count' => $count, 'images' => [@images]}); - } - } - return @items; -} - -sub parse_list_bbs_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>.*?<a href=([^<>]*?list_bbs.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_bbs_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=([^<>]*?list_bbs.pl[^<>]*?)>([^<>]*?)<\/a>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_bookmark { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=630>(.+?)<img src=["']?http:\/\/\S*?\/q_brown3.gif['"]? [^<>]*?>/s) { - $content = $1; - while ($content =~ s/<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=550>(.*?)<\/table>//is) { - my $record = $1; - my @lines = ($record =~ /<tr.*?>(.*?)<\/tr>/gis); - my $item = {}; - # parse record - ($item->{'link'}, $item->{'image'}) = ($1, $2) if ($lines[0] =~ /<td WIDTH=90 .*?><a href="([^"]*show_friend.pl\?id=\d+)"><img SRC="([^"]*)".*?>/is); - ($item->{'subject'}, $item->{'gender'}) = ($1, $2) if ($lines[0] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?) \((.*?)\)<\/td>/is); - $item->{'description'} = $1 if ($lines[1] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is); - $item->{'time'} = $1 if ($lines[2] =~ /<td BGCOLOR=#FFFFFF WIDTH=140>(.*?)<\/td>/is); - # format - foreach (qw(image link)) { $item->{$_} = $self->absolute_url($item->{$_}, $base) if ($item->{$_}); } - foreach (qw(subject description gender)) { $item->{$_} = $self->rewrite($item->{$_}); } - $item->{'time'} = $self->convert_login_time($item->{'time'}) if ($item->{'time'}); - push(@items, $item) if ($item->{'subject'} and $item->{'link'}); - } - } - @items = sort { $b->{'time'} cmp $a->{'time'} } @items; - return @items; -} - -sub parse_list_comment { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_list_community { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $status_backgrounds = { - 'http://img.mixi.jp/img/bg_orange1-.gif' => '管理者', - }; - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=2 WIDTH=560>(.+?)<\/table>/s) { - $content = $1; - while ($content =~ s/<tr ALIGN=center BGCOLOR=#FFFFFF>(.*?)<tr ALIGN=center BGCOLOR=#FFF4E0>(.*?)<\/tr>//is) { - my ($image_part, $text_part) = ($1, $2); - my @images = ($image_part =~ /<td WIDTH=20% HEIGHT=100 background=http:\/\/img.mixi.jp\/img\/bg_[a-z0-9-]+.gif>.*?<\/td>/gi); - my @texts = ($text_part =~ /<td>(.*?)<\/td>/gi); - for (my $i = 0; $i < @images or $i < @texts; $i++) { - my $item = {}; - my ($image, $text) = ($images[$i], $texts[$i]); - ($item->{'subject'}, $item->{'count'}) = ($1, $2) if ($text =~ /^\s*(.*?)\((\d+)\)\s*$/); - ($item->{'background'}, $item->{'link'}, $item->{'image'}) = ($1, $2, $3) if ($image =~ /<td .*? background=([^<> ]*).*?><a href=(.*?)><img SRC=(.*?) border=0><\/a>/); - if ($item->{'link'}) { - $item->{'subject'} = $self->rewrite($item->{'subject'}); - $item->{'link'} = $self->absolute_url($item->{'link'}, $base); - $item->{'image'} = $self->absolute_url($item->{'image'}, $base); - $item->{'background'} = $self->absolute_url($item->{'background'}, $base); - $item->{'status'} = $status_backgrounds->{$item->{'background'}}; - push(@items, $item); - } - } - } - } - return @items; -} - -sub parse_list_community_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=580 BGCOLOR=#F8A448>.*?<a href=([^<>]*?)>([^<>]*?)<\/a><\/td>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_community_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - return unless ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=580 BGCOLOR=#F8A448>.*?<td ALIGN=right BGCOLOR=#EED6B5><a href=["']?(.+?)['"]?>([^<>]+)<\/a>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $previous = {'link' => $link, 'subject' => $2}; - return $previous; -} - -sub parse_list_diary { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '<font COLOR=#996600>(\d{2})月(\d{2})日<br>(\d{1,2}):(\d{2})</font>'; - my $re_subj = '<td bgcolor=#F2DDB7> (.+?)</td>'; - my $re_desc = '<td CLASS=h120>\n(.*?)\n(.+?)\n<br>\n\n</td>'; - my $re_name = '\((.*?)\)'; - my $re_link = '<a href="?(.+?)"?>コメント\((\d+)\)<\/a>'; - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=3 WIDTH=525>(.+)<\/table>/s) { - $content = $1 ; - while ($content =~ s/<tr VALIGN=top>.*?${re_date}.*?${re_subj}.*?${re_desc}.*?${re_link}.*?<\/tr>//is) { - my $time = sprintf('%02d/%02d %02d:%02d', $1, $2, $3, $4); - my ($subj, $thumbs, $desc, $link, $count) = ($5, $6, $7, $8, $9); - $subj = $self->rewrite($subj); - $desc = $self->rewrite($desc); - $desc =~ s/^$//g; - $link = $self->absolute_url($link, $base); - my @images = (); - while ($thumbs =~ s/MM_openBrWindow\('(.*?)',.+?<img src=["']?([^<>]*?)['"]? border//is){ - my $img = $self->absolute_url($1, $base); - my $thumbimg = $self->absolute_url($2, $base); - push(@images, {'thumb_link' => $thumbimg, 'link' => $img}); - } - push(@items, {'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $link, 'count' => $count, 'images' => [@images]}); - } - } - return @items; -} - -sub parse_list_diary_capacity { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - return unless ($content =~ /<table width="165" border="0" cellspacing="1" cellpadding="2">(.*?)<\/table>/is); - my $box = $1; - return unless ($box =~ /(\d+\.\d+).*?MB\/.*?(\d+\.\d+).*?MB/); - my $capacity = {'used' => $1, 'max' => $2}; - return $capacity; -} - -sub parse_list_diary_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>.*?<a href=([^<>]*?list_diary.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_diary_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=([^<>]*?list_diary.pl[^<>]*?)>([^<>]*?)<\/a>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_diary_monthly_menu { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<img src=.*? ALT=各月の日記 .*?>(.+?)<\/table>/is) { - $content = $1; - $content =~ s/\s+/ /gs; - while ($content =~ s/<a HREF=['"]?(list_diary.pl\?year=(\d+)\&month=(\d+))["']?.*?>.*?<\/a>//is) { - push(@items, {'link' => $self->absolute_url($1, $base), 'year' => $2, 'month' => $3}); - } - } - return @items; -} - -sub parse_list_friend { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $status_backgrounds = { - 'http://img.mixi.jp/img/bg_orange1-.gif' => '1時間以内', - 'http://img.mixi.jp/img/bg_orange2-.gif' => '1日以内', - }; - my @time1 = reverse((localtime(time - 3600))[0..5]); - my @time2 = reverse((localtime(time - 3600 * 24))[0..5]); - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=2 WIDTH=560>(.+?)<\/table>/s) { - $content = $1 ; - while ($content =~ s/<tr ALIGN=center BGCOLOR=#FFFFFF>(.*?)<tr ALIGN=center BGCOLOR=#FFF4E0>(.*?)<\/tr>//is) { - my ($image_part, $text_part) = ($1, $2); - my @images = ($image_part =~ /<td WIDTH=20% HEIGHT=100 background=http:\/\/img.mixi.jp\/img\/bg_[a-z0-9-]+.gif>.*?<\/td>/gi); - my @texts = ($text_part =~ /<td>(.*?)<\/td>/gi); - for (my $i = 0; $i < @images or $i < @texts; $i++) { - my $item = {}; - my ($image, $text) = ($images[$i], $texts[$i]); - ($item->{'subject'}, $item->{'count'}) = ($1, $2) if ($text =~ /^\s*(.+?)\((\d+)\)/); - ($item->{'background'}, $item->{'link'}, $item->{'image'}) = ($1, $2, $3) if ($image =~ /<td .*? background=([^<> ]*).*?><a href=(.*?)><img alt=(?:.*?) SRC=(.*?) border=0><\/a>/); - if ($item->{'link'}) { - $item->{'subject'} = $self->rewrite($item->{'subject'}); - $item->{'link'} = $self->absolute_url($item->{'link'}, $base); - $item->{'id'} = $2 if ($item->{'link'} =~ /(.*?)?id=(\d*)/); - $item->{'image'} = $self->absolute_url($item->{'image'}, $base); - $item->{'background'} = $self->absolute_url($item->{'background'}, $base); - $item->{'status'} = $status_backgrounds->{$item->{'background'}}; - push(@items, $item); - } - } - } - } - return @items; -} - -sub parse_list_friend_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /  <a href=([^<>]*?list_friend.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_friend_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - return unless ($content =~ /<a href=([^<>\s]*list_friend.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>  /); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $previous = {'link' => $link, 'subject' => $2}; - return $previous; -} - -sub parse_list_member { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=2 WIDTH=560>(.+?)<\/table>/s) { - $content = $1 ; - while ($content =~ s/<tr ALIGN=center BGCOLOR=#FFFFFF>(.*?)<tr ALIGN=center BGCOLOR=#FFF4E0>(.*?)<\/tr>//is) { - my ($image_part, $text_part) = ($1, $2); - my @images = ($image_part =~ /<td WIDTH=20% HEIGHT=100 background=http:\/\/img.mixi.jp\/img\/bg_line.gif>.*?<\/td>/gi); - my @texts = ($text_part =~ /<td>(.*?)<\/td>/gi); - for (my $i = 0; $i < @images or $i < @texts; $i++) { - my $item = {}; - my ($image, $text) = ($images[$i], $texts[$i]); - ($item->{'subject'}, $item->{'count'}) = ($1, $2) if ($text =~ /^\s*(.+?)\((\d+)\)/); - ($item->{'background'}, $item->{'link'}, $item->{'image'}) = ($1, $2, $3) if ($image =~ /<td .*? background=([^<> ]*).*?><a href=(.*?)><img SRC=(.*?) border=0><\/a>/i); - if ($item->{'link'}) { - $item->{'subject'} = $self->rewrite($item->{'subject'}); - $item->{'link'} = $self->absolute_url($item->{'link'}, $base); - $item->{'id'} = $2 if ($item->{'link'} =~ /(.*?)?id=(\d*)/); - $item->{'image'} = $self->absolute_url($item->{'image'}, $base); - $item->{'background'} = $self->absolute_url($item->{'background'}, $base); - push(@items, $item); - } - } - } - } - return @items; -} - -sub parse_list_member_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /  <a href=([^<>]*?list_member.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_list_member_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - return unless ($content =~ /<a href=([^<>\s]*list_member.pl\?[^<>\s]*page=[^<>\s]*)>((?:(?!<\/a>).)*)<\/a>  /); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $previous = {'link' => $link, 'subject' => $2}; - return $previous; -} - -sub parse_list_message { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - my @items = (); - my $img_rep = $self->absolute_url('img/mail5.gif', $base); - my %emvelopes = ( - $self->absolute_url('img/mail1.gif', $base) => 'new', - $self->absolute_url('img/mail2.gif', $base) => 'opened', - $self->absolute_url('img/mail5.gif', $base) => 'replied', - ); - my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>'; - if ($content =~ /<!--受信箱一覧-->.*?<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=553>(.+?)<\/table>/s) { - $content = $1; - while ($content =~ s/<tr BGCOLOR="(#FFF7E1|#FFFFFF)">(.*?)<\/tr>//s) { - my $message = $2; - my $emvelope = ($message =~ s/<td[^<>]*>\s*<img SRC="(.*?)".*?>\s*<\/td>//s) ? $self->absolute_url($1, $base) : undef; - my $status = $emvelopes{$emvelope} ? $emvelopes{$emvelope} : 'unknown'; - if ($message =~ /<td>([^<>]*?)<\/td>\s*<td>${re_link}<\/td>\s*<td>(\d{2})月(\d{2})日<\/td>/is) { - my ($name, $link, $subj) = ($1, $2, $3); - my $time = sprintf('%02d/%02d', $4, $5); - my $item = { - 'time' => $time, - 'subject' => $self->rewrite($subj), - 'name' => $self->rewrite($name), - 'link' => $self->absolute_url($link, $base), - 'status' => $status, - 'emvelope' => $emvelope, - }; - push(@items, $item); - } - } - } - return @items; -} - -sub parse_list_outbox { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - my @items = (); - my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>'; - if ($content =~ /<!--送信済み一覧-->.*?<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=553>(.+?)<\/table>/s) { - $content = $1; - while ($content =~ s/<tr BGCOLOR="?(#FFF7E1|#FFFFFF)"?>(.*?)<\/tr>//s) { - my $message = $2; - if ($message =~ /<td>([^<>]*?)<\/td>\s*<td>${re_link}<\/td>\s*<td>(\d{2})月(\d{2})日<\/td>/is) { - my ($name, $link, $subj) = ($1, $2, $3); - my $time = sprintf('%02d/%02d', $4, $5); - my $item = { - 'time' => $time, - 'subject' => $self->rewrite($subj), - 'name' => $self->rewrite($name), - 'link' => $self->absolute_url($link, $base), - }; - push(@items, $item); - } - } - } - return @items; -} - -sub parse_list_request { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=630>(.+?)<table BORDER=0 CELLSPACING=0 CELLPADDING=0 WIDTH=720 BGCOLOR=#FF9933>/s) { - $content = $1; - while ($content =~ s/<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=550>(.*?)<\/table>//is) { - my $record = $1; - my @lines = ($record =~ /<tr.*?>(.*?)<\/tr>/gis); - my $item = {}; - # parse record - ($item->{'link'}, $item->{'image'}) = ($1, $2) if ($lines[0] =~ /<td WIDTH=90 .*?><a href="([^"]*show_friend.pl\?id=\d+)"><img SRC="([^"]*)".*?>/is); - ($item->{'subject'}, $item->{'gender'}) = ($1, $2) if ($lines[0] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?) \((.*?)\)<\/td>/is); - $item->{'description'} = $1 if ($lines[1] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is); - $item->{'message'} = $1 if ($lines[2] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is); - $item->{'time'} = $1 if ($lines[3] =~ /<td BGCOLOR=#FFFFFF WIDTH=140>(.*?)<\/td>/is); - while ($lines[3] =~ s/<a href="(.*?)"><img src=["']?(.*?)['"]? ALT=["']?(.*?)['"]? [^<>]*?><\/a>//) { - my $button = { 'link' => $1, 'image' => $2, 'title' => $3 }; - map { $button->{$_} = $self->absolute_url($button->{$_}, $base) } qw(link image); - map { $button->{$_} = $self->rewrite($button->{$_}, $base) } qw(title); - $item->{'button'} = [] unless ($item->{'button'}); - push(@{$item->{'button'}}, $button); - } - # format - map { $item->{$_} = $self->absolute_url($item->{$_}, $base) } qw(link image); - map { $item->{$_} = $self->rewrite($item->{$_}, $base) } qw(subject description message gender); - $item->{'time'} = $self->convert_login_time($item->{'time'}) if ($item->{'time'}); - push(@items, $item) if ($item->{'subject'} and $item->{'link'}); - } - } - @items = sort { $b->{'time'} cmp $a->{'time'} } @items; - return @items; -} - -sub parse_new_album { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_new_bbs { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_new_bbs_next { - my $self = shift; - return $self->parse_standard_history_next(@_); -} - -sub parse_new_bbs_previous { - my $self = shift; - return $self->parse_standard_history_previous(@_); -} - -sub parse_new_comment { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_new_friend_diary { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_new_friend_diary_next { - my $self = shift; - return $self->parse_standard_history_next(@_); -} - -sub parse_new_friend_diary_previous { - my $self = shift; - return $self->parse_standard_history_previous(@_); -} - -sub parse_new_review { - my $self = shift; - return $self->parse_standard_history(@_); -} - -sub parse_release_info { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_subj = '<b><font COLOR=#605048>(.+?)</font></b>'; - my $re_date = '<td ALIGN=right><font COLOR=#605048>(\d{4}).(\d{2}).(\d{2})</font></td>'; - my $re_desc = '<td CLASS=h130>(.*?)</td>'; - if ($content =~ /新機能リリース・障害のご報告(.*?)<!--フッタ-->/s) { - $content = $1; - while ($content =~ s/<table BORDER=0 CELLSPACING=0 CELLPADDING=2 WIDTH=520 BGCOLOR=#F7F0E6>.*?${re_subj}.*?${re_date}.*?${re_desc}.*?<!--▼1つ分ここまで-->//is) { - my $subj = $1; - my $date = sprintf('%04d/%02d/%02d', $2, $3, $4); - my $desc = $5; - $subj = $self->rewrite($subj); - $desc = $self->rewrite($desc); - $desc =~ s/^$//g; - push(@items, {'time' => $date, 'description' => $desc, 'subject' => $subj}); - } - } - return @items; -} - -sub parse_self_id { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my $self_id = ($content =~ /\(URL は http:\/\/mixi.jp\/show_friend.pl\?id=(\d+) です。\)/) ? $1 : 0; - return $self_id; -} - -sub parse_search_diary { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my @time = localtime(); - my ($month, $year) = ($time[4] + 1, $time[5] + 1900); - if ($content =~ m{<!--///// 最新日記検索ここまで /////-->(.+?)<!--フッタ-->}s) { - $content = $1; - while ($content =~ s/<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=550>(.*?)<\/table>//is) { - my $record = $1; - my @lines = ($record =~ /<tr.*?>(.*?)<\/tr>/gis); - my $item = {}; - # parse record - ($item->{'link'}, $item->{'image'}) = ($1, $2) if ($lines[0] =~ /<td WIDTH=90 .*?><a href="([^"]*view_diary.pl\?id=\d+\&owner_id=\d+)"><img SRC="([^"]*)".*?>/is); - ($item->{'name'}, $item->{'gender'}) = ($1, $2) if ($lines[0] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?) \((.*?)\).*<\/td>/is); - $item->{'subject'} = $1 if ($lines[1] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is); - $item->{'description'} = $1 if ($lines[2] =~ /<td COLSPAN=2 BGCOLOR=#FFFFFF>(.*?)<\/td>/is); - $item->{'time'} = $1 if ($lines[3] =~ /<td BGCOLOR=#FFFFFF WIDTH=220>(.*?)<\/td>/is); - # format - my @time = ($item->{'time'} =~ /\d+/g); - unshift(@time, ($time[0] == $month) ? $year : $year - 1) if (@time == 4); - $item->{'time'} = (@time == 5) ? sprintf('%04d/%02d/%02d %02d:%02d', @time) : ''; - foreach (qw(image link)) { $item->{$_} = $self->absolute_url($item->{$_}, $base) if ($item->{$_}); } - foreach (qw(name subject description gender time)) { - $item->{$_} =~ s/<.*?>//g if ($item->{$_}); - $item->{$_} = $self->rewrite($item->{$_}); - } - push(@items, $item) if ($item->{'subject'} and $item->{'link'}); - } - } - return @items; -} - -sub parse_search_diary_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>.*?<a href=([^<>]*?search_diary.pl[^<>]*?)>([^<>]*?)<\/a><\/td>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_search_diary_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=([^<>]*?search_diary.pl[^<>]*?)>([^<>]*?)<\/a>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_show_calendar { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my %icons = ('i_sc-.gif' => '予定', 'i_bd.gif' => '誕生日', 'i_iv1.gif' => '参加イベント', 'i_iv2.gif' => 'イベント'); - my %whethers = ('1' => '晴', '2' => '曇', '3' => '雨', '4' => '雪', '8' => 'のち', '9' => 'ときどき'); - my @items = (); - my $term = $self->parse_show_calendar_term($res) or return undef; - if ($content =~ /<table width="670" border="0" cellspacing="1" cellpadding="3">(.+?)<\/table>/s) { - $content = $1; - $content =~ s/<tr ALIGN=center BGCOLOR=#FFF1C4>.*?<\/tr>//is; - while ($content =~ s/<td HEIGHT=65 [^<>]*><font COLOR=#996600>(\S*?)<\/font>(.*?)<\/td>//is) { - my $date = $1; - my $text = $2; - next unless ($date =~ /(\d+)/); - $date = sprintf('%04d/%02d/%02d', $term->{'year'}, $term->{'month'}, $1); - if ($text =~ s/<img SRC=(.*?) WIDTH=23 HEIGHT=16 ALIGN=absmiddle>(.*?)<\/font><\/font>//) { - my $item = { 'subject' => "天気", 'link' => undef, 'name' => $2, 'time' => $date, 'icon' => $1}; - $item->{'icon'} = $self->absolute_url($item->{'icon'}, $base); - my $weather = ($item->{'icon'} =~ /i_w(\d+).gif$/) ? $1 : '不明'; - $weather =~ s/(\d)/$whethers{$1}/g; - $item->{'name'} = sprintf("%s(%s%%)", $weather, $self->rewrite($item->{'name'})); - push(@items, $item); - } - my @events = split(/<br>/, $text); - foreach my $event (@events) { - my $item = {}; - if ($event =~ /<img SRC=(.*?) WIDTH=16 HEIGHT=16 ALIGN=middle><a HREF=(.*?)>(.*?)<\/a>/) { - $item = { 'subject' => $1, 'link' => $2, 'name' => $3, 'time' => $date, 'icon' => $1}; - } elsif ($event =~ /<a href=".*?" onClick="MM_openBrWindow\('(view_schedule.pl\?id=\d+)'.*?\)"><img src=(.*?) .*?>(.*?)<\/a>/) { - $item = { 'subject' => $2, 'link' => $1, 'name' => $3, 'time' => $date, 'icon' => $2}; - } else { - next; - } - $item->{'subject'} = ($item->{'subject'} =~ /([^\/]+)$/ and $icons{$1}) ? $icons{$1} : "不明($1)"; - $item->{'link'} = $self->absolute_url($item->{'link'}, $base); - $item->{'icon'} = $self->absolute_url($item->{'icon'}, $base); - $item->{'subject'} = $self->rewrite($item->{'subject'}); - $item->{'name'} = $self->rewrite($item->{'name'}); - push(@items, $item); - } - } - } - return @items; -} - -sub parse_show_calendar_term { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<a href="show_calendar.pl\?year=(\d+)&month=(\d+)&pref_id=13">[^&]*?<\/a>/); - return {'year' => $1, 'month' => $2}; -} - -sub parse_show_calendar_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<a href="(show_calendar.pl\?.*?)">([^<>]+?) >>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $subject}; - return $next; -} - -sub parse_show_calendar_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<a href="(show_calendar.pl\?.*?)"><< ([^<>]+)/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $subject}; - return $next; -} - -sub parse_show_friend_outline { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - my $outline = {'link' => $base}; - return unless ($content =~ /<img [^<>]*?src=["']?http:\/\/img.mixi.jp\/img\/q_yellow2.gif['"]?[^<>]*?>[^\r\n]*\n(.+?)\n[^\r\n]*?<img [^<>]*?src=["']?http:\/\/img.mixi.jp\/img\/q_yellow3.gif['"]?[^<>]*?>/s); - $content = $1; - # parse relation - if ($content =~ s/<td ALIGN=center COLSPAN=3>(.*?)<table BORDER=0 CELLSPACING=0 CELLPADDING=1 BGCOLOR=#D3B16D>//s) { - my $relation_part = $1; - my @nodes = ($relation_part =~ /(<a href=show_friend.pl\?id=\d+>.*?<\/a>)/g); - $outline->{'step'} = @nodes; - if ($outline->{'step'} == 2) { - if ($nodes[0] =~ /<a href="?(.+?)"?>(.+?)<\/a>/) { - my ($link, $name) = ($1, $2); - $outline->{'relation'} = { 'link' => $self->absolute_url($link, $base), 'name' => $self->rewrite($name) }; - } else { - $outline->{'relation'} = { 'link' => '', 'name' => '' }; - } - } - } - # parse image - if ($content =~ s/<table BORDER=0 CELLSPACING=0 CELLPADDING=3 WIDTH=250 BGCOLOR=#FFFFFF>(.*?)<\/table>//s) { - my $image_part = $1; - $outline->{'image'} = ($image_part =~ s/<img SRC="(.*?)".*?VSPACE=2.*?>//) ? $self->absolute_url($1, $base) : ''; - } - # parse nickname - if ($content =~ s/([^\n]+)さん\((\d+)\)<br>\n<span class="f08x">\((.*?)\)<\/span><br>//) { - my ($name, $count, $desc) = ($1, $2, $3); - $outline->{'name'} = $self->rewrite($name); - $outline->{'count'} = $count; - $outline->{'description'} = $self->rewrite($desc); - } - return $outline; -} - -sub parse_show_friend_profile { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my $profile = {}; - my $re_link = '<a href=.*?>(.+?)<\/a>'; - return unless ($content = ($content =~ /<!--プロフィール-->(.+?)<!--プロフィールここまで-->/s) ? $1 : ''); - return unless ($content = ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=425>(.+?)<!-- start:/s) ? $1 : ''); - while ($content =~ s/<tr BGCOLOR=#FFFFFF>(.*?)<\/tr>//is) { - my $row = $1; - my ($key, $val) = ($row =~ /<td\b.*?>(.*?)<\/td>/gs); - $key =~ s/ //g; - $key = $self->rewrite($key); - $key =~ s/(^\s+|\s+$)//gs; - $val =~ s/[\r\n]//g; - $val =~ s/<br ?\/?>/\n/g; - $val =~ s/$re_link/$1/g; - $val = $self->rewrite($val); - $val =~ s/(^\s+|\s+$)//gs; - $profile->{$key} = $val; - } - return $profile if (keys(%{$profile})); - return; -} - -sub parse_show_intro { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /からの紹介文(.+?)<!--フッタ-->/s) { - $content = $1; - while ($content =~ s/<tr bgcolor=#FFFFFF>.*?<a href="(.+?)"><img src="(.+?)".*?\n(.+?)<\/td>.*?<td WIDTH=480>\n(.*?)\n(.*?)<\/td>//is) { - my ($link, $img, $name, $rel, $desc) = ($1, $2, $3, $4, $5); - $rel =~ s/関係:(.+?)<br>/$1/; - my $intro = ($desc =~ /edit_intro.pl\?id=.+?\&type=edit/) ? "1" : "0"; - my $delete = ($desc =~ s/<a href="delete_intro.pl\?id=(\d+)">削除<\/a>//s) ? "1" : "0"; - $name = $self->rewrite($name); - $rel = $self->rewrite($rel); - $desc = $self->rewrite($desc); - $desc =~ s/この友人を紹介する//; - $desc =~ s/[\r\n]+//ig; - $link = $self->absolute_url($link, $base); - my $item = {'link' => $link, 'name' => $name, 'image' => $img, 'relation' => $rel, 'description' => $desc, 'introduction' => $intro, 'detele' => $delete}; - push(@items, $item); - } - } - return @items; -} - -sub parse_show_log { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '(\d{4})年(\d{2})月(\d{2})日 (\d{1,2}):(\d{2})'; - my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>'; - if ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=5>(.+?)<\/table>/s) { - $content = $1 ; - while ($content =~ s/${re_date} ${re_link}<br>//is) { - my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5); - my $name = $self->rewrite($7); - my $link = $self->absolute_url($6, $base); - push(@items, {'time' => $time, 'name' => $name, 'link' => $link}); - } - } - return @items; -} - -sub parse_show_log_count { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my $count = ($content =~ /ページ全体のアクセス数:<b>(\d+)<\/b> アクセス/) ? $1 : 0; - return $count; -} - -sub parse_view_album { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /概要ここから(.+?)<!--フッタ-->/s) { - my $img = $1 if ($content =~ /width=250><img ALT="" SRC="(.*?)" VSPACE=4><\/td>/); - my $name = $1 if ($content =~ /<b>(.*?)さんのフォトアルバム/); - my $subj = $1 if ($content =~ /タイトル.*?<b>(.*?)<\/b>/s); - my $desc = $1 if ($content =~ /説明.*?CLASS=h120>(.*?)<\/td>/s); - my $level = $1 if ($content =~ /公開レベル.*?<td bgcolor=#FFFFFF>(.*?)<br>/s); - my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $5, $5) if ($content =~ /作成日時.*?<td bgcolor=#FFFFFF>(\d{4})年(\d{2})月(\d{2})日 (\d{2}):(\d{2})<\/td>/s); - my $comm = $1 if ($content =~ />コメント\((\d+)\)/); - my $number = $1 if ($content =~ /写真一覧.*?\ (\d+)枚/); - $name = $self->rewrite($name); - $subj = $self->rewrite($subj); - $desc = $self->rewrite($desc); - my $item = { 'image' => $self->absolute_url($img, $base), 'name' => $name, 'subject' => $subj, 'description' => $desc, 'level' => $level, 'time' => $time, 'comment_number' => $comm, 'photo_number' => $number}; - push(@items, $item); - } - return @items; -} - -sub parse_view_album_comment { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /写真一覧ここまで(.*?)<!--フッタ-->/s) { - $content = $1; - while ($content =~ s/<td rowspan="2" width="110" bgcolor="#f2ddb7" align="center" valign="top" nowrap>\n(\d{4})年(\d{2})月(\d{2})日<br>(\d{2}):(\d{2})\n<\/td>.*?<a href="(.+?)">(.+?)<\/a>.*?<td class="h120">(.*?)<\/td>//s) { - my ($time, $link, $name, $desc) = ((sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5)), $6, $7, $8); - my $item = { 'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $self->rewrite($name), 'description' => $self->rewrite($desc)}; - push(@items, $item); - } - } - return @items; -} - -sub parse_view_album_photo { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($content =~ /写真一覧ここから(.*?)写真一覧ここまで/s) { - $content = $1; - while ($content =~ s/<td.*?<img alt="(.+?)" src="(.+?)".*?<a href="(.+?)">(.+?)<\/a><\/td>//) { - my ($alt, $thumb, $link, $subj) = ($1, $2, $3, $4); - my $item = { 'description' => $alt, 'thumb_link' => $self->absolute_url($thumb, $base), 'link' => $self->absolute_url($link, $base), 'subject' => $self->rewrite($subj)}; - push(@items, $item); - } - } - return @items; -} - -sub parse_view_bbs { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '<td rowspan="3" width="110" bgcolor="#ffd8b0" align="center" valign="top" nowrap>(\d{4})年(\d{2})月(\d{2})日<br>(\d{1,2}):(\d{2})</td>'; - my $re_subj = '<td bgcolor="#fff4e0"> (.+?)</td>'; - my $re_desc = '</table>(.+?)</td>'; - my $re_c_date = '<td rowspan="2" width="110" bgcolor="#f2ddb7" align="center" nowrap>\n(\d{4})年(\d{2})月(\d{2})日<br>\n(\d{1,2}):(\d{2})'; - my $re_c_desc = '<td class="h120">(.+?)\n</td>'; - my $re_link = '<a href="?(.+?)"?>(.*?)<\/a>'; - if ($content =~ s/<!-- TOPIC: start -->.*?${re_date}.*?${re_subj}.*?${re_link}(.*?)${re_desc}(.*?)$//is) { - my ($time, $subj, $link, $name, $imgs, $desc, $comm) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8, $9, $10, $11); - ($desc, $subj) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($desc, $subj); - my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [] , 'name' => $name, 'name_link' => $self->absolute_url($link, $base)}; - foreach my $image ($imgs =~ /<td width=130[^<>]*>(.*?)<\/td>/g) { - next unless ($image =~ /<a [^<>]*'show_picture.pl\?img_src=(.*?)'[^<>]*><img src=([^ ]*) border=0>/); - push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)}); - } - while ($comm =~ s/.*?${re_c_date}.*?${re_link}.*?${re_c_desc}.*?<\/table>//is){ - my ($time, $link, $name, $desc) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8); - ($name, $desc) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($name, $desc); - push(@{$item->{'comments'}}, {'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $name, 'description' => $desc}); - } - push(@items, $item); - } - return @items; -} - -sub parse_view_diary { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '<td ALIGN=center ROWSPAN=2 NOWRAP WIDTH=95 bgcolor=#FFD8B0>(\d{4})年(\d{2})月(\d{2})日<br>(\d{1,2}):(\d{2})</td>'; - my $re_subj = '<td BGCOLOR=#FFF4E0 WIDTH=430> (.+?)</td>'; - my $re_desc = '<td CLASS=h12>(.+?)</td>'; - my $re_c_date = '<td rowspan="2" align="center" width="95" bgcolor="#f2ddb7" nowrap>\n(\d{4})年(\d{2})月(\d{2})日<br>(\d{1,2}):(\d{2})'; - my $re_link = '<a href="?(.+?)"?>(.+?)<\/a>'; - if ($content =~ s/<tr VALIGN=top>.*?${re_date}.*?${re_subj}(.*?)${re_desc}(.+)//is) { - my ($time, $subj, $imgs, $desc, $comm) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8, $9); - my $level = { 'description' => $self->rewrite($2), 'link' => $self->absolute_url($1, $base) } if ($content =~ /<img src="([^"]+)" alt="([^"]+)" height="\d+" hspace="\d+" width="\d+">/); - ($desc, $subj) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($desc, $subj); - my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [], 'level' => $level }; - foreach my $image ($imgs =~ /<td width=130[^<>]*>(.*?)<\/td>/g) { - next unless ($image =~ /<a [^<>]*'show_picture.pl\?img_src=(.*?)'[^<>]*><img src=([^ ]*) border=0>/); - push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)}); - } - while ($comm =~ s/.*?${re_c_date}.*?${re_link}.*?${re_desc}.*?<\/table>//is){ - my ($time, $link, $name, $desc) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8); - ($name, $desc) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($name, $desc); - push(@{$item->{'comments'}}, {'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $name, 'description' => $desc}); - } - push(@items, $item); - } - return @items; -} - -sub parse_view_event { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '<td ROWSPAN=11 BGCOLOR=#FFD8B0 ALIGN=center VALIGN=top WIDTH=110>(\d{4})年(\d{2})月(\d{2})日<br>(\d{1,2}):(\d{2})</td>'; - my $re_subj = '<td BGCOLOR=#FFF4E0> (.+?)</td>'; - my $re_link = '<a href="?(.+?)"?>(.*?)<\/a>'; - my $re_hold = '<td BGCOLOR=#FFFFFF>\n (.*?)\n</td>'; - my $re_dead = '<td BGCOLOR=#FFFFFF> (.*?)</td>'; - my $re_desc = '<table BORDER=0 CELLSPACING=0 CELLPADDING=5>(.*?)</tr>'; - my $re_c_date = '<td ROWSPAN=.*?\n(\d{4})年(\d{2})月(\d{2})日<br>\n(\d{1,2}):(\d{2})<br>\n'; - my $re_c_desc = '<td CLASS="?h120"?>(.*?)\n</tr>'; - if ($content =~ s/<table BORDER=0 CELLSPACING=0 CELLPADDING=1 BGCOLOR=#DFA473>.*?${re_date}(.*?)${re_subj}.*?${re_link}.*?${re_hold}.*?${re_hold}.*?${re_desc}.*?${re_dead}(.*?)<!-- TOPIC: end -->(.*?)<!--フッタ-->//is) { - my ($time, $imgs, $subj, $link, $name, $date, $location, $desc, $deadline, $join, $comm) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8, $9, $10, $11, $12, $13, $14, $15); - if ($join =~ /VALUE=" イベントに参加する "/i) { $join = 1; - } elsif ($join =~ /VALUE=" 参加をキャンセルする "/i) { $join = 2; - } else { $join = 0; - } - ($desc, $subj) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($desc, $subj); - my $item = { 'time' => $time, 'description' => $desc, 'subject' => $subj, 'link' => $res->request->uri->as_string, 'images' => [], 'comments' => [] , 'name' => $name, 'name_link' => $self->absolute_url($link, $base), 'date' => $date, 'location' => $location, 'deadline' => $deadline, 'join' => $join}; - foreach my $image ($imgs =~ /<td width=130[^<>]*>(.*?)<\/td>/g) { - next unless ($image =~ /<a [^<>]*'show_picture.pl\?img_src=(.*?)'[^<>]*><img src=([^ ]*) border=0>/); - push(@{$item->{'images'}}, {'link' => $self->absolute_url($1, $base), 'thumb_link' => $self->absolute_url($2, $base)}); - } - while ($comm =~ s/${re_c_date}.*?${re_link}.*?${re_c_desc}//is) { - my ($time, $link, $name, $desc) = (sprintf('%04d/%02d/%02d %02d:%02d', $1,$2,$3,$4,$5), $6, $7, $8); - my $imgs; - ($imgs, $desc) = ($1, $2) if ($desc =~ /<table>(.+?)<\/table>.*?(.+?)<\/td>/); - ($name, $desc) = map { s/[\r\n]+//g; s/<br>/\n/g; $_ = $self->rewrite($_); } ($name, $desc); - push(@{$item->{'comments'}}, {'time' => $time, 'link' => $self->absolute_url($link, $base), 'name' => $name, 'description' => $desc}); - } - push(@items, $item); - } - return @items; -} - -sub parse_view_message { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - my $item = undef; - my $re_link = '<a href="(.+?)">(.+?)<\/'; - my $re_date = '(\d{4})年(\d{2})月(\d{2})日  (\d{1,2}):(\d{2})'; - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=555>(.*?)<\/table>/s) { - my $message = $1; - my @rows = split(/<\/tr>/, $message, 4); - my $image = $1 if ($rows[0] =~ /<td ALIGN=center.*?>.*?<img SRC="(.*?)" border=0>.*?<\/td>/i); - my ($link, $name) = ($1, $2) if ($rows[0] =~ /<td BGCOLOR=#FFF4E0.*?>.*?${re_link}.*?td>/i); - my $time = sprintf('%04d/%02d/%02d %02d:%02d', $1, $2, $3, $4, $5) if ($rows[1] =~ /${re_date}/); - my $subj = $1 if ($rows[2] =~ /<\/font> : (.*)<\/td>/); - my $desc = $1 if ($rows[3] =~ /<td CLASS=h120>(.*?)<\/td>/); - unless (grep { not $_ } ($image, $link, $name, $time, $subj, $desc)) { - $item = { - 'subject' => $self->rewrite($subj), - 'time' => $time, - 'name' => $self->rewrite($name), - 'link' => $self->absolute_url($link, $base), - 'image' => $self->absolute_url($image, $base), - 'description' => $self->rewrite($desc), - }; - } - } - return $item; -} - -sub parse_view_message_form { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - my @items = (); - while ($content =~ s/<form action="(.*?)"[^<>]*>(.*?)<\/form>//s) { - my $action = $1; - my $submit = $2; - $submit = ($submit =~ /<input TYPE=submit VALUE="(.*?)".*?>/) ? $1 : undef; - my $command = $1 if ($action =~ /([^\/\?]+)\.pl(\?[^\/]*)?$/); - my $item = { - 'action' => $self->absolute_url($action), - 'submit' => $submit, - 'command' => $command, - }; - push(@items, $item); - } - return @items; -} - -sub parse_add_diary_preview { - my $self = shift; - my @items = grep { $_ and $_->{'__action__'} =~ /\Qadd_diary.pl\E/ } $self->parse_standard_form(); - return @items; -} - -sub parse_add_diary_confirm { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $succeed = '作成が完了しました。'; - if ($content =~ /<table BORDER=0 CELLSPACING=0 CELLPADDING=5>(.*?)<\/form>/s) { - $content = $1; - if (index($content, $succeed) != -1) { - my $link = ($content =~ /<form action="(.*?)">/) ? $self->absolute_url($1, $base) : undef; - my $subj = $self->rewrite($content); - $subj =~ s/[\r\n]+//g; - push(@items, {'subject' => $subj, 'result' => 1, 'link' => $link }); - } - } - return @items; -} - -sub parse_delete_diary_preview { - my $self = shift; - my @items = grep { $_ and $_->{'__action__'} =~ /\Q_diary.pl\E/ } $self->parse_standard_form(); - return @items; -} - -sub parse_delete_diary_confirm { - my $self = shift; - return $self->parse_list_diary(@_); -} - -sub parse_edit_diary_preview { - my $self = shift; - my @items = grep { $_ and $_->{'__action__'} =~ /\Q_diary.pl\E/ } $self->parse_standard_form(); - return @items; -} - -sub parse_edit_diary_image { - my $self = shift; - my @items = (); - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - foreach my $photo ($content =~ /<td bgcolor="#f2ddb7">.*?<\/tr>/gs) { - my $subj = ($photo =~ /<font color="#996600">(.*?)<\/td>/) ? $1 : next; - my ($thumb, $link) = ($photo =~ /<img src="([^\n]*?)"><br>\n<a href="([^\n]*?)">削除<\/a>/) ? ($1, $2) : next; - my $item = { - 'subject' => $self->rewrite($subj), - 'link' => $self->absolute_url($link, $base), - 'thumb_link' => $self->absolute_url($thumb, $base), - }; - push(@items, $item); - } - return @items; -} - -sub parse_edit_diary_confirm { - my $self = shift; - return $self->parse_list_diary(@_); -} - -sub parse_send_message_preview { - my $self = shift; - my @items = grep { $_ and $_->{'__action__'} =~ /\Qsend_message.pl\E/ } $self->parse_standard_form(); - return @items; -} - -sub parse_send_message_confirm { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $succeed = '<b>送信完了</b>しました。'; - if ($content =~ /<tr>[^\n]*?<img src=[^ ]*?\/mail_send.gif WIDTH=25 HEIGHT=28>(.*?)<\/tr>/s) { - $content = $1; - if (index($content, $succeed) != -1) { - my $item = { 'subject' => $self->rewrite($succeed), 'result' => 1 }; - if ($content =~ /<a href=(banner.pl\?[^ ]*) class="img"><img src=([^ ]*?) [^<>]*? alt='([^']*)'>/) { #'{ - $item->{'banner'} = { - 'link' => $self->absolute_url($1, $base), - 'image' => $self->absolute_url($2, $base), - 'subject' => $self->rewrite($3), - }; - } - push(@items, $item) - } - } - return @items; -} - -sub get_main_menu { - my $self = shift; - my $url = (@_) ? shift : undef; - if ($url) { - $self->set_response($url, @_) or return; - } else { - return unless ($self->response); - return unless ($self->response->is_success); - } - return $self->parse_main_menu(); -} - -sub get_banner { - my $self = shift; - my $url = (@_) ? shift : undef; - if ($url) { - $self->set_response($url, @_) or return; - } else { - return unless ($self->response); - return unless ($self->response->is_success); - } - return $self->parse_banner(); -} - -sub get_tool_bar { - my $self = shift; - my $url = (@_) ? shift : undef; - if ($url) { - $self->set_response($url, @_) or return; - } else { - return unless ($self->response); - return unless ($self->response->is_success); - } - return $self->parse_tool_bar(); -} - -sub get_information { my $self = shift; return $self->get_standard_data('parse_information', 'home.pl', @_); } -sub get_home_new_album { my $self = shift; return $self->get_standard_data('parse_home_new_album', 'home.pl', @_); } -sub get_home_new_bbs { my $self = shift; return $self->get_standard_data('parse_home_new_bbs', 'home.pl', @_); } -sub get_home_new_comment { my $self = shift; return $self->get_standard_data('parse_home_new_comment', 'home.pl', @_); } -sub get_home_new_friend_diary { my $self = shift; return $self->get_standard_data('parse_home_new_friend_diary', 'home.pl', @_); } -sub get_home_new_review { my $self = shift; return $self->get_standard_data('parse_home_new_review', 'home.pl', @_); } - -sub get_ajax_new_diary { - my $self = shift; - my $url = 'ajax_new_diary.pll'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'friend_id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'friend_id'}) and length($param{'friend_id'}) and $url !~ /[\?\&]friend_id=/) { - $url .= ($url =~ /\?/) ? "&friend_id=$param{'friend_id'}" : "?friend_id=$param{'friend_id'}"; - } - return $self->get_standard_data('parse_ajax_new_diary', qr/ajax_new_diary\.pl/, $url, $refresh); -} - -sub get_community_id { - my $self = shift; - return $self->get_standard_data('parse_community_id', qr/view_community\.pl/, @_); -} - -sub get_list_bbs { - my $self = shift; - my $url = 'list_bbs.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - return $self->get_standard_data('parse_list_bbs', qr/list_bbs\.pl/, $url, $refresh); -} - -sub get_list_bbs_next { - my $self = shift; - my $url = 'list_bbs.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - $self->set_response($url, $refresh) or return; - return $self->parse_list_bbs_next(); -} - -sub get_list_bbs_previous { - my $self = shift; - my $url = 'list_bbs.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - $self->set_response($url, $refresh) or return; - return $self->parse_list_bbs_previous(); -} - -sub get_list_bookmark { - my $self = shift; - my $url = 'list_bookmark.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_bookmark(); -} - -sub get_list_comment { - my $self = shift; - my $url = 'list_comment.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_comment(); -} - -sub get_list_community { - my $self = shift; - my $url = 'list_community.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_community(); -} - -sub get_list_community_next { - my $self = shift; - my $url = 'list_community.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_community_next(); -} - -sub get_list_community_previous { - my $self = shift; - my $url = 'list_community.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_community_previous(); -} - -sub get_list_diary { - my $self = shift; - my $url = 'list_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_diary(); -} - -sub get_list_diary_capacity { - my $self = shift; - my $url = 'list_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_diary_capacity(); -} - -sub get_list_diary_next { - my $self = shift; - my $url = 'list_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_diary_next(); -} - -sub get_list_diary_previous { - my $self = shift; - my $url = 'list_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_diary_previous(); -} - -sub get_list_diary_monthly_menu { - my $self = shift; - my $url = 'list_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_diary_monthly_menu(); -} - -sub get_list_friend { - my $self = shift; - my $url = 'list_friend.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_friend(); -} - -sub get_list_friend_next { - my $self = shift; - my $url = 'list_friend.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_friend_next(); -} - -sub get_list_friend_previous { - my $self = shift; - my $url = 'list_friend.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_friend_previous(); -} - -sub get_list_member { - my $self = shift; - my $url = 'list_member.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - return $self->get_standard_data('parse_list_member', qr/list_member\.pl/, $url, $refresh); -} - -sub get_list_member_next { - my $self = shift; - my $url = 'list_member.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - $self->set_response($url, $refresh) or return; - return $self->parse_list_member_next(); -} - -sub get_list_member_previous { - my $self = shift; - my $url = 'list_member.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - $self->set_response($url, $refresh) or return; - return $self->parse_list_member_previous(); -} - -sub get_list_message { - my $self = shift; - my $url = 'list_message.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_message(); -} - -sub get_list_outbox { - my $self = shift; - my $url = 'list_message.pl?box=outbox'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_outbox(); -} - -sub get_list_request { - my $self = shift; - my $url = 'list_request.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_list_request(); -} - -sub get_new_album { - my $self = shift; - my $url = 'new_album.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_album(); -} - -sub get_new_bbs { - my $self = shift; - my $url = 'new_bbs.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_bbs(); -} - -sub get_new_bbs_next { - my $self = shift; - my $url = 'new_bbs.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_bbs_next(); -} - -sub get_new_bbs_previous { - my $self = shift; - my $url = 'new_bbs.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_bbs_previous(); -} - -sub get_new_comment { - my $self = shift; - my $url = 'new_comment.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_comment(); -} - -sub get_new_friend_diary { - my $self = shift; - my $url = 'new_friend_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_friend_diary(); -} - -sub get_new_friend_diary_next { - my $self = shift; - my $url = 'new_friend_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_friend_diary_next(); -} - -sub get_new_friend_diary_previous { - my $self = shift; - my $url = 'new_friend_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_friend_diary_previous(); -} - -sub get_new_review { - my $self = shift; - my $url = 'new_review.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_new_review(); -} - -sub get_release_info { - my $self = shift; - my $url = 'release_info.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_release_info(); -} - -sub get_self_id { - my $self = shift; - my $url = 'show_profile.pl'; - $self->set_response($url, @_) or return; - return $self->parse_self_id(); -} - -sub get_search_diary { - my $self = shift; - my $url = 'search_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'keyword'}) and length($param{'keyword'}) and $url !~ /[\?\&]keyword=/) { - $param{'keyword'} =~ s/([^\w ])/'%' . unpack('H2', $1)/eg; - $param{'keyword'} =~ tr/ /+/; - $url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}"; - } - @_ = grep { defined($_) } ($url, $refresh); - $self->set_response(@_) or return; - return $self->parse_search_diary(); -} - -sub get_search_diary_next { - my $self = shift; - my $url = 'search_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'keyword'}) and length($param{'keyword'}) and $url !~ /[\?\&]keyword=/) { - $param{'keyword'} =~ s/([^\w ])/'%' . unpack('H2', $1)/eg; - $param{'keyword'} =~ tr/ /+/; - $url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}"; - } - $self->set_response($url, $refresh) or return; - return $self->parse_search_diary_next(); -} - -sub get_search_diary_previous { - my $self = shift; - my $url = 'search_diary.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'keyword'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'keyword'}) and length($param{'keyword'}) and $url !~ /[\?\&]keyword=/) { - $param{'keyword'} =~ s/([^\w ])/'%' . unpack('H2', $1)/eg; - $param{'keyword'} =~ tr/ /+/; - $url .= ($url =~ /\?/) ? "&keyword=$param{'keyword'}" : "?keyword=$param{'keyword'}"; - } - $self->set_response($url, $refresh) or return; - return $self->parse_search_diary_previous(); -} - -sub get_show_calendar { - my $self = shift; - my $url = 'show_calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_calendar(); -} - -sub get_show_calendar_term { - my $self = shift; - my $url = 'show_calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_calendar_term(); -} - -sub get_show_calendar_next { - my $self = shift; - my $url = 'show_calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_calendar_next(); -} - -sub get_show_calendar_previous { - my $self = shift; - my $url = 'show_calendar.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_calendar_previous(); -} - -sub get_show_intro { - my $self = shift; - my $url = 'show_intro.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_intro(); -} - -sub get_show_log { - my $self = shift; - my $url = 'show_log.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_log(); -} - -sub get_show_log_count { - my $self = shift; - my $url = 'show_log.pl'; - $url = shift if (@_ and $_[0] ne 'refresh'); - $self->set_response($url, @_) or return; - return $self->parse_show_log_count(); -} - -sub get_show_friend_outline { - my $self = shift; - my $url = shift or return undef; - $self->set_response($url, @_) or return undef; - return $self->parse_show_friend_outline(); -} - -sub get_show_friend_profile { - my $self = shift; - my $url = shift or return undef; - $self->set_response($url, @_) or return undef; - return $self->parse_show_friend_profile(); -} - -sub get_view_album { - my $self = shift; - my $url = 'view_album.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - return $self->get_standard_data('parse_view_album', qr/view_album\.pl/, $url, $refresh); -} - -sub get_view_album_comment { - my $self = shift; - my $url = 'view_album.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}&mode=comment"; - } - return $self->get_standard_data('parse_view_album_comment', qr/view_album\.pl/, $url, $refresh); -} - -sub get_view_album_photo { - my $self = shift; - my $url = 'view_album.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - return $self->get_standard_data('parse_view_album_photo', qr/view_album\.pl/, $url, $refresh); -} - -sub get_view_bbs { - my $self = shift; - my $url = shift or return; - $self->set_response($url, @_) or return undef; - return $self->parse_view_bbs(); -} - -sub get_view_community { - my $self = shift; - my $url = 'view_community.pl'; - $url = shift if (@_ and $_[0] ne 'refresh' and $_[0] ne 'id'); - my $refresh = shift if (@_ and $_[0] eq 'refresh'); - my %param = @_; - if (defined($param{'id'}) and length($param{'id'}) and $url !~ /[\?\&]id=/) { - $url .= ($url =~ /\?/) ? "&id=$param{'id'}" : "?id=$param{'id'}"; - } - return $self->get_standard_data('parse_view_community', qr/view_community\.pl/, $url, $refresh); -} - -sub get_view_diary { - my $self = shift; - my $url = shift or return; - $self->set_response($url, @_) or return undef; - return $self->parse_view_diary(); -} - -sub get_view_event { - my $self = shift; - my $url = shift or return; - $self->set_response($url, @_) or return undef; - return $self->parse_view_event(); -} - -sub get_view_message { - my $self = shift; - my $url = shift or return undef; - $self->set_response($url, @_) or return undef; - return $self->parse_view_message(); -} - -sub get_view_message_form { - my $self = shift; - my $url = shift or return; - $self->set_response($url, @_) or return; - return $self->parse_view_message_form(); -} - -sub get_add_diary_preview { - my $self = shift; - my %form = @_; - $form{'submit'} = 'main'; - my $response = $self->post_add_diary(%form); - return if ($@ or not $response); - return $self->parse_add_diary_preview(); -} - -sub get_add_diary_confirm { - my $self = shift; - my %form = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_; - my $url = 'add_diary.pl'; - my @files = qw(photo1 photo2 photo3); - # POSTキー未取得、または写真があればプレビュー投稿 - if (not $form{'post_key'} or grep { $form{$_} } @files) { - my @forms = grep {$_->{'submit'} eq 'confirm'} $self->get_add_diary_preview(%form); - return 0 if ($self->response->is_error); - return 0 unless (@forms); - %form = %{$forms[0]}; - $self->log("[info] プレビューページを取得しました。\n"); - $self->dumper_log(\%form); - } - # 投稿 - $form{'submit'} = 'confirm'; - $self->post_add_diary(%form) or return; - return $self->parse_add_diary_confirm(); -} - -sub get_delete_diary_preview { - my $self = shift; - my %form = @_; - $self->post_delete_diary(%form) or return; - return $self->parse_delete_diary_preview(); -} - -sub get_delete_diary_confirm { - my $self = shift; - my %form = @_; - # 投稿 - $form{'submit'} = 'confirm'; - $self->post_delete_diary(%form) or return; - return $self->parse_delete_diary_confirm(); -} - -sub get_edit_diary_preview { - my $self = shift; - my $url = shift or return undef; - $self->set_response($url, @_) or return undef; - return $self->parse_edit_diary_preview(); -} - -sub get_edit_diary_image { - my $self = shift; - my $url = shift or return undef; - $self->set_response($url, @_) or return undef; - return $self->parse_edit_diary_image(); -} - -sub get_edit_diary_confirm { - my $self = shift; - my %form = @_; - # 投稿 - $form{'submit'} = 'main'; - $self->post_edit_diary(%form) or return; - return $self->parse_edit_diary_confirm(); -} - -sub get_send_message_preview { - my $self = shift; - my %form = @_; - $form{'submit'} = 'main'; - $self->post_send_message(%form) or return; - return $self->parse_send_message_preview(); -} - -sub get_send_message_confirm { - my $self = shift; - my %form = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_; - $form{'submit'} = 'confirm'; - $form{'yes'} = ' 送 信 ' unless ($form{'yes'}); - #post key未取得ならプレビュー投稿 - if (not $form{'post_key'} or not $form{'yes'}) { - my @forms = grep {$_->{'submit'} eq 'confirm'} $self->get_send_message_preview(%form); - return 0 if ($self->response->is_error); - return 0 unless (@forms); - %form = %{$forms[0]}; - $self->log("[info] プレビューページを取得しました。\n"); - $self->dumper_log(\%form); - } - # 送信 - $self->post_send_message(%form) or return; - return $self->parse_send_message_confirm(); -} - -sub absolute_url { - my $self = shift; - my $url = shift; - my $base = (@_) ? shift : $self->{'mixi'}->{'base'}; - return undef unless (length($url)); - $url =~ s/^"(.*)"$/$1/ or $url =~ s/^'(.*)'$/$1/; - $url .= '.pl' if ($url and $url !~ /[\/\.]/); - return URI->new($url)->abs($base)->as_string; -} - -sub absolute_linked_url { - my $self = shift; - my $url = shift; - return $url unless ($url and $self->response()); - my $base = $self->response->base->as_string; - return $self->absolute_url($url, $base); -} - -sub query_sorted_url { - my $self = shift; - my $url = shift; - return undef unless ($url); - if ($url =~ s/\?(.*)$//) { - my $qurey_string = join('&', map {join('=', @{$_})} - map { $_->[1] =~ s/%20/+/g if @{$_} == 2; $_; } - sort {$a->[0] cmp $b->[0]} - map {[split(/=/, $_, 2)]} split(/&/, $1)); - $url = "$url?$qurey_string"; - } - return $url; -} - -sub enable_cookies { - my $self = shift; - unless ($self->cookie_jar) { - my $cookie = sprintf('cookie_%s_%s.txt', $$, time); - $self->cookie_jar(HTTP::Cookies->new(file => $cookie, ignore_discard => 1)); - $self->log("[info] Cookieを有効にしました。\n"); - } - return $self; -} - -sub save_cookies { - my $self = shift; - my $file = shift; - my $info = ''; - my $result = 0; - if (not $self->cookie_jar) { - $info = "[error] Cookieが無効です。\n"; - } elsif (not $file) { - $info = "[error] Cookieを保存するファイル名が指定されませんでした。\n"; - } else { - $info = "[info] Cookieを\"${file}\"に保存します。\n"; - $result = eval "\$self->cookie_jar->save(\$file)"; - $info .= "[error] $@\n" if ($@); - } - return $result; -} - -sub load_cookies { - my $self = shift; - my $file = shift; - my $info = ''; - my $result = 0; - if (not $file){ - $info = "[error] Cookieを読み込むファイル名が指定されませんでした。\n"; - } elsif (not $file) { - $info = "[error] Cookieファイル\"${file}\"が存在しません。\n"; - } else { - $info = "[info] Cookieを\"${file}\"から読み込みます。\n"; - $self->enable_cookies; - $result = eval "\$self->cookie_jar->load(\$file)"; - $info .= "[error] $@\n" if ($@); - } - return $result; -} - -sub log { - my $self = shift; - return &{$self->{'mixi'}->{'log'}}($self, @_); -} - -sub dumper_log { - my $self = shift; - my @logs = @_; - if (not defined($self->{'mixi'}->{'dumper'})) { - eval "use Data::Dumper"; - $self->{'mixi'}->{'dumper'} = ($@) ? 0 : Data::Dumper->can('Dumper'); - $self->log("[warn] Data::Dumper is not available : $@\n") unless ($self->{'mixi'}->{'dumper'}); - } - if ($self->{'mixi'}->{'dumper'}) { - local $Data::Dumper::Indent = 1; - my $log = &{$self->{'mixi'}->{'dumper'}}([@logs]); - $log =~ s/\n/\n /g; - $log =~ s/\s+$/\n/s; - return $self->log(" $log"); - } else { - return $self->log(" [dumper] " . join(', ', @logs) . "\n"); - } -} - -sub abort { - my $self = shift; - return &{$self->{'mixi'}->{'abort'}}($self, @_); -} - -sub callback_log { - eval "use Jcode"; - my $use_jcode = ($@) ? 0 : 1; - my $self = shift; - my @logs = @_; - my $error = 0; - foreach my $log (@logs) { - eval '$log = jcode($log, "euc")->sjis' if ($use_jcode); - if ($log !~ /^(\s|\[.*?\])/) { print $log; } - elsif ($log =~ /^\[error\]/) { print $log; $error = 1; } - elsif ($log =~ /^\[usage\]/) { print $log; } - elsif ($log =~ /^\[warn\]/) { print $log; } -# elsif ($log =~ /^\[info\]/) { print $log; } # useful for debugging -# elsif ($log =~ /^\s/) { print $log; } # useful for debugging -# else { print $log; } # useful for debugging - } - $self->abort if ($error); - return $self; -} - -sub callback_abort { - die @_; -} - -sub rewrite { - my $self = shift; - return &{$self->{'mixi'}->{'rewrite'}}($self, @_); -} - -sub callback_rewrite { - my $self = shift; - my $str = shift; - $str = $self->remove_tag($str); - $str = $self->unescape($str); - $str =~ s/\s+$//s; - return $str; -} - -sub escape { - my $self = shift; - my $str = shift; - my %escaped = ('&' => '&', '"' => '"', '>' => '>', '<' => '<'); - my $re_target = join('|', keys(%escaped)); - $str =~ s/($re_target)/$escaped{$1}/g; - return $str; -} - -sub unescape { - my $self = shift; - my $str = shift; - my %unescaped = ('amp' => '&', 'quot' => '"', 'gt' => '>', 'lt' => '<', 'nbsp' => ' ', 'apos' => "'", 'copy' => '(c)'); - my $re_target = join('|', keys(%unescaped)); - $str =~ s/&($re_target|#x([0-9a-z]+));/defined($unescaped{$1}) ? $unescaped{$1} : defined($2) ? chr(hex($2)) : "&$1;"/ige; - return $str; -} - -sub remove_tag { - my $self = shift; - my $str = shift; - my $re_standard_tag = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; - my $re_comment_tag = '<!(?:--[^-]*-(?:[^-]+-)*?-(?:[^>-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)'; - my $re_html_tag = qq{$re_comment_tag|<$re_standard_tag}; - $str =~ s/$re_html_tag//g; - return $str; -} - -sub remove_diary_tag { - my $self = shift; - my $str = shift; - my $re_diary_tag = join('|', - q{<a HREF="[^"]*" target="_blank">}, - q{<a href="[^"]*" onClick="MM_openBrWindow\([^"]*\)">}, - q{<img alt=写真 src=\S* border=0>}, - q{<span (?:class|style)="[^"]*">}, - q{<(?:blockquote|u|em|strong)>}, - q{<\/(?:a|blockquote|u|em|span|strong)>} - ); - $str =~ s/$re_diary_tag//g; - return $str; -} - -sub redirect_ok { - return 1; -} - -sub get_standard_data { - # default url is pased, so url is not necessary. - my $self = shift; - my $parser = shift; - my $def_url = shift; # defined url - my $url = shift if (@_ and $_[0] ne 'refresh'); # specified url - if (defined($def_url) and ref($def_url) eq 'Regexp') { - return unless (defined($url) and length($url)); - return unless ($url =~ $def_url); - } elsif (not (ref($url) eq '' and length($url))) { - $url = $def_url; - } - $self->abort("url \"$url\" is invalid.") unless (defined($url) and length($url)); # invalid url - $self->can($parser) or $self->abort("parser \"$parser\" is not available."); # invalid method - $self->set_response($url, @_) or $self->abort("set_response failed."); # request can not processed - return $self->$parser(); -} - -sub parse_standard_history { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - my $re_date = '(?:(\d{4})年)?(\d{2})月(\d{2})日 (\d{1,2}):(\d{2})'; - my $re_link = '<a [^<>]*href="?([^<> ]*?)"?(?: [^<>]*)?>(.*?)<\/a>'; - my $re_name = '\((.*?)\)'; - if ($content =~ /<table BORDER=0 CELLSPACING=1 CELLPADDING=4 WIDTH=630>(.+?)<\/table>/s) { - $content = $1; - my @today = reverse((localtime)[3..5]); - $today[0] += 1900; - $today[1] += 1; - foreach my $row ($content =~ /<tr bgcolor=#FFFFFF>(.*?)<\/tr>/isg) { - $row =~ s/\s*[\r\n]\s*//gs; - my @cols = ($row =~ /<td[^<>]*>(.*?)<\/td>/gs); - my $item = {}; - next unless ($cols[0] =~ s/$re_date//); - my @date = ($1, $2, $3, $4, $5); - next unless ($cols[1] =~ /${re_link}\s*$re_name/); - $item->{'link'} = $self->absolute_url($1, $base); - $item->{'subject'} = (defined($2) and length($2)) ? $self->rewrite($2) : '(削除)'; - $item->{'name'} = $self->rewrite($3); - $date[0] = ($date[1] > $today[1]) ? $today[0] - 1 : $today[0] if (not defined($date[0])); - $item->{'time'} = sprintf('%04d/%02d/%02d %02d:%02d', @date); - map { $item->{$_} =~ s/^\s+|\s+$//gs } (keys(%{$item})); - if ($cols[1] =~ /(<a [^>]*>)\s*(<img [^>]*>)\s*<\/a>/is) { - my $image = {}; - my @tags = ($1, $2); - if ($_ = $self->parse_standard_tag($tags[0]) and $_->{'attr'}->{'href'} or $_->{'attr'}->{'onclick'}) { - $_ = ($_->{'attr'}->{'onclick'}) ? $_->{'attr'}->{'onclick'} : $_->{'attr'}->{'href'}; - $_ = $1 if ($_ =~ /MM_openBrWindow\('(.*?)'/); - $item->{'image'}->{'link'} = $self->absolute_url($_, $base); - } - $item->{'image'}->{'src'} = $self->absolute_url($_, $base) if ($_ = $self->parse_standard_tag($tags[1]) and $_ = $_->{'attr'}->{'src'}); - } - push(@items, $item); - } - } - return @items; -} - -sub parse_standard_history_next { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5>[^\r\n]*?<a href=["']?([^>]+?)['"]?>([^<>]+)<\/a><\/td><\/tr>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $next = {'link' => $link, 'subject' => $2}; - return $next; -} - -sub parse_standard_history_previous { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->request->uri->as_string; - my $content = $res->content; - return unless ($content =~ /<td ALIGN=right BGCOLOR=#EED6B5><a href=["']?(.+?)['"]?>([^<>]+)<\/a>[^\r\n]*?<\/td><\/tr>/); - my $subject = $2; - my $link = $self->absolute_url($1, $base); - my $previous = {'link' => $link, 'subject' => $2}; - return $previous; -} - -sub parse_standard_form { - my $self = shift; - my $res = (@_) ? shift : $self->response(); - return unless ($res and $res->is_success); - my $base = $res->base->as_string; - my $content = $res->content; - my @items = (); - if ($res->is_success and $content =~ /<tr>.*?<img src=["']?http:\/\/[^<> ]*\/alt.gif['" ].*?>(.*?)<\/tr>/s) { - my $message = $1; - $message =~ s/\n//g; - $message =~ s/<br>|<br ?\/>|<\/br>/\n/g; - $res->code(400); - $res->message($self->rewrite($message)); - return; - } - while ($content =~ s/(<form (?:"[^"]*"|'[^']*'|[^'"<>]*)*>)(.*?)<\/form>//is) { - my $tag = $1; - my $form = $2; - my $action = ($tag =~ /\baction=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : ""; - $action =~ s/^"(.*)"$/$1/s or $action =~ s/^'(.*)'$/$1/s; - my $item = {'__action__' => $self->absolute_url($action, $base)}; - foreach my $tag ($form =~ /<input (?:"[^"]*"|'[^']*'|[^'"<>]*)*>/g) { - my $name = ($tag =~ /\bname=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : ""; - my $value = ($tag =~ /\bvalue=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : ""; - ($name, $value) = map { s/^"(.*)"$/$1/s or s/^'(.*)'$/$1/s; $_ } ($name, $value); - $item->{$name} = $self->rewrite($value) if (length($name)); - } - while ($form =~ s/<textarea ((?:"[^"]*"|'[^']*'|[^'"<>]*)*)>(.*?)<\/textarea.*?>//s) { - my ($attrs, $value) = ($1, $2); - my $name = ($attrs =~ /\bname=("[^"]*"|'[^']*'|[^'"<> ]*)/) ? $1 : ""; - ($name) = map { s/^"(.*)"$/$1/s or s/^'(.*)'$/$1/s; $_ } ($name); - $item->{$name} = $self->rewrite($value) if (length($name)); - } - push(@items, $item); - } - return @items; -} - -sub parse_standard_tag { - my $self = shift; - my $str = shift; - return undef unless ($str =~ s/^\s*<(.*)>\s*$/$1/s); - return undef if ($str =~ /^\!--/); - my $re_word = q{[^"'<>\s=]+}; #"]} - my $re_quote = q{(?:"[^"]*"|'[^']*')}; #")} - my $re_pair = qq{$re_word\\s*=\\s*(?:$re_quote|$re_word\\((?:[^)]*|$re_quote)*\\)|[^"'<>\\s]+)?}; - my $re_parse = qq{$re_pair|$re_word|$re_quote}; - my @parsed = ($str =~ /$re_parse/gs); - my $tag = lc(shift(@parsed)); - @parsed = map { /^($re_word)\s*=\s*(.*)$/ ? (lc($1) => $2) : (lc($_) => '') } @parsed; - @parsed = map { /^\s*=\s*$/ ? '=' :/^"(.*)"$/ ? $1 : /^'(.*)'$/ ? $1 : $_ } @parsed; - return { 'tag' => $tag, , 'attr' => {@parsed} }; -} - -sub set_response { - my $self = shift; - my $url = shift; - my $refresh = (@_ and defined($_[0]) and $_[0] eq 'refresh') ? 1 : 0; - my $latest = ($self->response) ? $self->response->request->uri->as_string : undef; - $url = $self->query_sorted_url($self->absolute_url($url)); - return 0 unless ($url); - return 1 if ($url eq $latest and not $refresh and $self->response->is_success); - $self->get($url); - return 0 unless ($self->response); - return 0 unless ($self->response->is_success); - return 1; -} - -sub post_add_diary { - my $self = shift; - my %values = @_; - my $url = 'add_diary.pl'; - my @fields = qw(submit diary_title diary_body photo1 photo2 photo3 orig_size packed post_key); - my @required = qw(submit diary_title diary_body); - my @files = qw(photo1 photo2 photo3); - my %label = ('diary_title' => '日記のタイトル', 'diary_body' => '日記の本文', 'photo1' => '写真1', 'photo2' => '写真2', 'photo3' => '写真3', orig_size => '圧縮指定', packed => '送信データ', 'post_key' => '送信キー'); - my @errors; - # データの生成とチェック - my %form = map { $_ => $values{$_} } @fields; - push @errors, map { "$label{$_}を指定してください。" } grep { not $form{$_} } @required; - if ($form{'submit'} eq 'main') { - # プレビュー用の追加処理 - foreach my $file (@files) { - next unless ($form{$file}); - if (not -f $form{$file}) { - push @errors, "[info] $label{$file}のファイル\"$form{$file}\"がありません。\n" ; - } else { - $form{$file} = [$form{$file}]; - } - } - } - if (@errors) { - $self->log(join('', @errors)); - return undef; - } - return $self->post($url, %form); -} - -sub post_edit_diary { - my $self = shift; - my %values = @_; - $self->dumper_log(\%values); - my $url = exists($values{'__action__'}) ? $values{'__action__'} : 'edit_diary.pl?id=' . $values{'id'}; - my @fields = qw(submit diary_title diary_body photo1 photo2 photo3 submit post_key); - my @required = qw(submit diary_title diary_body); - my @files = qw(photo1 photo2 photo3); - my %label = ('id' => '日記ID', 'diary_title' => '日記のタイトル', 'diary_body' => '日記の本文', 'photo1' => '写真1', 'photo2' => '写真2', 'photo3' => '写真3', 'post_key' => '送信キー'); - my @errors; - # データの生成とチェック - my %form = map { $_ => $values{$_} } @fields; - push @errors, "[error] $label{'id'}を指定してください。\n" if ($url !~ /[\?&]id=\d+/); - push @errors, map { "[error] $label{$_}を指定してください。\n" } grep { not $form{$_} } @required; - # ファイル追加処理 - foreach my $file (@files) { - next unless ($form{$file}); - if (not -f $form{$file}) { - push @errors, "[info] $label{$file}のファイル\"$form{$file}\"がありません。\n" ; - } else { - $form{$file} = [$form{$file}]; - } - } - if (@errors) { - $self->log(join('', @errors)); - return undef; - } - return $self->post($url, %form); -} - -sub post_delete_diary { - my $self = shift; - my %values = @_; - my $url = 'delete_diary.pl'; - my @fields = qw(submit id post_key); - my @required = qw(id post_key); - my %label = ('id' => '日記ID', 'post_key' => '送信キー'); - # データの生成とチェック - my %form = map {$_ => $values{$_}} @fields; - $form{'id'} = $1 if ($values{'__action__'} and $values{'__action__'} =~ /delete_diary.pl?id=(\d+)/); - my @errors = map { "$label{$_}を指定してください。" } grep { not $form{$_} } @required; - if (@errors) { - $self->log(map { "[warn] $_\n" } @errors); - return undef; - } - $url .= "?id=" . delete($form{'id'}); - return $self->post($url, %form); -} - -sub post_send_message { - my $self = shift; - my %values = @_; - my $url = exists($values{'__action__'}) ? $values{'__action__'} : 'send_message.pl?id=' . $values{'id'}; - my @fields = qw(submit subject body post_key yes no); - my @required = qw(submit subject body); - my %label = ('id' => '受信者のID', 'subject' => 'メッセージのタイトル', 'body' => 'メッセージの本文', 'post_key' => '送信キー'); - my %form = map { $_ => $values{$_} } @fields; - my @errors = map { "$label{$_}を指定してください。" } grep { not $form{$_} } @required; - push(@errors, "$label{'id'}を指定してください。") if ($url !~ /[\?&]id=\d+/); - if (@errors) { - $self->log(map { "[warn] $_\n" } @errors); - return undef; - } - delete($form{'no'}) if ($form{'yes'} and $form{'no'}); # プレビューを解析すると'yes'、'no'が両方入るため、択一 - return $self->post($url, %form); -} - -sub convert_login_time { - my $self = shift; - my $time = @_ ? shift : 0; - if ($time =~ /^\d+$/) { 1; } - elsif ($time =~ /^(\d+)分/) { $time = $1 * 60; } - elsif ($time =~ /^(\d+)時間/) { $time = $1 * 60 * 60; } - elsif ($time =~ /^(\d+)日/) { $time = $1 * 60 * 60 * 24; } - else { $self->log("[error] ログイン時刻\"$time\"を解析できませんでした。\n"); } - $time = time() - $time; - my @date = localtime($time); - $time = sprintf('%04d/%02d/%02d %02d:%02d', $date[5] + 1900, $date[4] + 1, $date[3], $date[2], $date[1]); - return $time; -} - -sub test { - $| = 1; - my $mail = (@_) ? shift : $ENV{'MIXI_MAIL'}; - my $pass = (@_) ? shift : $ENV{'MIXI_PASS'}; - my $log = (@_) ? shift : "WWW-Mixi-${VERSION}-test.log"; - - open(OUT, ">$log"); - my $logger = &test_logger; - my $error = undef; - my @items = (); - unless ($mail and $pass) { - - &{$logger}("mixiにログインできるメールアドレスとパスワードを指定してください。\n"); - &{$logger}("[usage] perl -MWWW::Mixi -e \"WWW::Mixi::test('mail\@address', 'password');\"\n"); - exit 1; - } - my ($result, $response) = (); - # オブジェクトの生成 - my $mixi = &test_new($mail, $pass, $logger); # オブジェクトの生成 - $mixi->test_login; # ログイン - $mixi->test_get; # GET(トップページ) - $mixi->test_scenario; # 主要データの取得と解析 - $mixi->test_get_add_diary_preview; # 日記のプレビュー - $mixi->test_save_and_read_cookies; # Cookieの読み書き - # 終了 - $mixi->log("終了しました。\n"); - $mixi->dumper_log({'テストレコード' => $mixi->{'__test_record'}, 'テストリンク' => $mixi->{'__test_link'}}); - exit 0; -} - -sub test_logger { - return sub { - eval "use Jcode"; - my $use_jcode = ($@) ? 0 : 1; - my $self = shift if (ref($_[0])); - my @logs = @_; - my $error = 0; - foreach my $log (@logs) { - eval '$log = jcode($log, "euc")->sjis' if ($use_jcode); - if ($log !~ /^(\s|\[.*?\])/) { print OUT $log; print $log; } - elsif ($log =~ /^\[error\]/) { print OUT $log; print $log; $error = 1; } - elsif ($log =~ /^\[usage\]/) { print OUT $log; print $log; } - elsif ($log =~ /^\[warn\]/) { print OUT $log; print $log; } - elsif ($log =~ /^\[info\]/) { print OUT $log; print $log; } # useful for debugging - elsif ($log =~ /^\s/) { print OUT $log; } # useful for debugging - else { print OUT $log; } # useful for debugging - } - return $self; - }; -} - -sub test_new { - my ($mail, $pass, $logger) = @_; - my $error = ''; - &{$logger}("オブジェクトを生成します。\n"); - my $mixi = eval "WWW::Mixi->new('$mail', '$pass', '-log' => \$logger)"; - if ($@) { - $error = "[error] $@\n"; - } elsif (not $mixi) { - $error = "[error] 不明なエラーです。\n"; - } elsif (not $mixi->{'mixi'}) { - $error = "[error] mixi関連情報を設定できませんでした。\n"; - } - if ($error) { - &{$logger}({}, "オブジェクトを生成できませんでした。\n", $error); - exit 8; - } - $mixi->delay(0); - $mixi->env_proxy; - return $mixi; -} - -sub test_login { - my $mixi = shift; - my $error = ''; - $mixi->log("mixiにログインします。\n"); - my ($result, $response) = eval '$mixi->login'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not $result) { - if (not $response->is_success) { - $error = sprintf("[error] %d %s\n", $response->code, $response->message); - $error .= "[info] Webアクセスにプロキシが必要な時は、環境変数HTTP_PROXYをセットしてから再試行してください。\n" unless($ENV{'HTTP_PROXY'}); - } elsif ($mixi->is_login_required($response)) { - $error = "[error] " . $mixi->is_login_required($response) . "\n"; - } elsif (not $mixi->session) { - $error = "[error] セッションIDを取得できませんでした。\n"; - } elsif (not $mixi->stamp) { - $error = "[error] セッションスタンプを取得できませんでした。\n"; - } elsif (not $mixi->session) { - $error = "[error] リフレッシュURLを取得できませんでした。\n"; - } - } - if ($error) { - $mixi->log("ログインできませんでした。\n", $error); - $mixi->dumper_log($response); - exit 8; - } else { - $mixi->log('[info] セッションIDは"' . $mixi->session . "\"です。\n"); - } -} - -sub test_get { - my $mixi = shift; - my $error = ''; - $mixi->log("トップページを取得します。\n"); - my $response = eval '$mixi->get("home")'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not $response->is_success) { - $error = sprintf("[error] %d %s\n", $response->code, $response->message); - $error .= "[info] Webアクセスにプロキシが必要な時は、環境変数HTTP_PROXYをセットしてから再試行してください。\n" unless($ENV{'HTTP_PROXY'}); - } elsif ($mixi->is_login_required($response)) { - $error = "[error] " . $mixi->is_login_required($response) . "\n"; - } - if ($error) { - $mixi->log("トップページの取得に失敗しました。\n", $error); - $mixi->dumper_log($response); - exit 8; - } -} - -sub test_record { - my $mixi = shift; - $mixi->{'__test_record'} = {} unless (ref($mixi->{'__test_record'}) eq 'HASH'); - if (@_ == 0) { - return sort { $a cmp $b } (keys(%{$mixi->{'__test_record'}})); - } elsif (@_ == 1) { - my $key = shift; - return $mixi->{'__test_record'}->{$key}; - } else { - my %args = @_; - map { $mixi->{'__test_record'}->{$_} = $args{$_} } keys(%args); - return 1; - } -} - -sub test_link { - my $mixi = shift; - $mixi->{'__test_link'} = {} unless (ref($mixi->{'__test_link'}) eq 'HASH'); - if (@_ == 0) { - return sort { $a cmp $b } (keys(%{$mixi->{'__test_link'}})); - } elsif (@_ == 1) { - my $key = shift; - return $mixi->{'__test_link'}->{$key}; - } else { - my $key = shift; - foreach my $item (grep { ref($_) eq 'HASH' } @_) { - foreach (values(%{$item})) { - foreach my $value (ref($_) eq 'HASH' ? values(%{$_}) : $_) { - next if (ref($value) ne '' or $value =~ /\s/); - next if ($value !~ /^https?:\/\/(?:[^\/]*].)?mixi.jp\/(?:[^\?]*\/)?([^\/\?]+).*$/); - next if ($mixi->{'__test_link'}->{$1}); - $mixi->{'__test_link'}->{$1} = $value; - } - } - } - return 1; - } -} - -sub test_scenario { - my $mixi = shift; - my @tests = ( - # 引数不要のもの - 'main_menu' => {'label' => 'メインメニュー'}, - 'banner' => {'label' => 'バナー'}, - 'tool_bar' => {'label' => 'ツールバー'}, - 'information' => {'label' => '管理者からのお知らせ'}, - 'home_new_album' => {'label' => 'ホームのマイミクシィ最新アルバム'}, - 'home_new_bbs' => {'label' => 'ホームのコミュニティ最新書き込み'}, - 'home_new_comment' => {'label' => 'ホームの日記コメント記入履歴'}, - 'home_new_friend_diary' => {'label' => 'ホームのマイミクシィ最新日記'}, - 'home_new_review' => {'label' => 'ホームのマイミクシィ最新レビュー'}, - 'list_bookmark' => {'label' => 'お気に入り'}, - 'list_comment' => {'label' => '最近のコメント'}, - 'list_community' => {'label' => 'コミュニティ一覧'}, - 'list_community_next' => {'label' => 'コミュニティ一覧(次)'}, - 'list_community_previous' => {'label' => 'コミュニティ一覧(前)', 'url' => sub { return $_[0]->test_record('list_community_next')}}, - 'list_diary' => {'label' => '日記'}, - 'list_diary_capacity' => {'label' => '日記容量'}, - 'list_diary_next' => {'label' => '日記(次)'}, - 'list_diary_previous' => {'label' => '日記(前)', 'url' => sub { return $_[0]->test_record('list_diary_next')}}, - 'list_diary_monthly_menu' => {'label' => '日記月別ページ'}, - 'list_friend' => {'label' => '友人・知人一覧'}, - 'list_friend_next' => {'label' => '友人・知人一覧(次)'}, - 'list_friend_previous' => {'label' => '友人・知人一覧(前)', 'url' => sub { return $_[0]->test_record('list_friend_next')}}, - 'list_message' => {'label' => '受信メッセージ'}, - 'list_outbox' => {'label' => '送信メッセージ'}, - 'list_request' => {'label' => '承認待ちの友人'}, - 'new_album' => {'label' => 'マイミクシィ最新アルバム'}, - 'new_bbs' => {'label' => 'コミュニティ最新書き込み'}, - 'new_bbs_next' => {'label' => 'コミュニティ最新書き込み(次)'}, - 'new_bbs_previous' => {'label' => 'コミュニティ最新書き込み(前)', 'url' => sub { return $_[0]->test_record('new_bbs_next')}}, - 'new_comment' => {'label' => '日記コメント記入履歴'}, - 'new_friend_diary' => {'label' => 'マイミクシィ最新日記'}, - 'new_friend_diary_next' => {'label' => 'マイミクシィ最新日記(次)'}, - 'new_friend_diary_previous' => {'label' => 'マイミクシィ最新日記(前)', 'url' => sub { return $_[0]->test_record('new_friend_diary_next')}}, - 'ajax_new_diary' => {'label' => 'マイミクシィの最新日記(Ajax版)', 'url' => sub { return $_[0]->test_link('ajax_new_diary.pl') }}, - 'new_review' => {'label' => 'マイミクシィ最新レビュー'}, - 'release_info' => {'label' => 'リリースインフォメーション'}, - 'self_id' => {'label' => '自分のID'}, - 'search_diary' => {'label' => '新着日記検索', 'arg' => ['keyword' => 'Mixi']}, - 'search_diary_next' => {'label' => '新着日記検索(次)', 'arg' => ['keyword' => 'Mixi']}, - 'search_diary_previous' => {'label' => '新着日記検索(前)', 'url' => sub { return $_[0]->test_record('search_diary_next')}}, - 'show_calendar' => {'label' => 'カレンダー'}, - 'show_calendar_term' => {'label' => 'カレンダーの期間'}, - 'show_calendar_next' => {'label' => 'カレンダー(次)'}, - 'show_calendar_previous' => {'label' => 'カレンダー(前)', 'url' => sub { return $_[0]->test_record('show_calendar_next')}}, - 'show_intro' => {'label' => 'マイミクシィからの紹介文'}, - 'show_log' => {'label' => 'あしあと'}, - 'show_log_count' => {'label' => 'あしあと数'}, - # コンテンツ - 'view_album' => {'label' => 'フォトアルバム', 'url' => sub { return $_[0]->test_record('new_album')}}, - 'view_album_photo' => {'label' => 'フォトアルバムの写真', 'url' => sub { $_ = $_[0]->test_record('new_album'); return ref($_) eq 'HASH' ? $_->{'link'} : undef }}, - 'view_album_comment' => {'label' => 'フォトアルバムのコメント', 'url' => sub { $_ = $_[0]->test_record('new_album'); return ref($_) eq 'HASH' ? $_->{'link'} . '&mode=comment' : undef }}, - 'view_diary' => {'label' => '日記(詳細)', 'url' => sub { return $_[0]->test_record('list_diary')}}, - 'view_event' => {'label' => 'イベント', 'url' => sub { return $_[0]->test_link('view_event.pl')}}, - 'view_message' => {'label' => 'メッセージ(詳細)', 'url' => sub { return $_[0]->test_record('list_message')}}, - # コミュニティ関連 - 'community_id' => {'label' => 'コミュニティID', 'url' => sub { return $_[0]->test_record('list_community')}}, - 'list_bbs' => {'label' => 'トピック一覧', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, - 'list_bbs_next' => {'label' => 'トピック一覧(次)', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, - 'list_bbs_previous' => {'label' => 'トピック一覧(前)', 'url' => sub { return $_[0]->test_record('list_bbs_next')}}, - 'list_member' => {'label' => 'メンバー一覧', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, - 'list_member_next' => {'label' => 'メンバー一覧(次)', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, - 'list_member_previous' => {'label' => 'メンバー一覧(前)', 'url' => sub { return $_[0]->test_record('list_member_next')}}, - 'view_bbs' => {'label' => 'トピック', 'url' => sub { return $_[0]->test_record('list_bbs')}}, -# 'view_community' => {'label' => 'コミュニティ', 'arg' => ['id' => sub { return $_[0]->test_record('community_id')}]}, - ); - while (@tests >= 2) { - my ($test, $opt) = splice(@tests, 0, 2); - my $method = "get_$test"; - my $label = $opt->{'label'}; - my $url = defined($opt->{'url'}) ? $opt->{'url'} : ''; - if (defined($url) and ref($url) eq 'CODE') { - $url = &{$url}($mixi); - unless ($url) { - $mixi->log("$labelをスキップします。\n", "[warn] 参照レコードなし\n"); - next; - } - } - $url = $url->{'link'} if (defined($url) and ref($url) eq 'HASH'); - my @arg = (defined($opt->{'arg'}) and ref($opt->{'arg'})) eq 'ARRAY' ? @{$opt->{'arg'}} : (); - @arg = map { ref($_) eq 'CODE' ? &{$_}($mixi) : $_ } @arg; - unshift(@arg, $url) if (defined($url) and ref($url) eq '' and length($url)); - $mixi->log("$labelの取得と解析をします。\n"); - $mixi->log(qq([info] ターゲットURLは"$url"です。\n)); - my @items = eval { $mixi->$method(@arg); }; - my $error = ($@) ? $@ : ($mixi->response->is_error) ? $mixi->response->status_line : undef; - if (defined $error) { - $mixi->log("$labelの取得と解析に失敗しました。\n", "[error] $error\n"); - $mixi->dumper_log($mixi->response); - exit 8; - } else { - if (@items) { - $mixi->dumper_log([@items]); - $mixi->test_link($test => @items); - $mixi->test_record($test => $items[0]); - $mixi->test_record($test => {'link' => 'http://mixi.jp/view_album.pl?id=150828'}) if ($test eq 'new_album'); - } else { - $mixi->log("[warn] レコードが見つかりませんでした。\n"); - $mixi->dumper_log($mixi->response); - } - } - } -} - -sub test_get_add_diary_preview { - my $mixi = shift; - my %diary = ( - 'diary_title' => '日記タイトル', - 'diary_body' => '日記本文', - 'photo1' => '../logo.jpg', - 'orig_size' => 1, - ); - $mixi->log("日記の投稿と確認画面の解析をします。\n"); - my @items = eval '$mixi->get_add_diary_preview(%diary)'; - my $error = ($@) ? "[error] $@\n" : ($mixi->response->is_error) ? "[error] " . $mixi->response->status_line ."\n" : ''; - if ($error) { - $mixi->log("日記の投稿と確認画面の解析に失敗しました。\n", $error); - exit 8; - } else { - if (@items) { - $mixi->dumper_log([@items]); - } else { - $mixi->log("[info] 確認画面のフォームが見つかりませんでした。\n"); - $mixi->dumper_log($mixi->response); - } - } -} - -sub test_save_and_read_cookies { - my $mixi = shift; - my $error = ''; - # Cookieの保存 - $mixi->log("Cookieを保存します。\n"); - my $saved_str = $mixi->cookie_jar->as_string; - my $loaded_str = ''; - my $cookie_file = sprintf('cookie_%s_%s.txt', $$, time); - $_ = eval '$mixi->save_cookies($cookie_file)'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not $_) { - $error = "[error] cookieの保存が失敗しました。\n"; - } - if ($error) { - $mixi->log("Cookieを保存できませんでした。\n", $error); - exit 8; - } - # Cookieの読込 - $mixi->log("Cookieの読込をします。\n"); - $mixi->cookie_jar->clear; - $_ = eval '$mixi->load_cookies($cookie_file)'; - if ($@) { - $error = "[error] $@\n"; - } elsif (not $_) { - $error = "[error] cookieの読込が失敗しました。\n"; - } else { - $loaded_str = $mixi->cookie_jar->as_string; - $error = "[error] 保存したCookieと読み込んだCookieが一致しません。\n" if ($saved_str ne $loaded_str); - } - if ($error) { - $mixi->log("Cookieを読込めませんでした。\n", $error); - exit 8; - } - unlink($cookie_file); -} - -package WWW::Mixi::RobotRules; -use vars qw($VERSION @ISA); -require WWW::RobotRules; - @ ISA = qw(WWW::RobotRules::InCore); - -$VERSION = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); - -sub allowed { - return 1; -} - -1; - -=head1 NAME - -WWW::Mixi - Perl extension for scraping the MIXI social networking service. - -=head1 SYNOPSIS - - require WWW::Mixi; - $mixi = WWW::Mixi->new('me @ foo.com', 'password'); - $mixi->login; - my $res = $mixi->get('home.pl'); - print $res->content; - -=head1 DESCRIPTION - -WWW::Mixi uses LWP::RobotUA to scrape mixi.jp. -This provide login method, get and put method, and some parsing method for user who create mixi spider. - -I think using WWW::Mixi is better than using LWP::UserAgent or LWP::Simple for accessing Mixi. -WWW::Mixi automatically enables cookie, take delay 1 second for each access, take care robot exclusions. - -See "mixi.pod" for more detail. - -=head1 SEE ALSO - -L<LWP::UserAgent>, L<WWW::RobotUA>, L<HTTP::Request::Common> - -=head1 AUTHORS - -WWW::Mixi is written by TSUKAMOTO Makio <tsukamoto @ gmail.com> - -Some bug fixes submitted by Topia (http://clovery.jp/), shino (http://www.freedomcat.com/), makamaka (http://www.donzoko.net/), ash. -get_ and post_add_diary, get_ and post_delete_diary, parse_list_diary and parse_new_diary contributed by DonaDona (http://hsj.jp/). -get_ and parse_view_diary contributed by shino (http://www.freedomcat.com/). -get_ and parse_list_outbox contributed by AsO (http://www.bx.sakura.ne.jp/~clan/rn/cgi-bin/index.cgi). -get_ and post_send_message contributed by noname (http://untitled.rootkit.jp/diary/). - -=head1 COPYRIGHT - -Copyright 2004-2005 Makio Tsukamoto. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 702] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi Message-ID: <20051024192043.A742E2AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Cookbook.pod diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Cookbook.pod:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Cookbook.pod:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Cookbook.pod:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Cookbook.pod Tue Oct 25 04:20:43 2005 @@ -1,455 +0,0 @@ -=encoding utf8 - -=head1 NAME - -WWW::Mixi::Cookbook - WWW::Mixi???????????- -=head1 DESCRIPTION - -???????ャ??潟????WWW::Mixi????????戎?????ず?????ゃ?????潟?????ャ?????障???- -=head1 mixi???????若???? - -WWW::Mixi?≪??ャ???????????ゃ????login?<?????????????1?<?????х??ャ??<???????????с?????若?????<????????????? -??????篏帥????mixi?吾??≪??祉????絽吾?膂≦??с???- -=head2 ????ゃ? - -mixi?吾?????ゃ????login?潟??潟?筝???у?篋???障???-????ゃ?緇?????LWP::UserAgent?鴻??ゃ??с?Request?<??????et??ost?<?????с?mixi?≪??祉????mixi???????若?????<?????с?????水??????????????? - - use WWW::Mixi; - use HTTP::Request::Common; - - my $mixi = WWW::Mixi->new('me @ mixi.user', 'mixi_password'); - - print "????ゃ???????\n"; - my $response = $mixi->login; - -=head2 ???????激?????ヨ????? - -mixi???????怨?????腱??????水???<?????????????????ゃ???梢????<?????х亜???羝????????????????? -??????????水?????綽????????????????????????????戎????????亜????号??с???- -?障?????ゃ?????ゆ??井?荐??????若?????<????"get_new_friend_diary"??換篁???障??????-????<???????罨<??????????????<??潟?????????? - - { - 'subject' => 'mixi?????, - 'link' => 'http://mixi.jp/list_item_review.pl?reviewer_id=xxxx&item_id=xxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -箴?????????ゃ?????ゆ??井?荐??????鴻??у????????????????????????? - - use WWW::Mixi; - - my $mixi = WWW::Mixi->new('me @ mixi.user', 'mixi_password'); - - print "????ゃ???????\n"; - my $response = $mixi->login; - - print "???????激?????ヨ???????????\n"; - my =item get_new_friend_diary; - print "???????激?????ヨ????????障???n"; - foreach my $item (@items) { - my $subject = $item->{'subject'}; - my $link = $item->{'link'}; - my $name = $item->{'name'}; - my $time = $item->{'time'}; - print "??$subject\n[?ユ?] $time\n[???] $name\n[Link] $link\n\n"; - } - -?<??c?羂??篁??????????????mixi???絖???若???UC??????????с???-Windows??????????ゃ?????т戎?????????絖???若???JIS?????????荀??????с???????????????code?≪??ャ???????腟???????帥???????? - -=head2 ???篁??????水???<???? - -???????激?????ヨ????get_new_friend_diary???????????ゃ?????若?????<????????????? -篁ヤ???.21???????с?????若?????<??????????????????????緇?唇???parse_鐔?????????純???????絲上??????et_鐔???<?????????????????????????????????-罩g∈?у????筝?Η???????ャ??潟???∈茯??????????? - -紊??????若?????<???????get_new_friend_diary?????????綣??????у?茵???????????羆冴??c?綵√?????с?get_new_friend_diary??室??????鐚??????ャ????????鴻?茲??菴???障???- -=over 4 - -=item get_information - -??????茵?ず??????膊∞????????????????????????? - -=item get_list_comment - -???????<????茵?ず?????????????<????荀с??????????? - -=item get_list_message - -?<??祉??吾?茵?ず????????拭膊宴??????????? - -=item get_new_bbs - -?潟??ャ????????吾?莨若??????????? - -=item get_new_comment - -?ヨ??潟??潟?荐??絮ユ??????????? - -=item get_new_friend_diary - -???????激?????ヨ??????????? - -=item get_new_review - -???????激????????ャ??????????? - -=item get_show_log - -???????????????? - -=back - -箴?????????<??潟?????守??????????get_main_menu?????????????get_banner????若??????????????get_tool_bar???ゃ?????違?URL???絎???????? -?????????????吾??с????????с???-URL??home.pl"??????????若???????????с?罕???障???? - - my =item get_main_menu("home.pl"); - -URL????ャ??????????緇??????水???<???????get?障???ost?<?????у?????????吾?????障???- -=over 4 - -=item get_main_menu - -????後????????ゃ??<??ャ??????????? - -=item get_banner - -????若?????????? - -=item get_tool_bar - -?<??潟?????若?筝??罔?ず???????若?????????????? - -=back - -?障???????紊?????get_show_log_count?????????????????? -??????get_self_id??????ID????????? -??????菴???ゃ?????с????????ャ????????鴻????????????鴻??????? - - my $count = $mixi->get_show_log_count; - my $id = $mixi->get_self_id; - -=over 4 - -=item get_show_log_count - -???????????????? - -=item get_self_id - -?????D?????????? - -=back - -=head1 LWP::UserAgent?鴻??ゃ??с??≪??祉? - -????ゃ?????若?????<??????戎?c??潟?????潟???亜???????????с?????若????????障????????若??潟?????違?綣宴???械????с???-???絨??膣違????緇<?????????????????с??????????LWP::UserAgent????????戎?c??帥???????? - -絎?????WWW::Mixi????若??若??????WP::RobotUA?с???????????若??若??????WP::UserAgent?с???-紊??????純????LWP鐚??UserAgent???膓???????????????祉????????????????????????? - -=head2 ????ゃ? - -LWP::UserAgent?鴻??ゃ??с??若??c??違??????????????ゃ???ogin?<??????戎?c?????c?????с??????- -LWP::UserAgent??戎???????違??割?罐????OST??TTP::Request????吾????????????ookie????鴻????????ゃ?????吾??≪??祉????????c????????????? -????ゃ??<?????????????????????????????????? -???緇??Cookie?с?????с?ID???????????拭????障??????WP::UserAgent?с???????request??imple_request?<?????у?????吾??≪??祉??с??障???- -箴???違?????ゃ?緇????????HTML??????????????札筝?????????障???- - use WWW::Mixi; - use HTTP::Request::Common; - - my $mixi = WWW::Mixi->new('me @ mixi.user', 'mixi_password'); - - print "????ゃ???????\n"; - my $response = $mixi->login; - - print "???????????????\n"; - $request = &HTTP::Request::Common::GET('http://mixi.jp/home.pl'); - $response = $mixi->request($request); - print $response->content; - -=head2 get?<???? - -LWP::UserAgent?≪??ャ???????羣??????若??????1)HTTP::Request????吾??????????(2)request?<?????с?????鴻??????????????????? -WWW::Mixi?≪??ャ??????????篁??get??ost?????亜???????純???????????????????篏帥????????????? - -箴???違?筝???????????????若?????????????- - use WWW::Mixi; - use HTTP::Request::Common; - - (?? - - print "???????????????\n"; - $request = &HTTP::Request::Common::GET('http://mixi.jp/home.pl'); - $response = $mixi->request($request); - print $response->content; - -get??戎?????TTP::Request::Common?≪??ャ???????篏帥????????鴻??????????????贋・URL???絎?????羝???障???-?障???RL??http://'???紮????偽絲?RL?с???????緇??????ゃ?????障??????????綣球???.pl'?????????鐚?????????医??????? -?ゃ????筝??????????????篋???с??障???- - use WWW::Mixi; - - (?? - - print "???????????????\n"; - $response = $mixi->get('home.pl'); - print $response->content; - -=head2 post?<???? - -膂≦???ET?с??若???????????????純?????????WW::Mixi???get???????純??????????????障???? - -?????OST?с????????ュ??ゃ???拭????????ost?????亜???????純????篏帥????????????? -post?с???RL?????????????若?????違?羝<??障???-箴???違?罨<???????????ヨ????腮帥??с??障???- - use WWW::Mixi; - - my %diary = ( - 'submit' => 'confirm', # ????????main?????confirm??信罩?cancel - 'diary_title' => 'WWW::Mixi?ф?荐????┸', - 'diary_body' => "WWW::Mixi?≪??ャ?????ヨ????腮帥?????障???nPOST?<???????薑?????", - 'photo1' => '', - 'photo2' => '', - 'photo3' => '', - ); - - my $mixi = WWW::Mixi->new('me @ mixi.user', 'mixi_password'); - - print "????ゃ???????\n"; - my ($result, $response) = $mixi->login; - - print "?ヨ????腮帥??障???n"; - $response = $mixi->post('add_diary.pl', %diary); - -????若?????????拭?????????????潟?????????? -?顑??????潟??若?????鴻??若???????荀??????障???? - -=head2 ????ゃ????篆?- -post?<?????с???????????<??????拭?????????????????????????障????荅?????????障???????荅?????????????????????????- -箴???違??ヨ????????ャ???;腓冴????????≪??激??潟?????ヨ???下篁??????????hoto1???photo2???photo3???3?ゃ?????若?????ャ???????????с??障???-????若????????<????????????????????ゃ???????????ら???????????鴻?????????? - - use WWW::Mixi; - - my %diary = ( - 'submit' => 'main', # ????????main?????confirm??信罩?cancel - 'diary_title' => 'WWW::Mixi?ф?荐????┸', - 'diary_body' => "WWW::Mixi?≪??ャ?????ヨ????腮帥?????障???nPOST?<???????薑?????", - 'photo1' => ['c:\My Documents\photos\walrus.png'], - 'photo2' => '', - 'photo3' => '', - ); - - my $mixi = WWW::Mixi->new('me @ mixi.user', 'mixi_password'); - - print "????ゃ???????\n"; - my ($result, $response) = $mixi->login; - - print "?ヨ????腮帥??障???n"; - $response = $mixi->post('add_diary.pl', %diary); - -=head2 ?<??潟?????若?茹f??<???? - -?潟??????????????????????荀??????帥?????冴??????В???????с??????-WWW::Mixi?≪??ャ???????????ゃ?????若????茹f??<????????????? - -茹f?膤祉?筝??膂≦?????????????篏?????鐚?В????純?????<??潟?????種?????後????mixi????違?筝??????????????膣≪?膈??????潟????莨若?????<??ャ??с?鐚??茹f????parse_main_menu?<?????с???-????<???????罨<??????????????<??潟?????????? - - { - 'subject' => '?????, - 'link' => 'http://mixi.jp/home.pl' - } - -箴?????????若?????????<??潟?????若????????阪?????鴻???????????障??????-???????若??????障??????????????吾???????????冴????????????????????????障?????障???- - use WWW::Mixi; - - my $mixi = WWW::Mixi->new('me @ mixi.user', 'mixi_password'); - print "????ゃ???????\n"; - my $response = $mixi->login; - print "???????????????\n"; - $response = $mixi->get('home.pl'); - - print "?<??潟?????若??阪???????\n"; - my =item parse_main_menu($response); - foreach my $item (@items) { - my $subject = $item->{'subject'}; - my $link = $item->{'link'}; - print "$subject -> $link\n"; - } - -?????response???絎??????c???????緇??get?障???ost?<?????у?????????帥?茹f???????request??imple_request???莟≦??с?鐚?? -筝??箴?????茹f???????????????et?у?????????帥?????????????$response???絎????????罕???障???? - - my =item parse_main_menu(); - -=head2 ???篁??茹f??<???? - -?<??潟?????主???arse_main_method???????????ゃ???В????純????荐?????????障???- -茹f??<????????????response????違??????????????????ャ????????鴻????????????? -$response???絎??????c????茹f?絲乗院????????et?障???ost?<?????у?????????帥???? -?????ャ????????鴻??????????????<???????????????? - -篁ヤ???.21???????с???В????<???????荀с???? -??????????純????菴遵??????????紊??????????????????ャ??障?????с?荅括完???????<????腆肴??????????? - -=over 4 - -=item parse_main_menu - -????後????????ゃ??<??ャ???В????障???- -=item parse_banner - -?<??潟?????若????莨若???????????若?茹f??????? - -=item parse_tool_bar - -?<??潟?????若?筝??罔?ず???????若??????В????障???- -=item parse_information - -??????home.pl鐚??茵?ず??????膊∞????????????????茹f??????? - -=item parse_calendar - -????潟??種?calendar.pl鐚???????????????ゃ??潟????????ゃ??潟?????ゃ?????c?茯???ワ???В????障???- -=item parse_calendar_term - -????潟??種?calendar.pl鐚??茵?ず?????????鐚?拘?????В????障???- -=item parse_calendar_next - -????潟??種?calendar.pl鐚???????????????潟???В????障???- -=item parse_calendar_previous - -????潟??種?calendar.pl鐚???????????????潟???В????障???- -=item parse_list_bookmark - -?????????list_bookmark.pl鐚??茹f??????? - -=item parse_list_comment - -???????<????list_comment.pl鐚??茵?ず?????????????<????荀с???В????障???- -=item parse_list_community - -?潟??ャ????筝?Η鐚?ist_community.pl鐚??茵?ず?????????????c?茹f??????? - -=item parse_list_community_next - -?潟??ャ????筝?Η鐚?ist_community.pl鐚?????????若????????潟???В????障???- -=item parse_list_community_previous - -?潟??ャ????筝?Η鐚?ist_community.pl鐚?????????若????????潟???В????障???- -=item parse_list_diary - -?ヨ?鐚?ist_diary.pl鐚???ヨ??????В????障???- -=item parse_list_diary_next - -?ヨ?鐚?ist_diary.pl鐚???????x篁吟??吾???????茹f??????? - -=item parse_list_diary_previous - -?ヨ?鐚?ist_diary.pl鐚???????x篁吟??吾???????茹f??????? - -=item parse_list_friend - -??査?紫?篋坂?荀э?list_friend.pl鐚????査?紫?篋冴?茹f??????? - -=item parse_list_friend_next - -??査?紫?篋坂?荀э?list_friend.pl鐚?????????若????????潟???В????障???- -=item parse_list_friend_previous - -??査?紫?篋坂?荀э?list_friend.pl鐚?????????若????????潟???В????障???- -=item parse_list_message - -?<??祉??醐?message.pl鐚??茵?ず????????拭膊宴???В????障???- -=item parse_new_bbs - -?潟??ャ????????吾?莨若?鐚?ew_bbs.pl鐚??茹f??????? - -=item parse_new_comment - -?ヨ??潟??潟?荐??絮ユ?鐚?ew_comment.pl鐚??茹f??????? - -=item parse_new_friend_diary - -???????激?????ヨ?鐚?ew_friend_diary.pl鐚??茹f??????? - -=item parse_new_friend_diary_next - -???????激?????ヨ?鐚?ew_friend_diary.pl鐚?????????若????????潟???В????障???- -=item parse_new_friend_diary_previous - -???????激?????ヨ?鐚?ew_friend_diary.pl鐚?????????若????????潟???В????障???- -=item parse_new_review - -???????激????????ャ?鐚?ew_review.pl鐚??茹f??????? - -=item parse_show_log - -??????鐚?how_log.pl鐚??茹f??????? - -=item parse_show_log_count - -??????鐚?how_log.pl鐚??????若???????????号????茹f??????? -????<?????????????????号??с??????ャ????????鴻?????с?????障???? - -=item parse_add_diary_preview - -?ヨ?篏?????????ャ?鐚?dd_diary.pl鐚??茹f????????帥????綵????????????ゃ?菴???障???- -=item parse_self_id - -??????????ャ?鐚?ist_review.pl鐚??茹f?????????D????????? -????<????????????D?с??????ャ????????鴻?????с?????障???? - -=back - -=head1 SEE ALSO - -L<WWW::Mixi>, L<LWP::UserAgent>, L<WWW::RobotUA>, L<HTTP::Request::Common> - -=head1 COPYRIGHT - -Copyright 2004-2004 TSUKAMOTO Makio. - -This text is free document; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Mixi.pod diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Mixi.pod:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Mixi.pod:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Mixi.pod:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/WWW/Mixi/Mixi.pod Tue Oct 25 04:20:43 2005 @@ -1,1612 +0,0 @@ -=encoding utf8 - -=head1 NAME - -WWW::Mixi - Mixi?≪??祉????LWP::UserAgent?≪??ャ???- -=head1 SYNOPSIS - - use WWW::Mixi; - $mixi = WWW::Mixi->new('me @ foo.com', 'password'); - $mixi->login; - my $res = $mixi->get('home.pl'); - print $res->content; - -=head1 DESCRIPTION - -Mixi???????鴻????????≪??ャ??????? - -LWP::RobotUA?????????????c??????WP::UserAgent?????WP::RobotUA?????????篏帥????????????? -WWW::Mixi???LWP::UserAgent???箴水???????ゃ??????? - -?障???WW::Mixi?с?????ゃ??∫????罐???????ogin?<?????ф??障????????с??障???-login?<???????Cookie????鴻???????????????????????с??????????????????若??≪????????鴻??若???ogin????吾??????????????鴻?茹f?????祉??激???D??????????ュ???RL?????????? -????ゃ??倶????is_login_required??s_logined??ession??efresh???????純????腆肴??с??障???- -???????????ゃ???梢????<???????????????障???-紊у??????膤紫輝?с?筝????偽絲?RL????????????bsolute_url??bsolute_linked_url?с???????mixi????若?????吾????????????RL????若??????偽絲?RL???緇?????緇??get?障???ost?у?????????吾?????鴻????URL????????? -???筝?????mixi????潟??潟???В??????????<?????с?????ゃ??<??ャ?茹f????parse_main_menu????若????茹f????parse_tool_bar????ャ???В?????arse_information?<???????紊????В????純??????RL??????В????障????茵??get_main_menu???????純????????障???- -?障?????????WP::RobotUA?????????????с?????????????絋ュ????篏??茵??????????? -筝????????????泣???????莢?????????????elay??腱??荐???????????1腱??????札筝??????????????????????????????障???-?????obot.txt????с???????????????-????ゃ????膩?????WWW::Mixi?с?robot.txt????с????????????ixi???篋??絮???????????????????障???- -=head1 METHODS - -WWW::Mixi??WP::RobotUA???????????????茖????????????с?LWP::RobotUA?????Κ????鴻????LWP::UserAgent????純????綣??膓???с??障???-??????篏帥??鴻??ゃ???????????鴻?????ャ??潟????荀с??????? - -=head2 Constructor - -WWW::Mixi????潟????????с???- -=head3 $mixi = WWW::Mixi->new($email [, $password] [, '-log' => \&logging_method] [, '-abort' => \&aborting_method] [, '-rewrite' => \&rewriting_method] ) - -WWW::Mixi????吾??????????????潟????????с???- -???????違???ixi????違??潟????????<????????鴻?????????? -篋?????綣?????mixi????違??潟??????????????????? -'-log'???????с??с?????????????????<???????絎???障???-'-abort'???????с??с?????惹????篋?????茵?????????純????????????? -'-rewrite'???????с??с?茹f????????鴻??ゃ???????????????????????純????????????? - -????<??????WP::RobotUA鐚??篁????WP::UserAgent鐚??????帥???ew?<????????吾?????????? - -=head2 Login and Login information - -mixi????違??潟????????<????????上?????違??括?羈???祉??激???D???????f??宴??????????????純???召?с???- -=head3 $response = $mixi->login( [$password] ); - -mixi????違??潟??障???-綽???с??????ookie????劫?????????????? - -????ゃ???????????????password???絎??????違??????戎????障???-???絎??????潟??鴻?????帥???????????鴻??若???戎????障???-?潟??鴻?????帥?????鴻??若????絎?????????翫????????純????篏???≪??激??潟?茵?????undef????????? - -菴???ゃ?????ゃ????HTTP::Response????吾?????с???-????ゃ?紊掩???????????鴻??若???01??????????с?篁ヤ???????????若??潟?????違?????с???- - $mixi->login->is_sucess or die 'Login failed'; - -罨<??????????????違??喝け???????宴?腆肴???????????с??????- - $res = $mixi->login; - $res->is_success or die $res->status_line; - -=head3 $result = $mixi->is_logined - -????ゃ?羝???с????1???????ゃ??с????0????????? - -=head3 $result = $mixi->is_login_required( [$response] ) - -?????et?障???ost?у?????????吾??若???В??????????ゃ?????若???;腓冴??????????腆肴??????? -????吾????????????????????ゃ?????若???;腓冴???????????????????????? -????ゃ?????若???;腓冴???????????????????????<??祉??吾?菴???障???- -$response???絎?????????????????????????吾?紊?????$response??В????障???-$response???HTTP::Response????吾????鐚?et??ost??equest??imple_request?<?????????????????????????絎??????????? - -=head3 $session = $mixi->session( [$session] ); - -?上????????с?ID????????? -????ゃ????????祉??激???D?????с????????????ndef????????? - -$session???絎????????????祉??激???D???絎??????х舟?????障???- -=head3 $session = $mixi->stamp( [$stamp] ); - -?上????????с??鴻??潟?????????? -????ゃ????????祉??激??潟??帥????????с????????????ndef????????? - -$stamp???絎????????????祉??激??潟??帥???????????ゃ?臀??????障???- -=head3 $session = $mixi->refresh - -????ゃ?????????????????激?URL????????? - -=head2 Fetch URL - -????吾??????????????純??????? -???????違??喝????茵???????????綵???若?????潟??潟??????с???????????鴻??若???01????????? - -=head3 $response = $mixi->request($request, $arg [, $size]) ) - -????<??????WP::UserAgent??equest?<????????弱????篏???????? -篏帥??鴻??ゃ??????WP::UserAgent???????<????????????????? - -??????????帥?????障???????菴???????????????鴻??若???00???????ゃ???????????鴻??若???ogin?<???????401?с???-?障????????純????LWP::RobotUA??equest?<???????茵??????障???-箴????obot exclution???????????????????拷??????????????????????罕?????????障???- -=head3 $response = $mixi->get($url) - -GET?<?????ф?絎?????URL?????????? -URL??撮????'login'??show_logs'?????.pl'??????????ゃ?????????????????????- -菴???ゃ?HTTP::Response????吾?????с??????WP::UserAgent?≪??ャ????request?<????????????? - -=head3 $response = $mixi->post($url ['field' => value, ...]) - -POST?<?????ф?絎?????URL?????????? -URL??撮????'login'??show_logs'?????.pl'??????????ゃ?????????????????????- -POST???????若?????ゃ???name' => 'Mr. Mixi', 'Age' => '3years'??????????c????????ゃ?絲障?????????????????絲障?????ゆ?絎?????罕???障???? -????若???????????ゃ????絎?????????с??障??????????'pic1' => ['./picture.jpg']??????????<?????鴻???????????<??潟??ф検?????????? -?????OST????帥?HTTP::Request::Common?≪??ャ????POST?<?????у??????????????ゃ???????膣違?????ゃ????????????∈茯???????? - -菴???ゃ?HTTP::Response????吾?????с??????WP::UserAgent?≪??ャ????request?<????????????? - -=head3 $response = $mixi->response() - -??????????????鴻??潟?????????? -菴???ゃ?HTTP::Response????吾?????с??????WP::UserAgent?≪??ャ????request?<??????????????????? - -=head2 Parse response - -???羝??????若???В????障???- -茹f?膤祉??<?????????????綣??$response???絎??????????response??????絎?????緇??get?障???ost?<?????у?????????帥?茹f??????? -$response???HTTP::Response????吾????鐚?et??ost??equest??imple_request?<?????????????????????????絎??????????? - -=head3 @items = $mixi->parse_main_menu( [$response] ); - -?<??潟?????種???ixi?????????篏???????????????<??ャ?鐚??????????????? -菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????, - 'link' => 'http://mixi.jp/home.pl' - } - -=head3 @items = $mixi->parse_banner( [$response] ); - -????種??<??潟?????若????莨若??????????鐚??????????? -菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '羆?査?泣???ind Job !', - 'link' => 'http://mixi.jp/banner.pl?id=x' - 'image' => 'http://banner.host.domain/image.gif' - } - -mixi??????膣????.胼??篋?????篋???????ixi ????吟???????????若??祉??鴻????絋?????茵?????????????????????????????緇???????ixi????吟?綽?????????????????? -WWW::Mixi?≪??ャ????篏睡??????????荐???????????筝???????????????宴??????ィ絅???障???- -=head3 @items = $mixi->parse_tool_bar( [$response] ); - -???????若?????????????? -菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '???????若?', - 'link' => 'http://mixi.jp/home.pl' - } - -=head3 @items = $mixi->parse_information( [$response] ); - -????????????????????? -菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '????????査??mixi ???緇?????鐚?, - 'link' => 'http://mixi.jp/invite.pl', - 'description\' => '??査???緇? - } - -=head3 @items = $mixi->parse_calendar( [$response] ); - -????潟??種?calendar.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '茯????, - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18' - 'icon' => 'http://mixi.jp/img/i_bd.gif' - } - -=head3 $item = $mixi->parse_calendar_term( [$response] ); - -????潟??種?calendar.pl????ゃ??????????綛贋?鐚??茹f??????? -菴???ゃ???札筝????????????ャ????????鴻???? - - { - 'year' => '2004', - 'month' => '8' - } - -=head3 $item = $mixi->parse_calendar_next( [$response] ); - -????潟??種?calendar.pl????ゃ???????罨<?????吾???????茹f??????? -菴???ゃ????罨<?????????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '罨<???, - 'link' => 'http://mixi.jp/calendar.pl?year=2004&month=10&pref_id=13', - } - -=head3 $item = $mixi->parse_calendar_previous( [$response] ); - -????潟??種?calendar.pl????ゃ??????????????吾???????茹f??????? -菴???ゃ???????????????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '?????, - 'link' => 'http://mixi.jp/calendar.pl?year=2004&month=10&pref_id=13', - } - -=head3 @items = $mixi->parse_list_bookmark( [$response] ); - -?????????list_bookmark.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => 'walrus', - 'gender' => '?傑?', - 'description' => 'Perl????≪?PDA????≪??吟????????吟?????ゃ??泣?????ヨ?????<??с???..', - 'image' => 'http://img.mixi.jp/photo/member/xx/xx/xxxx.jpg', - 'link' => 'http://mixi.jp/show_friend.pl?id=xxxxxx', - 'time' => '2004/08/18 13:18' - } - -=head3 @items = $mixi->parse_list_comment( [$response] ); - -???????<????list_comment.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 @items = $mixi->parse_list_community( [$response] ); - -?潟??ャ????筝?Η鐚?ist_community.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => 'WWW::Mixi?≪??ャ???, - 'link' => 'http://mixi.jp/view_community.pl?id=xxxx', - 'image' => 'http://img.mixi.jp/photo/comm/xx/xx/xxxx_xxs.jpg', - 'count' => '20' - } - -=head3 $item = $mixi->parse_list_community_next( [$response] ); - -?潟??ャ????筝?Η鐚?ist_community.pl????ゃ???????罨<?????吾??吾???????茹f??????? -菴???ゃ????罨<?????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '罨<?xx篁?, - 'link' => 'http://mixi.jp/list_community.pl?page=x', - } - -=head3 $item = $mixi->parse_list_community_previous( [$response] ); - -?潟??ャ????筝?Η鐚?ist_community.pl????ゃ??????????????吾??吾???????茹f??????? -菴???ゃ???????????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '???50篁?, - 'link' => 'http://mixi.jp/list_community.pl?page=x', - } - -=head3 @items = $mixi->parse_list_diary( [$response] ); - -?ヨ?鐚?ist_diary.pl鐚???<??渇??????В????純??????? -菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? -images??賢荳???泣???????????糸???RL???????ャ????????鴻?????????????????障???- - { - 'subject' => '?????????', - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'description' => '????????..', - 'time' => '08/18 13:18' - 'count' => '?潟??潟?篁倶?', - 'images' => [ - { - 'link' => 'http://img.mixi.jp/photo/diary/xx/xx/xxxxxxxxx_xxx.jpg', - 'thumb_link' => 'http://img.mixi.jp/photo/diary/xx/xx/xxxxxxxxx_xxxs.jpg' - } - ] - } - -=head3 $item = $mixi->parse_list_diary_capasity( [$response] ); - -?ヨ?鐚?ist_diary.pl????ゃ????????ヨ???戎???羈????В????障???-菴???ゃ?????ヨ???戎???羈???????????篁ヤ????????????ャ????????鴻???? - - { - 'max' => '100.0', - 'used' => '2.2', - } - -=head3 $item = $mixi->parse_list_diary_next( [$response] ); - -?ヨ?鐚?ist_diary.pl????ゃ???????罨<?xx篁吟??吾???????茹f??????? -菴???ゃ????罨<?xx篁吟??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '罨<?xx篁?, - 'link' => 'http://mixi.jp/list_diary.pl?page=x', - } - -=head3 $item = $mixi->parse_list_diary_previous( [$response] ); - -?ヨ?鐚?ist_diary.pl????ゃ??????????xx篁吟??吾???????茹f??????? -菴???ゃ???????xx篁吟??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '???xx篁?, - 'link' => 'http://mixi.jp/list_diary.pl?page=x', - } - -=head3 @items = $mixi->parse_list_diary_monthy_menu( [$response] ); - -?ヨ?鐚?ist_diary.pl鐚?????????潟?????鴻?????潟???В????障???-菴???ゃ?????????札筝????????????ャ????????鴻???????????????? - - { - 'link' => 'http://mixi.jp/list_diary.pl?year=2005&month=7', - 'month' => '7', - 'year' => '2005' - }, - -=head3 @items = $mixi->parse_list_friend( [$response] ); - -??査?紫?篋坂?荀э?list_friend.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => 'walrus???', - 'link' => 'http://mixi.jp/show_friend.pl?id=xxxxx', - 'image' => 'http://img.mixi.jp/photo/member/xx/xx/xxxxx_xxxxxxxxxx.jpg', - 'background' => 'http://img.mixi.jp/img/bg_xxx.gif', - 'id' => 'xxxxx', - 'count' => 'xxx' - 'status' => '1???篁ュ?', - } - -=head3 $item = $mixi->parse_list_friend_next( [$response] ); - -??査?紫?篋坂?荀э?list_friend.pl????ゃ???????罨<?????吾??吾???????茹f??????? -菴???ゃ????罨<?????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '罨<?xx篁?, - 'link' => 'http://mixi.jp/list_friend.pl?page=x', - } - -=head3 $item = $mixi->parse_list_friend_previous( [$response] ); - -??査?紫?篋坂?荀э?list_friend.pl????ゃ??????????????吾??吾???????茹f??????? -菴???ゃ???????????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '???50篁?, - 'link' => 'http://mixi.jp/list_friend.pl?page=x', - } - -=head3 @items = $mixi->parse_list_message( [$response] ); - -??????拭?<??祉??醐?list_message.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? -status??ew(?亥?)??pened(?∵?)??eplied(菴?拭羝??)??nknown(筝??)????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_message.pl?id=xxxxxx&box=xxxxx', - 'name' => '紂???х?', - 'time' => '08/18', - 'status' => 'replied', - 'emvelope' => 'http://mixi.jp/img/mail5.gif' - } - -=head3 @items = $mixi->parse_list_outbox( [$response] ); - -??????篆<?????若?鐚?ist_message.pl?box=outbox????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_message.pl?id=xxxxxx&box=xxxxx', - 'name' => '紂???х?', - 'time' => '08/18', - } - -=head3 @items = $mixi->parse_new_album( [$response] ); - -???????激?????≪????鐚?ew_album.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '紂??絎吟?篋冴?', - 'link' => 'http://mixi.jp/view_album.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 @items = $mixi->parse_new_bbs( [$response] ); - -?潟??ャ????????吾?莨若?鐚?ew_bbs.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_bbs.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 $item = $mixi->parse_new_friend_diary_next( [$response] ); - -?潟??ャ????????吾?莨若?鐚?ew_bbs.pl????ゃ???????罨<?????吾??吾???????茹f??????? -菴???ゃ????罨<?????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '罨<?xx篁吟?茵?ず', - 'link' => 'http://mixi.jp/new_friend_diary.pl?page=x', - } - -=head3 $item = $mixi->parse_new_friend_diary_previous( [$response] ); - -?潟??ャ????????吾?莨若?鐚?ew_bbs.pl????ゃ??????????????吾??吾???????茹f??????? -菴???ゃ???????????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '???50篁吟?茵?ず', - 'link' => 'http://mixi.jp/new_friend_diary.pl?page=x', - } - -=head3 @items = $mixi->parse_new_comment( [$response] ); - -?ヨ??潟??潟?荐??絮ユ?鐚?ew_comment.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 @items = $mixi->parse_new_diary( [$response] ); - -?亥??ヨ?罎?刈鐚?ew_diary.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'description' => 'mixi????????????罕????????????????, - 'time' => '2005/05/20 13:32' - 'name' => '紂???х?', - 'gender' => '?傑?', - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx&owner_id=xxxxx', - 'image' => 'http://img.mixi.jp/photo/member/xx/xx/xxxxx_xxxxxxxxs.jpg', - } - -=head3 $item = $mixi->parse_new_diary_next( [$response] ); - -?亥??ヨ?罎?刈鐚?ew_diary.pl????ゃ???????罨<?????吾??吾???????茹f??????? -菴???ゃ????罨<?茵?ず???????翫???札筝????????????ャ????????鴻???? - - { - 'subject' => '罨<?茵?ず', - 'link' => 'http://mixi.jp/new_diary.pl?page=2&keyword=xx' - } - -=head3 $item = $mixi->parse_new_diary_previous( [$response] ); - -?亥??ヨ?罎?刈鐚?ew_diary.pl????ゃ??????????????吾??吾???????茹f??????? -菴???ゃ???????茵?ず???????翫???札筝????????????ャ????????鴻???? - - { - 'subject' => '???茵?ず', - 'link' => 'http://mixi.jp/new_diary.pl?page=2&keyword=xx' - } - -=head3 @items = $mixi->parse_new_friend_diary( [$response] ); - -???????激?????ヨ?鐚?ew_friend_diary.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 $item = $mixi->parse_new_friend_diary_next( [$response] ); - -???????激?????ヨ?鐚?ew_friend_diary.pl????ゃ???????罨<?????吾??吾???????茹f??????? -菴???ゃ????罨<?????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '罨<?xx篁吟?茵?ず', - 'link' => 'http://mixi.jp/new_friend_diary.pl?page=x', - } - -=head3 $item = $mixi->parse_new_friend_diary_previous( [$response] ); - -???????激?????ヨ?鐚?ew_friend_diary.pl????ゃ??????????????吾??吾???????茹f??????? -菴???ゃ???????????吾??????????篁ヤ????????????ャ????????鴻???? - - { - 'subject' => '???50篁吟?茵?ず', - 'link' => 'http://mixi.jp/new_friend_diary.pl?page=x', - } - -=head3 @items = $mixi->parse_new_review( [$response] ); - -???????激????????ャ?鐚?ew_review.pl????ゃ??????В????障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => 'mixi?????, - 'link' => 'http://mixi.jp/list_item_review.pl?reviewer_id=xxxx&item_id=xxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 $id = $mixi->parse_self_id( [$response] ); - -???????若?鐚?how_profile.pl鐚??茹f?????????D????????? -ID?????с?????c????菴???ゃ?0?с???- -????<?????????????В??鎧?<???????????????ャ????????鴻?????с??????????絖??鐚??????わ??????????羈???????????? - -=head3 $item = $mixi->parse_show_friend_outline( [$response] ); - -???????若???????show_friend.pl???????c?????鎴???????В????障???-菴???ゃ???札筝????????????ャ????????鴻???? - - { - 'name' => '?障???, - 'link' => 'http://mixi.jp/show_friend.pl?id=xxx', - 'image' => 'http://img.mixi.jp/photo/member/xx/xx/xxx_xxxxxxxxxx.jpg', - 'description' => '???????ゃ??????篁ュ?', - 'count' => 20, - 'step' => 2, - 'relation' => { - 'link' => 'http://mixi.jp/show_friend.pl?id=xxx', - 'name' => 'walrus' - } - } - -step????ゃ?????c??翫?1????ゃ?????c????????激??????????<??с?????翫?0?с???-step?????????????????????障????????激?????宴?relation??????????障???- -=head3 $item = $mixi->parse_show_friend_profile( [$response] ); - -???????若?鐚?how_friend.pl????ゃ??????В??????????c????菴???障???-菴???ゃ???札筝????????????ャ????????鴻???? - - { - '?鞘??? => '?延根?初????', - '絅純?????? => '?吾?????????, - '???' => '???篌?ぞ?帥??泣???, - '?肴昆?? => '?主????罕糸?', - '綛顔就' => '30罩?, - '???' => '紂?? ?х? (?傑?)', - '茵?恐?? => 'O??, - '?傑キ' => '????違???, - '莇e?' => '??????, 茯??', - '絅純?????祉??潟?' => '????????, - '茯???? => '01??1??, - '??訓膣剛?' => '??????????? - } - -?????ャ??????????篋冴?????????????????若????絎鴻???????羝???障???- -=head3 @items = $mixi->parse_show_log( [$response] ); - -??????鐚?how_log.pl????ゃ??????В????????????菴???障???-菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'link' => 'http://mixi.jp/show_friend.pl?id=xxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 $count = $mixi->parse_show_log_count( [$response] ); - -??????鐚?how_log.pl????ゃ??????В????????????????????? - -????<?????????????В??鎧?<???????????????ャ????????鴻?????с???????????わ??鴻????鐚??菴???????絵??????????? - -=head3 $item = $mixi->parse_view_diary( [$response] ); - -?ヨ?鐚?iew_diary.pl????ゃ??????В????障???-菴???ゃ???札筝????????????ャ????????鴻???? - - { - 'subject' => '?????????', - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'description' => '???', - 'time' => '2005/05/24 22:36' - 'images' => [ - { - 'link' => 'http://img.mixi.jp/photo/diary/xx/xx/xxxxxxxxx_xxx.jpg', - 'thumb_link' => 'http://img.mixi.jp/photo/diary/xx/xx/xxxxxxxxx_xxxs.jpg' - } - ] - 'comments' => [ - { - 'link' => 'http://mixi.jp/show_friend.pl?id=xxxxxx', - 'time' => '2005/05/24 22:56', - 'name' => '?潟??潟???, - 'description' => '??????????? - }, - ] - } - -images??omments??篁吟????????遺散????????????羈???????????? - -=head3 $item = $mixi->parse_view_message( [$response] ); - -??拭?<??祉??醐?view_message.pl????ゃ???????????若???В????障???-菴???ゃ????????若??????с???????篁ヤ????????????ャ????????鴻???? - -??拭?<??祉??吾????綽???障???? - - { - 'subject' => '?????????, - 'image' => 'http://img.mixi.jp/photo/member/xx/xx/xxxxxx_xxxxxxxxs.jpg', - 'link' => 'http://mixi.jp/show_friend.pl?id=?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 12:34', - 'description' => '???...', - } - -=head3 @items = $mixi->parse_view_message_form( [$response] ); - -??拭?<??祉??醐?view_message.pl????ゃ???????????若???????篆<????????若???В????障???-菴???ゃ?????????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'command' => 'delete_message' - 'action' => 'http://mixi.jp/delete_message.pl?box=xxxxx&message_id=xxxxxxx', - 'submit' => '????, - } - -???????????ction???綽???????RL?????????????????ubmit?????ubmit???綽??????????ost?ч?篆<?????????? - -=head3 @items = $mixi->parse_add_diary_preview( [$response ]); - -?ヨ?篏?????????ャ?鐚?dd_diary.pl????ゃ??????В??????????潟??後????????若????????????? -菴???ゃ?????????????篁ヤ????????????ャ????????鴻???????????????? - - { - '__action__' => 'http://mixi.jp/show_friend.pl?id=xxxxx', - 'submit' => 'confirm', - 'diary_title' => '篁?????荐?, - 'diary_body' => '篁????????????c???- ???????違????...', - 'packed' => 'asjkEKJHFu.16190.diary:1:adjksHfsdk.16190.diary_s:1', - 'post_key' => '012a34b56cd78e901fa23b45678cde90', - } - -__action__???????若?????????絵??????????? -?????????????????拭??RL??;??????????с?????若??ゃ????????????-?ヨ??????????confirm鐚???????????????若??????????綽??????????? - -'post_key'????????ixi?眼?????潟??????????菴???????? -?障???packed'???????ャ????????糸?????ゃ??????c?????違??????xi?眼?????潟??????????菴???????? -?ヨ????腮帥????post?障???et_edit_diary_confirm鐚????????????若??????????????ゃ?綽???с???- -=head3 $item = $mixi->parse_add_diary_confirm( [$response ]); - -?ヨ?篏??腟??鐚?dd_diary.pl????ゃ??????В????障???-菴???ゃ???札筝????????????ャ????????鴻???? - - { - 'link' => 'http://mixi.jp/list_diary.pl', - 'subject' => '篏?????篋???障??????????????????????????障??????;腓冴?????????????絨??????<???????', - 'result' => 1 - } - -???????潟??潟????篏?????篋???障????????<??祉??吾?荀????????????????????????????-?障?????鴻??潟????????帥?????障????????c???????菴???ゃ?????障???? -???????翫???????????<??祉??檎?篆<?紊掩?????????? -菴???ゃ?????c??翫?????鴻??潟??潟????200?с???????????鴻??潟?????????00?с???????????鴻?????若?????с???????????????? - -=head3 @items = $mixi->parse_delete_diary_preview( [$response ]); - -?ヨ???????????ャ?鐚?elete_diary.pl????ゃ??????В??????????潟??後????????若????????????? -菴???ゃ?????????????篁ヤ????????????ャ????????鴻???????????????? - - { - '__action__' => 'http://mixi.jp/delete_dairy.pl?id=xxxxx', - 'submit' => 'confirm', - } - -__action__???????若?????????絵??????????? -?????????????????拭??RL??;??????????с?????若??ゃ????????????-?ヨ?????ゃ????confirm鐚???????????????若??????????綽??????????? - -=head3 $item = $mixi->parse_delete_diary_confirm( [$response ]); - -?ヨ????腟??鐚?elete_diary.pl????ゃ??????В????障???-?ヨ?????ゃ??????????????鴻??若?302????c??ヨ?鐚?ist_diary.pl鐚??????ゃ????????障??????В??????parse_list_diary?<??????????????障???- -菴???ゃ?????c??????????????鴻??若???????????鴻?previous?<?????у???с?????????????絮ユ?????潟????????鴻??潟??潟??????????????帥???????? - -=head3 @items = $mixi->parse_edit_diary_preview( [$response ]); - -?ヨ?膩?????????ャ?鐚?dit_diary.pl????ゃ??????В??????????若????????????? -菴???ゃ?????????????篁ヤ????????????ャ????????鴻???????????????? - - { - '__action__' => 'http://mixi.jp/edit_diary.pl?id=xxxxx', - 'submit' => 'main', - 'diary_title' => '篁?????荐?, - 'diary_body' => '篁????????????c???- ???????違????...', - 'form_date' => 'date', - 'photo1' => '', - 'photo2' => '', - 'photo3' => '', - } - -__action__???????若?????????絵??????????? -?????????????????拭??RL??;??????????с?????若??ゃ????????????-膩???????∈絎???????????????若??????????綽??????????? - -=head3 @items = $mixi->parse_edit_diary_image( [$response ]); - -?ヨ?膩?????????ャ?鐚?dit_diary.pl????ゃ??????В????障???-菴???ゃ?????????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'thumb_link' => 'http://img1.mixi.jp/photo/diary/xx/xx/xxxxx_xxxs.jpg', - 'subject' => '???1', - 'link' => 'http://mixi.jp/delete_diary_photo.pl?diary_id=xxxxx&photo_number=xxx' - } - -'link'???綽????RL?????????????ゃ???????????с???- -=head3 $item = $mixi->parse_edit_diary_confirm( [$response ]); - -?ヨ?膩??腟??鐚?dit_diary.pl????ゃ??????В????障???-?ヨ???隈????????????????鴻??若?302????c??ヨ?鐚?ist_diary.pl鐚??????ゃ????????障??????В??????parse_list_diary?<??????????????障???- -菴???ゃ?????c??????????????鴻??若???????????鴻?previous?<?????у???с?????????????絮ユ?????潟????????鴻??潟??潟??????????????帥???????? - -=head3 $item = $mixi->parse_send_message_preview( [$response ]); - -?<??祉??檎?篆<????????種?send_message.pl????ゃ??????В?????????????若?????????? -菴???ゃ?篁ヤ????????????ャ????????鴻???? - - { - '__action__' => 'http://mixi.jp/send_message.pl?id=267049', - 'subject' => '篁?????膣??', - 'body' => '篁????????????c???- ???????違????...', - 'submit' => 'confirm', - 'yes' => '?????拭??, - 'no' => '??信 罩c?', - 'post_key' => '777c74e88ba28b909be01d31082daa67', - } - -__action__???????若?????????絵??????????? -?????????????????拭??RL??;??????????с?????若??ゃ????????????- -'post_key'????????ixi?眼?????潟??????????菴???????? -?<??祉??吾???拭???鐚?ost?障???et_edit_diary_confirm鐚????????????若??????????????ゃ?綽???с???- -??????????????????parse_send_message_preview????鴻??潟??潟????400????鴻??潟??<??祉??吾?"Invalid Form Data"????眼??障???-菴???ゃ?????c??翫????綺???鴻??潟??潟??????????????帥???????? - -=head3 $item = $mixi->parse_send_message_confirm( [$response ]); - -?<??祉??檎?篆∞????send_message.pl????ゃ??????В????障???-菴???ゃ???札筝????????????ャ????????鴻???? - - { - 'result' => 1, - 'subject' => '??拭絎?????????? - 'banner' => { - 'subject' => '', - 'image' => 'http://img.mixi.jp/img/banner/yosoo03.gif', - 'link' => 'http://mixi.jp/banner.pl?id=63' - }, - } - -???????潟??潟??????拭絎??????????????????若?????ゃ??????????菴???ゃ?????障???? -?障?????鴻??潟????????帥?????障????????c???????菴???ゃ?????障???? -???????翫???????????<??祉??檎?篆<?紊掩?????????? -菴???ゃ?????c??翫?????鴻??潟??潟????200?с???????????鴻??潟?????????00?с???????????鴻?????若?????с???????????????? - -=head2 Fetch data - -?贋・????帥??????????????純??????? - -絎?????????????????????吾??????В???茵???????? -菴???ゃ???戎??????茹f??<????鐚?arse_鐔??????????? - -????水???<????????若??c??違?膂≦?????障????菴???ゃ??????????????若?莎激???????????????????綵???潟?????????????????c???????羈???????????? -????????????log?<????????吾??????????????<??祉??悟???????response?<?????х???TTP???????鴻???????茹f?????????????羈?????????????????荐?????????с?????障???et?<????鐚?arse_鐔???純????篏帥????????с????鐚?? - -=head3 @items = $mixi->get_main_menu( [$url | $url => 'refresh'] ) - -????????RL????ゃ??<??ャ??????????? -菴???ゃ?parse_main_menu????????? - -????????RL???緇??get?障???ost?<?????у?????URL??????????障???RL???絎?????????????????緇??get?障???ost?<?????у?????????帥??<??潟?????若?菴???障???-???URL?с?????????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_banner( [$url | $url => 'refresh'] ) - -????????RL???????????????? -菴???ゃ?parse_banner????????? - -????????RL???緇??get?障???ost?<?????у?????URL??????????障???RL???絎?????????????????緇??get?障???ost?<?????у?????????帥??<??潟?????若?菴???障???-???URL?с?????????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_tool_bar( [$url | $url => 'refresh'] ) - -????????RL????若?????????????? -菴???ゃ?parse_tool_bar????????? - -????????RL???緇??get?障???ost?<?????у?????URL??????????障???RL???絎?????????????????緇??get?障???ost?<?????у?????????帥??<??潟?????若?菴???障???-???URL?с?????????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_information( [$url | $url => 'refresh' | 'refresh'] ); - -????????RL??????膊∞????????????????????????? -URL???絎??????c????????若????絲乗院????障???-菴???ゃ?parse_information????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_calendar( [$url | $url => 'refresh' | 'refresh'] ); - -????潟??若?????????? -???????????????????潟??若?絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_calendar????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_calendar_term( [$url | $url => 'refresh' | 'refresh'] ); - -????潟??若????鐚?拘????????????? -???????????????????潟??若?絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_calendar_term????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_calendar_next( [$url | $url => 'refresh' | 'refresh'] ); - -????潟??若??????????????潟??????????? -????????????????潟??若????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_calendar_next????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_calendar_previous( [$url | $url => 'refresh' | 'refresh'] ); - -????潟??若??????????????潟??????????? -????????????????潟??若????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_calendar_previous????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_bookmark( [$url | $url => 'refresh' | 'refresh'] ); - -?????????????????? -?????????????若????????????????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_list_bookmark????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_comment( [$url | $url => 'refresh' | 'refresh'] ); - -???????<????????????? -???????????????????<???????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_list_comment????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_community( [$url | $url => 'refresh' | 'refresh'] ); - -?潟??ャ????筝?Η?????????? -?????????????潟??ャ????筝?Η???絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_community????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_community_next( [$url | $url => 'refresh' | 'refresh'] ); - -?潟??ャ????筝?Η???罨<?????吾??吾???????????????? -?????????????潟??ャ????筝?Η???絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_community_next????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_community_previous( [$url | $url => 'refresh' | 'refresh'] ); - -?潟??ャ????筝?Η??????????吾??吾???????????????? -?????????????潟??ャ????筝?Η???絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_community_previous????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_diary( [$url | $url => 'refresh' | 'refresh'] ); - -?ヨ?筝?Η?????????? -?????????????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_diary????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_diary_capacity( [$url | $url => 'refresh' | 'refresh'] ); - -?ヨ?????ヨ???戎???羈???????????? -?????????????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_diary_capacity????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_diary_next( [$url | $url => 'refresh' | 'refresh'] ); - -?ヨ????罨<?????吾??吾???????????????? -?????????????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_diary_next????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_diary_previous( [$url | $url => 'refresh' | 'refresh'] ); - -?ヨ???????????吾??吾???????????????? -?????????????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_diary_previous????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_diary_monthy_menu( [$url | $url => 'refresh' | 'refresh'] ); - -?ヨ????????ゃ????????吾???????????????? -?????????????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_diary_monthy_menu????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_friend( [$url | $url => 'refresh' | 'refresh'] ); - -??査?紫?篋坂?荀с?????????? -??????????????査?紫?篋坂?荀с????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_list_friend????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_friend_next( [$url | $url => 'refresh' | 'refresh'] ); - -??査?紫?篋坂?荀с????????若????????潟??????????? -??????????????査?紫?篋坂?荀с????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_list_friend_next????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_list_friend_previous( [$url | $url => 'refresh' | 'refresh'] ); - -??査?紫?篋坂?荀с????????若????????潟??????????? -??????????????査?紫?篋坂?荀с????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_list_friend_previous????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_message( [$url | $url => 'refresh' | 'refresh'] ); - -???菴????拭?<??祉??吾??????????? -??????????????????拭?<??祉??吾????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_list_message????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_list_outbox( [$url | $url => 'refresh' | 'refresh'] ); - -???菴????拭?<??祉??吾??????????? -??????????????拭?<??祉??吾???????????吾?絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_list_message????????? - -=head3 @items = $mixi->get_new_album( [$url | $url => 'refresh' | 'refresh'] ); - -???????激?????≪?????????????? -???????????????????激?????≪???????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_album????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_new_bbs( [$url | $url => 'refresh' | 'refresh'] ); - -?潟??ャ????????吾?莨若??????????? -?????????????潟??ャ????????梧昭?帥????莟<?????????RL???絎????????????若????莟<??????? -菴???ゃ?parse_new_bbs????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_new_bbs_next( [$url | $url => 'refresh' | 'refresh'] ); - -?潟??ャ????????吾?莨若????罨<?????吾??吾???????????????? -?????????????潟??ャ????????吾?莨若????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_bbs_next????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_new_bbs_previous( [$url | $url => 'refresh' | 'refresh'] ); - -?潟??ャ????????吾?莨若???????????吾??吾???????????????? -?????????????潟??ャ????????吾?莨若????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_bbs_previous????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_new_comment( [$url | $url => 'refresh' | 'refresh'] ); - -?ヨ??潟??潟?荐??絮ユ??????????? -?????????????ヨ??潟??潟?荐??絮ユ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_comment????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_new_diary( [$url | $url => 'refresh' | 'refresh'] [,'keyword' => $keyword]); - -?亥??ヨ?罎?刈?????????? -?????????????亥??ヨ?罎?刈???絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_diary????????? - -罎?刈????????????????????RL?????昭???????違?筝??????????? -????????????罎?刈???????????????膣∝????菴???????? -筝≧???????????????RL筝??????????????????障???- -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_new_diary_next( [$url | $url => 'refresh' | 'refresh'] [,'keyword' => $keyword]); - -?亥??ヨ?罎?刈???罨<?????吾??吾???????????????? -?????????????亥??ヨ?罎?刈???絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_diary_next????????? - -罎?刈???????????RL?????昭???????違?筝??????????? -?亥??ヨ?罎?刈?с??????????????????????????若???????????吾???????????с?URL筝??????違?????若??若??????????腆阪???け?????????羈???????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_new_diary_previous( [$url | $url => 'refresh' | 'refresh'] [,'keyword' => $keyword]); - -?亥??ヨ?罎?刈??????????吾??吾???????????????? -?????????????亥??ヨ?罎?刈???絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_diary_previous????????? - -罎?刈???????????RL?????昭???????違?筝??????????? -?亥??ヨ?罎?刈?с??????????????????????????若???????????吾???????????с?URL筝??????違?????若??若??????????腆阪???け?????????羈???????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_new_friend_diary( [$url | $url => 'refresh' | 'refresh'] ); - -???????激?????ヨ??????????? -???????????????????激?????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_friend_diary????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_new_friend_diary_next( [$url | $url => 'refresh' | 'refresh'] ); - -???????激?????ヨ????罨<?????吾??吾???????????????? -???????????????????激?????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_friend_diary_next????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_new_friend_diary_previous( [$url | $url => 'refresh' | 'refresh'] ); - -???????激?????ヨ???????????吾??吾???????????????? -???????????????????激?????ヨ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_friend_diary_previous????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_new_review( [$url | $url => 'refresh' | 'refresh'] ); - -???????激????????ャ??????????? -???????????????????激????????ャ????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_new_review????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $id = $mixi->get_self_id( ['refresh'] ); - -??????????ャ?鐚?ist_review.pl鐚?????????若??吾????????鴻?茹f???? -?????D????????? -ID?????с?????c????菴???ゃ?0?с???-???????違?????????? -菴???ゃ?parse_self_id????????? - -?????et?障???ost?<?????у?????????吾??????????????若?????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_show_log( [$url | $url => 'refresh' | 'refresh'] ); - -???????????????? -?????????????????????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_show_log????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $count = $mixi->get_show_log_count( [$url | $url => 'refresh' | 'refresh'] ); - -???????違?????????? -?????????????????????絲乗院????障????URL???絎????????????若????莟<??????? -菴???ゃ?parse_show_log_count????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_show_friend_outline( $url [ => 'refresh'] ); - -???????若??????????????????????? -????<?????с???RL???絎??綽???с???-菴???ゃ?parse_show_friend_outline????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_show_friend_profile( $url [ => 'refresh'] ); - -???????若??????????? -????<?????с???RL???絎??綽???с???-菴???ゃ?parse_show_friend_profile????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_view_diary( $url [ => 'refresh'] ); - -?ヨ??????????? -????<?????с???RL???絎??綽???с???-菴???ゃ?parse_view_diary????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 $item = $mixi->get_view_message( $url [ => 'refresh'] ); - -?<??祉??吾?????????? -????<?????с???RL???絎??綽???с???-菴???ゃ?parse_view_message????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head3 @items = $mixi->get_view_message_form( $url [ => 'refresh'] ); - -?<??祉??吾?????????? -????<?????с???RL???絎??綽???с???-菴???ゃ?parse_view_message????????? - -?????et?障???ost?<?????у?????????吾?絲乗院URL???????????????????帥?菴???障???-???????若??????????????'refresh'???絎??????????? - -=head2 Post data - -?贋・????帥???┸??????????純??????? - -絎????????????????????????若??吾?post?????????? - -=head3 @items = $mixi->get_add_diary_preview('diary_title' => $title, 'diary_body' => $body [, 'photo1' => $path_to_photo1] [, 'photo2' => $path_to_photo2] [, 'photo3' => $path_to_photo3]); - -?ヨ?篏??????吾?綣??????若????篆<????????ャ?????吾???????茹f??????? -菴???ゃ?parse_add_diary_preview????????? - -=head3 @items = $mixi->get_add_diary_confirm('diary_title' => $title, 'diary_body' => $body, 'post_key' => $key [, 'photo1' => $path_to_photo1] [, 'photo2' => $path_to_photo2] [, 'photo3' => $path_to_photo3]); - -?ヨ????腮帥??障???-菴???ゃ?parse_add_diary_confirm????????? - -=head3 @items = $mixi->get_delete_diary_preview('id' => $id); - -?ヨ??????∈茯???≪???????茹f??????? -菴???ゃ?parse_delete_diary_preview????????? - -=head3 @items = $mixi->get_delete_diary_confirm('id' => $id, 'post_key' => $key); - -?ヨ?????ゃ??障???-菴???ゃ?parse_delete_diary_confirm????????? - -=head3 @items = $mixi->get_edit_diary_preview($url|'id' => $id); - -?ヨ???隈??????腮随?????吾???????茹f??????? -菴???ゃ?parse_edit_diary_preview????????? - -=head3 @items = $mixi->get_edit_diary_image($url|'id' => $id); - -?ヨ???隈??????腮随?????吾???????茹f??????? -菴???ゃ?parse_edit_diary_image????????? - -=head3 @items = $mixi->get_edit_diary_confirm('id' => $id, 'diary_title' => $title, 'diary_body' => $body [, 'photo1' => $path_to_photo1] [, 'photo2' => $path_to_photo2] [, 'photo3' => $path_to_photo3]); - -?ヨ???隈??????腮随??????? -菴???ゃ?parse_edit_diary_confirm????????? - -=head3 @items = $mixi->get_send_message_preview('id' => $id, 'subject' => $subject, 'body' => $body); - -$id????若??弱????????若???拭????吾?綣??????若????篆<????????ャ?????吾???????茹f??????? -菴???ゃ?parse_send_message_preview????????? - -=head3 @items = $mixi->get_send_message_confirm('id' => $id, 'subject' => $subject, 'body' => $body [, 'post_key' => $key]); - -$id????若??弱????????若????篆<??障???-菴???ゃ?parse_send_message_confirm????????? - -=head2 Convert URL - -URL??偽絲?RL??????????純??????? - -=head3 $url = $mixi->absolute_url($url [, $base]) - -$base????若?URL??????腟九?URL????????? -$base???絎??????????????mixi??????????醐?0.13?????http://mixi.jp/"鐚??????鴻??????? -URL??撮????'login'??show_logs'?????.pl'??????????ゃ?????????????????????- -=head3 $url = $mixi->absolute_linked_url($url) - -?????et?障???ost?<?????у?????????吾?URL????若?URL??????腟九?URL????????? -URL??撮????'login'??show_logs'?????.pl'??????????ゃ?????????????????????- -=head3 $url = $mixi->query_sorted_url($url) - -URL?????????鐚??"???緇??鐚???????????筝???帥??障???-?障????????純?"%20"?????????????????????????舟????障???-腟?????????????????絎鴻?????医???RL??????????障???- -????<???????薑?????????純????篏睡?????????┃????????????URL????若???????????ャ?????????????????????? - -=head2 Cookies - -Cookie???絖??茯?昭??????????<?????с???- -=head3 $mixi->enable_cookies($cookie_file) - -cookie????鴻??????? -???????違??鰹?login鐚??Cookie????粋昭?随?load_cookies鐚??????????????茵???????????絽吾???ず???茵??綽?????????????-????ゃ???????腴?????Cookie???篏?????????????????????????障???- -菴???ゃ?????吾??????昆?с???- -=head3 $mixi->save_cookies($cookie_file) - -cookie???絎鴻???????????<????篆???????? -??????????け??????0????????? - -=head3 $mixi->load_cookies($cookie_file) - -??????????<??????ookie????帥?茯??莨若??障???-??????????け??????0????????? - -=head2 Internal methods - -篁ヤ???WW::Mixi???????純??????? - -?堺??????WW::Mixi????<??????????篏睡???????????????????????????若??с??с?篁??????眼????????純????綮???????????????????-?с??????????????鴻????????????? - -=head3 $mixi->log - -????????????茵???<?????с?????у?????????? -????????????callback_log?<????????喝??????? - -=head3 $mixi->dumper_log - -綣??????潟?????違?????阪??障???????????純?????????????????障???-絎???????????log?<??????戎????障???- -=head3 $mixi->abort - -????惹???bort??????????純?????????????????障???-????????????callback_abort?<????????喝??????? - -=head3 $mixi->callback_log - -綣??????違?????激???IS?????????羣??????阪??????? -?障?????違?????若?????若?????障?????????bort?<????????喝??????? -?????og?<????????????????茖???????????????障???- -???篁ュ?????医?????????????????潟??鴻?????????- - $mixi = WWW::Mixi->new($mail, $pass, -log => \&my_callback_log); - -???????????撮????????阪??<???????臂??????c???????? - -=head3 $mixi->callback_abort - -die???茵???障???-?????bort?<????????????????茖???????????????障???- -=head3 $str = $mixi->rewrite - -????粋В??????????????????茵???<?????с???-????????????callback_rewrite?<????????喝??????? - -=head3 $str = $mixi->callback_rewrite($str); - -HTML?帥?????ゃ?HTML????宴????茹i?鐚???潟??鴻??若?鐚??茵???障???-?????ewrite?<????????????????茖???????????????障???- -=head3 $str = $mixi->escape($str); - -HTML????宴???????絖??????????? - -=head3 $str = $mixi->unescape($str); - -HTML?≪?????宴???????絖??????????? - -=head3 $str = $mixi->remove_tag($str); - -?帥?????ゃ????絖??????????? -HTML????????鐔????????????????篋??羈???????????? -??幻???unescape??????茵?????????с???- -=head3 $str = $mixi->remove_diary_tag($str); - -?ヨ???戎??????????????????帥?????ゃ??障???-?亥??ヨ?筝??羞桁????????鴻??若???????荐??????違????????ゃ????篏睡???????????????? - -?帥????筝????????????????????????障???? - -=head3 $mixi->redirect_ok - -????ゃ??????????浦????<?????с?WWW::Mixi??????絽吾?1????????? -?ゃ????????ゃ??????幻?????????茵???????? - -????<??????WP::RobotUA鐚??篁????WP::UserAgent鐚??????帥???edirect_ok?<????????吾?????????? - -=head3 @items = $mixi->parse_standard_history( [$response] ); - -罔?????絮ユ?????吾??<??渇??????В????純??????? -???????<????list_comment.pl????ゃ??????????????f??井???昭?随?new_bbs.pl????ゃ????????ゃ?????f??井?荐??new_friend_diary.pl????ゃ????????ゃ?????f??違???????new_album????ゃ????????ゃ?????f??違?????種?new_review.pl????ゃ???????荐???<?????ュ吋罩器?new_comment鐚??茹f??с??障???- -菴???ゃ??????????篁ヤ????????????ャ????????鴻???????????????? - - { - 'subject' => '?????????, - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -????????????????<???????????????障????????<???戎???????c???? -?上???????????若???arse_standard_history?цВ?????????????????arse_standard_history????喝???????????с????絨??????????ixi?眼?紊???????????????????-?????????????純???????茹f??с?????????arse_standard_history??戎?c????????眼????荀??????с??????- -=head3 @items = $mixi->parse_standard_form( [$response] ); - -罔????????????若??若????????若?茹f??<?????с???-????後???????????遵????form?帥???ction?≪?????ャ???????????????RL??nput?帥???????????若??ф?絎????????name??alue????≪?textare?帥???ame???絎鴻??????В????????? -菴???ゃ?????????????篁ヤ????????????ャ????????鴻???????????????? -__action__篁ュ?????若?茹f????????若???????????????絵??????????? - - { - '__action__' => 'http://mixi.jp/add_diary.pl', - 'submit' => 'confirm', - 'diary_title' => '篁?????荐?, - 'diary_body' => '篁????????????c?????障?????????..', - 'orig_size' => 1, - 'packed' => 'xxxxxxx_xxx_xxxx', - 'post_key' => 'xxxxxxx_xxx', - 'link' => 'http://mixi.jp/view_diary.pl?id=xxxxxx', - 'name' => '紂???х?', - 'time' => '2004/08/18 13:18' - } - -=head3 $url = $mixi->set_response( $url [ => 'refresh'] ) - -response?<?????????????$url??????????帥??????????????????? -?????????????茹f??<???????????????В???莟<??若???url??????????障???- -????????????$url???緇??get?障???ost?у?????URL????????????$url??et?у???????? -?????????筝????????????激????????????????????????? -????翫??с?????帥???????????????若????????????refresh'???絎??????????? - -=head3 @items = $mixi->post_add_diary('submit' => $action, 'diary_title' => $title, 'diary_body' => $body, [, 'photo1' => $path_to_photo1, 'photo2' => $path_to_photo2, 'photo3' => $path_to_photo3] [, 'orig_size' => 1]] [, 'packed' => $hash_value]); - -?ヨ?篏??????吾?綣??????若????篆<??障???-菴???ゃ???拭???HTTP::Response????吾?????с???- -?≪??激??潟????腆肴??脂???????????"main"????????┸????????confirm"???絎???障???-???1鐔??????∈茯???≪??????????????ゃ???????絎?????????障?????ゃ??ч?篆<??????????orig_size => 1???絎???障???- -絎?????腮帥????????????鐔??????撮??????∈茯???≪?茵?ず??????????ュ?鐚?acked????若?????わ????絎???障???- -=head3 @items = $mixi->post_edit_diary('submit' => $action, 'diary_id' => $id, 'diary_title' => $title, 'diary_body' => $body, 'photo1' => $path_to_photo1, 'photo2' => $path_to_photo2, 'photo3' => $path_to_photo3); - -?ヨ?膩??????吾?綣??????若????篆<??障???-菴???ゃ???拭???HTTP::Response????吾?????с???- -?≪??激??潟????膩??????????main"???絎???障???-???1鐔????????<?????鴻?????????? - -=head3 @items = $mixi->post_delete_diary('submit' => $action, 'diary_id' => $id); - -?ヨ????????吾?綣??????若????篆<??障???-菴???ゃ???拭???HTTP::Response????吾?????с???- -?≪??激??潟????腆肴??脂???????????"main"????????┸????????confirm"???絎???障???- -=head3 $time = $mixi->convert_login_time($time); - -???羂???ャ????茵?ず??????45??札?????????菴違????????????? - -=head2 Testing method - -篁ヤ???WW::Mixi???薑??????純??????? - -=head3 perl -MWWW::Mixi -e "WWW::Mixi::test('email', 'password' [, 'logfile'])" - -WWW::Mixi???罘?????薑?????????<?????с???- -0.13???????潟???????????違??潟?????帥??????ookie???絖??荅??????障???-???????????RL??????????ゃ??倶?????????若????鐚?et??ost鐚??茹f????????純????篏睡?????????? - -email??assword??ixi????違??潟??????????絎??????????? -???????ゃ???В???????阪???????????????? -???絎????LWP-Mixi-x.xx-test.log'??戎????????? - -=head1 RESPONSE CODE - -????ゃ?????若??с???ixi????鴻??潟??潟???200"???????????????絎??????潟??潟????絎鴻???WW::Mixi????鴻??潟??潟???????????鴻?????若???舟?????障???-?????????WWW::Mixi????若??若??????????"絎?蟹???"???????翫??????s_success?????????"絎?蟹???"紊掩?????翫?????純????鐚?s_error???????????????????障???- -????т戎?????????????鴻??若?????????????????????????????鴻??若?"400"???綵??mixi???Bad Request????????????????障?????潟???????????若????????????????????с???????????障???-???????鴻?????若???WW::Mixi??????????????????????с????????阪??????????? - -=over 4 - -=item "400" - -篁ヤ?????若??с????????鴻??若???00??舟????????障???- -=over 8 - -=item No Data - -箴????d???絎?????view_diary.pl???????鴻??????????????若???????????????????荐?????????吾?菴??????障???-?祉????????若??с?????????????????????????絎????????????若?????с?WWW::Mixi???????鴻??潟????400 Bad Request???筝?┏???????障???- -=item Invalid Form Data (????若?????若?) - -?ヨ???┸?ц;蕁???????????????????????????ャ??脂????????<??祉??吾?茵?ず????障???-parse_鐔?preview?<?????ф?腮帥?????ャ???В?????WW::Mixi???????鴻??潟????400 Bad Request???筝?┏???????障???- -篁???宴??鴻??????arse_鐔?preview?<?????цВ???茵???障?????鴻??潟??潟???????????鴻?????若???舟????????????????絵??????????? -request絎???翫??????幻????鴻??潟??潟????200????с??????- -=back - -Invalid Form Data????????若?????若???ixi??????????с???幻??????鐚??絖???若???UC鐚??????????絵??????????? -????<??祉??吾?????障??阪??????????箴???遺札筝???????????絖???若???????紊??????????????? - - use Jcode; - use WWW::Mixi - my $mixi = WWW::Mixi->new('your @ email', 'yourpassword'); - my $res = $mixi->login; - if ($res->code == 401) { - print jcode($res->message)->sjis, "\n"; - ... - } - -=item "401" - -篁ヤ?????若??с????????鴻??若???01??舟????????障???-?上?????????ixi????若????茯?┝???????????????????若??若?401????鴻?????宴??鴻??帥?????馹??????????? - -=over 8 - -=item Login Required - -????ゃ?????若???;腓冴?????????? -??????????違??潟???????????吟????????≪??????????????違??潟?綽??????????? - -=item Login Failed (????若?????若?) - -????ゃ?????若??????????????<??祉??吾?茵?ず???????障???-??????????ゃ???け????????????????<??祉??吾???????腆冴??倶???????????????? - -=back - -????ゃ?紊掩????????若?????若???ixi??????????с???幻??????鐚??絖???若???UC鐚??????????絵??????????? -????<??祉??吾?????障??阪??????????????潟????????????????????????? - -=item "403" - -篁ヤ?????若??с????????鴻??若???03??舟????????障???- -=over 8 - -=item Closed content - -???????鴻????????????????荐?????????吾?菴??????障???-?????????????蚊????査?障????????≪??祉?????画Η?с?????潟????????ヨ????鐚???≪??祉?????翫??с???- -=back - -=item "503" - -篁ヤ?????若??с????????鴻??若???03??舟????????障???- -=over 8 - -=item Too frequently requests - -??????腥冴?????g????????吾??欠Щ?紙??違??紫?????????????????...??????筝?????????若?????c??????? -????????ixi?眼?荐???????????????劫?????????????????≪??祉??????????????≪??祉???????????????? -????倶?????医?????医??????В?ゃ????????с???- -??幻??WW::Mixi???????激??ゃ??帥??????舟????≪??祉?????????????蕁??莎激????????????? -??ず????≪??祉??????????????紊??????????????????????????????????? -WWW::Mixi??ixi???紊с?莢???????????????????????????糸????藥?????????障??????????????????????????違??若???┃荐??荀????????綣激???エ?????? - -=back - -=back - -=head1 SEE ALSO - -L<LWP::UserAgent>, L<WWW::RobotUA>, L<HTTP::Request::Common> - -=head1 AUTHORS - -WWW::Mixi is written by TSUKAMOTO Makio <tsukamoto @ gmail.com> - -Some bug fixes submitted by Topia (http://clovery.jp/), shino (http://www.freedomcat.com/), makamaka (http://www.donzoko.net/), ??????, slash/onigawara (http://www.okoshi.org/), Mami Komura (http://www.warehouse56.com/). -get_ and post_add_diary, get_ and post_delete_diary, parse_list_diary, parse_list_diary_monthly_menu and parse_new_diary contributed by DonaDona (http://hsj.jp/). -get_ and parse_view_diary contributed by shino (http://www.freedomcat.com/). -get_ and parse_list_outbox contributed by AsO (http://www.bx.sakura.ne.jp/~clan/rn/cgi-bin/index.cgi). -get_ and post_send_message contributed by noname (http://untitled.rootkit.jp/diary/). - -=head1 COPYRIGHT - -Copyright 2004-2005 TSUKAMOTO Makio. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:49 +0900 Subject: [Affelio-cvs 703] CVS update: affelio_farm/admin/skelton/affelio/extlib/HTML Message-ID: <20051024192049.F2D9B2AC030@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/HTML/Form.pm diff -u affelio_farm/admin/skelton/affelio/extlib/HTML/Form.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/HTML/Form.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/HTML/Form.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/HTML/Form.pm Tue Oct 25 04:20:49 2005 @@ -1,734 +0,0 @@ -package HTML::Form; - -use strict; -use URI; -use Carp (); - -use vars qw($VERSION); -$VERSION='0.03'; - -my %form_tags = map {$_ => 1} qw(input textarea button select option); - -my %type2class = ( - text => "TextInput", - password => "TextInput", - file => "TextInput", - hidden => "TextInput", - textarea => "TextInput", - - button => "IgnoreInput", - "reset" => "IgnoreInput", - - radio => "ListInput", - checkbox => "ListInput", - option => "ListInput", - - submit => "SubmitInput", - image => "ImageInput", -); - -=head1 NAME - -HTML::Form - Class that represents HTML forms - -=head1 SYNOPSIS - - use HTML::Form; - $form = HTML::Form->parse($html, $base_uri); - $form->value(query => "Perl"); - - use LWP; - LWP::UserAgent->new->request($form->click); - -=head1 DESCRIPTION - -Objects of the C<HTML::Form> class represents a single HTML <form> -... </form> instance. A form consist of a sequence of inputs that -usually have names, and which can take on various values. - -The following methods are available: - -=over 4 - -=item $form = HTML::Form->new($method, $action_uri, [[$enctype], $input,...]) - -The constructor takes a $method and a $uri as argument. The $enctype -and and initial inputs are optional. You will normally use -HTML::Form->parse() to create new HTML::Form objects. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - $self->{method} = uc(shift || "GET"); - $self->{action} = shift || Carp::croak("No action defined"); - $self->{enctype} = shift || "application/x-www-form-urlencoded"; - $self->{inputs} = [@_]; - $self; -} - - -=item @forms = HTML::Form->parse($html_document, $base_uri) - -The parse() class method will parse an HTML document and build up -C<HTML::Form> objects for each <form> found. If called in scalar -context only returns the first <form>. Returns an empty list if there -are no forms to be found. - -The $base_uri is (usually) the URI used to access the $html_document. -It is needed to resolve relative action URIs. For LWP this parameter -is obtained from the $response->base() method. - -=cut - -sub parse -{ - my($class, $html, $base_uri) = @_; - require HTML::TokeParser; - my $p = HTML::TokeParser->new(\$html); - eval { - # optimization - $p->report_tags(qw(form input textarea select optgroup option)); - }; - - my @forms; - my $f; # current form - - while (my $t = $p->get_tag) { - my($tag,$attr) = @$t; - if ($tag eq "form") { - my $action = delete $attr->{'action'}; - $action = "" unless defined $action; - $action = URI->new_abs($action, $base_uri); - $f = $class->new(delete $attr->{'method'}, - $action, - delete $attr->{'enctype'}); - $f->{extra_attr} = $attr; - push(@forms, $f); - while (my $t = $p->get_tag) { - my($tag, $attr) = @$t; - last if $tag eq "/form"; - if ($tag eq "input") { - my $type = delete $attr->{type} || "text"; - $f->push_input($type, $attr); - } elsif ($tag eq "textarea") { - $attr->{textarea_value} = $attr->{value} - if exists $attr->{value}; - my $text = $p->get_text("/textarea"); - $attr->{value} = $text; - $f->push_input("textarea", $attr); - } elsif ($tag eq "select") { - $attr->{select_value} = $attr->{value} - if exists $attr->{value}; - while ($t = $p->get_tag) { - my $tag = shift @$t; - last if $tag eq "/select"; - next if $tag =~ m,/?optgroup,; - next if $tag eq "/option"; - if ($tag eq "option") { - my %a = (%$attr, %{$t->[0]}); - $a{value} = $p->get_trimmed_text - unless defined $a{value}; - $f->push_input("option", \%a); - } else { - Carp::carp("Bad <select> tag '$tag'") if $^W; - } - } - } - } - } elsif ($form_tags{$tag}) { - Carp::carp("<$tag> outside <form>") if $^W; - } - } - for (@forms) { - $_->fixup; - } - - wantarray ? @forms : $forms[0]; -} - -=item $form->push_input($type, \%attr) - -Adds a new input to the form. - -=cut - -sub push_input -{ - my($self, $type, $attr) = @_; - $type = lc $type; - my $class = $type2class{$type}; - unless ($class) { - Carp::carp("Unknown input type '$type'") if $^W; - $class = "IgnoreInput"; - } - $class = "IgnoreInput" if exists $attr->{disabled}; - $class = "HTML::Form::$class"; - - my $input = $class->new(type => $type, %$attr); - $input->add_to_form($self); -} - - -=item $form->method( [$new] ) - -=item $form->action( [$new] ) - -=item $form->enctype( [$new] ) - -These method can be used to get/set the corresponding attribute of the -form. - -=cut - -BEGIN { - # Set up some accesor - for (qw(method action enctype)) { - my $m = $_; - no strict 'refs'; - *{$m} = sub { - my $self = shift; - my $old = $self->{$m}; - $self->{$m} = shift if @_; - $old; - }; - } - *uri = \&action; # alias -} - - -=item $form->inputs - -This method returns the list of inputs in the form. - -=cut - -sub inputs -{ - my $self = shift; - @{$self->{'inputs'}}; -} - - -=item $form->find_input($name, $type, $no) - -This method is used to locate some specific input within the form. At -least one of the arguments must be defined. If no matching input is -found, C<undef> is returned. - -If $name is specified, then the input must have the indicated name. -If $type is specified then the input must have the specified type. In -addition to the types possible for <input> HTML tags, we also have -"textarea" and "option". The $no is the sequence number of the input -with the indicated $name and/or $type (where 1 is the first). - -=cut - -sub find_input -{ - my($self, $name, $type, $no) = @_; - $no ||= 1; - for (@{$self->{'inputs'}}) { - if (defined $name) { - next unless exists $_->{name}; - next if $name ne $_->{name}; - } - next if $type && $type ne $_->{type}; - next if --$no; - return $_; - } - return; -} - -sub fixup -{ - my $self = shift; - for (@{$self->{'inputs'}}) { - $_->fixup; - } -} - - -=item $form->value($name, [$value]) - -The value() method can be used to get/set the value of some input. If -no input have the indicated name, then this method will croak. - -=cut - -sub value -{ - my $self = shift; - my $key = shift; - my $input = $self->find_input($key); - Carp::croak("No such field '$key'") unless $input; - local $Carp::CarpLevel = 1; - $input->value(@_); -} - - -=item $form->try_others(\&callback) - -This method will iterate over all permutations of unvisited enumerated -values (<select>, <radio>, <checkbox>) and invoke the callback for -each. The callback is passed the $form as argument. - -=cut - -sub try_others -{ - my($self, $cb) = @_; - my @try; - for (@{$self->{'inputs'}}) { - my @not_tried_yet = $_->other_possible_values; - next unless @not_tried_yet; - push(@try, [\@not_tried_yet, $_]); - } - return unless @try; - $self->_try($cb, \@try, 0); -} - -sub _try -{ - my($self, $cb, $try, $i) = @_; - for (@{$try->[$i][0]}) { - $try->[$i][1]->value($_); - &$cb($self); - $self->_try($cb, $try, $i+1) if $i+1 < @$try; - } -} - - -=item $form->make_request - -Will return a HTTP::Request object that reflects the current setting -of the form. You might want to use the click method instead. - -=cut - -sub make_request -{ - my $self = shift; - my $method = uc $self->{'method'}; - my $uri = $self->{'action'}; - my $enctype = $self->{'enctype'}; - my @form = $self->form; - - if ($method eq "GET") { - require HTTP::Request; - $uri = URI->new($uri, "http"); - $uri->query_form(@form); - return HTTP::Request->new(GET => $uri); - } elsif ($method eq "POST") { - require HTTP::Request::Common; - return HTTP::Request::Common::POST($uri, \@form, - Content_Type => $enctype); - } else { - Carp::croak("Unknown method '$method'"); - } -} - - -=item $form->click([$name], [$x, $y]) - -Will click on the first clickable input (C<input/submit> or -C<input/image>), with the indicated $name, if specified. You can -optinally specify a coordinate clicked, which only makes a difference -if you clicked on an image. The default coordinate is (1,1). - -=cut - -sub click -{ - my $self = shift; - my $name; - $name = shift if (@_ % 2) == 1; # odd number of arguments - - # try to find first submit button to activate - for (@{$self->{'inputs'}}) { - next unless $_->can("click"); - next if $name && $_->name ne $name; - return $_->click($self, @_); - } - Carp::croak("No clickable input with name $name") if $name; - $self->make_request; -} - - -=item $form->form - -Returns the current setting as a sequence of key/value pairs. - -=cut - -sub form -{ - my $self = shift; - map {$_->form_name_value} @{$self->{'inputs'}}; -} - - -=item $form->dump - -Returns a textual representation of the form. Mainly useful for -debugging. If called in void context, then the dump is printed on -STDERR. - -=cut - -sub dump -{ - my $self = shift; - my $method = $self->{'method'}; - my $uri = $self->{'action'}; - my $enctype = $self->{'enctype'}; - my $dump = "$method $uri"; - $dump .= " ($enctype)" - if $enctype eq "application/xxx-www-form-urlencoded"; - $dump .= "\n"; - for ($self->inputs) { - $dump .= " " . $_->dump . "\n"; - } - print STDERR $dump unless defined wantarray; - $dump; -} - - -#--------------------------------------------------- -package HTML::Form::Input; - -=back - -=head1 INPUTS - -An C<HTML::Form> contains a sequence of inputs. References to the -inputs can be obtained with the $form->inputs or $form->find_input -methods. Once you have such a reference, then one of the following -methods can be used on it: - -=over 4 - -=cut - -sub new -{ - my $class = shift; - my $self = bless {@_}, $class; - $self; -} - -sub add_to_form -{ - my($self, $form) = @_; - push(@{$form->{'inputs'}}, $self); - $self; -} - -sub fixup {} - - -=item $input->type - -Returns the type of this input. Types are stuff like "text", -"password", "hidden", "textarea", "image", "submit", "radio", -"checkbox", "option"... - -=cut - -sub type -{ - shift->{type}; -} - -=item $input->name([$new]) - -=item $input->value([$new]) - -These methods can be used to set/get the current name or value of an -input. If the input only can take an enumerated list of values, then -it is an error to try to set it to something else and the method will -croak if you try. - -=cut - -sub name -{ - my $self = shift; - my $old = $self->{name}; - $self->{name} = shift if @_; - $old; -} - -sub value -{ - my $self = shift; - my $old = $self->{value}; - $self->{value} = shift if @_; - $old; -} - -=item $input->possible_values - -Returns a list of all values that and input can take. For inputs that -does not have discrete values this returns an empty list. - -=cut - -sub possible_values -{ - return; -} - -=item $input->other_possible_values - -Returns a list of all values not tried yet. - -=cut - -sub other_possible_values -{ - return; -} - -=item $input->form_name_value - -Returns a (possible empty) list of key/value pairs that should be -incorporated in the form value from this input. - -=cut - -sub form_name_value -{ - my $self = shift; - my $name = $self->{'name'}; - return unless defined $name; - my $value = $self->value; - return unless defined $value; - return ($name => $value); -} - -sub dump -{ - my $self = shift; - my $name = $self->name; - $name = "<NONAME>" unless defined $name; - my $value = $self->value; - $value = "<UNDEF>" unless defined $value; - my $dump = "$name=$value"; - - my $type = $self->type; - return $dump if $type eq "text"; - - $type = ($type eq "text") ? "" : " ($type)"; - my $menu = $self->{menu} || ""; - if ($menu) { - my @menu; - for (0 .. @$menu-1) { - my $opt = $menu->[$_]; - $opt = "<UNDEF>" unless defined $opt; - substr($opt,0,0) = "*" if $self->{seen}[$_]; - push(@menu, $opt); - } - $menu = "[" . join("|", @menu) . "]"; - } - sprintf "%-30s %-10s %s", $dump, $type, $menu; -} - - -#--------------------------------------------------- -package HTML::Form::TextInput; - @ HTML::Form::TextInput::ISA=qw(HTML::Form::Input); - -#input/text -#input/password -#input/file -#input/hidden -#textarea - -sub value -{ - my $self = shift; - if (@_) { - if (exists($self->{readonly}) || $self->{type} eq "hidden") { - Carp::carp("Input '$self->{name}' is readonly") if $^W; - } - } - $self->SUPER::value(@_); -} - -#--------------------------------------------------- -package HTML::Form::IgnoreInput; - @ HTML::Form::IgnoreInput::ISA=qw(HTML::Form::Input); - -#input/button -#input/reset - -sub value { return } - - -#--------------------------------------------------- -package HTML::Form::ListInput; - @ HTML::Form::ListInput::ISA=qw(HTML::Form::Input); - -#select/option (val1, val2, ....) -#input/radio (undef, val1, val2,...) -#input/checkbox (undef, value) - -sub new -{ - my $class = shift; - my $self = $class->SUPER::new(@_); - if ($self->type eq "checkbox") { - my $value = delete $self->{value}; - $value = "on" unless defined $value; - $self->{menu} = [undef, $value]; - $self->{current} = (exists $self->{checked}) ? 1 : 0; - delete $self->{checked}; - } else { - $self->{menu} = [delete $self->{value}]; - my $checked = exists $self->{checked} || exists $self->{selected}; - delete $self->{checked}; - delete $self->{selected}; - if (exists $self->{multiple}) { - unshift(@{$self->{menu}}, undef); - $self->{current} = $checked ? 1 : 0; - } else { - $self->{current} = 0 if $checked; - } - } - $self; -} - -sub add_to_form -{ - my($self, $form) = @_; - my $type = $self->type; - return $self->SUPER::add_to_form($form) - if $type eq "checkbox" || - ($type eq "option" && exists $self->{multiple}); - - my $prev = $form->find_input($self->{name}, $self->{type}); - return $self->SUPER::add_to_form($form) unless $prev; - - # merge menues - push(@{$prev->{menu}}, @{$self->{menu}}); - $prev->{current} = @{$prev->{menu}} - 1 if exists $self->{current}; -} - -sub fixup -{ - my $self = shift; - if ($self->{type} eq "option" && !(exists $self->{current})) { - $self->{current} = 0; - } - $self->{seen} = [(0) x @{$self->{menu}}]; - $self->{seen}[$self->{current}] = 1 if exists $self->{current}; -} - -sub value -{ - my $self = shift; - my $old; - $old = $self->{menu}[$self->{current}] if exists $self->{current}; - if (@_) { - my $i = 0; - my $val = shift; - my $cur; - for (@{$self->{menu}}) { - if ((defined($val) && defined($_) && $val eq $_) || - (!defined($val) && !defined($_)) - ) - { - $cur = $i; - last; - } - $i++; - } - Carp::croak("Illegal value '$val'") unless defined $cur; - $self->{current} = $cur; - $self->{seen}[$cur] = 1; - } - $old; -} - -sub possible_values -{ - my $self = shift; - @{$self->{menu}}; -} - -sub other_possible_values -{ - my $self = shift; - map { $self->{menu}[$_] } - grep {!$self->{seen}[$_]} - 0 .. (@{$self->{seen}} - 1); -} - - -#--------------------------------------------------- -package HTML::Form::SubmitInput; - @ HTML::Form::SubmitInput::ISA=qw(HTML::Form::Input); - -#input/image -#input/submit - -=item $input->click($form, $x, $y) - -Some input types (currently "sumbit" buttons and "images") can be -clicked to submit the form. The click() method returns the -corrsponding C<HTTP::Request> object. - -=cut - -sub click -{ - my($self,$form,$x,$y) = @_; - for ($x, $y) { $_ = 1 unless defined; } - local($self->{clicked}) = [$x,$y]; - return $form->make_request; -} - -sub form_name_value -{ - my $self = shift; - return unless $self->{clicked}; - return $self->SUPER::form_name_value(@_); -} - - -#--------------------------------------------------- -package HTML::Form::ImageInput; - @ HTML::Form::ImageInput::ISA=qw(HTML::Form::SubmitInput); - -sub form_name_value -{ - my $self = shift; - my $clicked = $self->{clicked}; - return unless $clicked; - my $name = $self->{name}; - return unless defined $name; - return ("$name.x" => $clicked->[0], - "$name.y" => $clicked->[1] - ); -} - -1; - -__END__ - -=back - -=head1 SEE ALSO - -L<LWP>, L<HTML::Parser>, L<webchatpp> - -=head1 COPYRIGHT - -Copyright 1998-2000 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/HTML/Template.pm diff -u affelio_farm/admin/skelton/affelio/extlib/HTML/Template.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/HTML/Template.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/HTML/Template.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/HTML/Template.pm Tue Oct 25 04:20:49 2005 @@ -1,3040 +0,0 @@ -package HTML::Template; - -$HTML::Template::VERSION = '2.4'; - -=head1 NAME - -HTML::Template - Perl module to use HTML Templates from CGI scripts - -=head1 SYNOPSIS - -First you make a template - this is just a normal HTML file with a few -extra tags, the simplest being <TMPL_VAR> - -For example, test.tmpl: - - <HTML> - <HEAD><TITLE>Test Template - - My Home Directory is -

- My Path is set to - - - - -Now create a small CGI program: - - use HTML::Template; - - # open the html template - my $template = HTML::Template->new(filename => 'test.tmpl'); - - # fill in some parameters - $template->param( - HOME => $ENV{HOME}, - PATH => $ENV{PATH}, - ); - - # send the obligatory Content-Type - print "Content-Type: text/html\n\n"; - - # print the template - print $template->output; - -If all is well in the universe this should show something like this in -your browser when visiting the CGI: - -My Home Directory is /home/some/directory -My Path is set to /bin;/usr/bin - -=head1 DESCRIPTION - -This module attempts to make using HTML templates simple and natural. It -extends standard HTML with a few new HTML-esque tags - , -, , and . The file -written with HTML and these new tags is called a template. It is -usually saved separate from your script - possibly even created by -someone else! Using this module you fill in the values for the -variables, loops and branches declared in the template. This allows -you to separate design - the HTML - from the data, which you generate -in the Perl script. - -A Japanese translation of the documentation is available at: - - http://member.nifty.ne.jp/hippo2000/perltips/html/template.htm - -This module is licensed under the GPL. See the LICENSE section -below for more details. - -=head1 MOTIVATION - -It is true that there are a number of packages out there to do HTML -templates. On the one hand you have things like HTML::Embperl which -allows you freely mix Perl with HTML. On the other hand lie -home-grown variable substitution solutions. Hopefully the module can -find a place between the two. - -One advantage of this module over a full HTML::Embperl-esque solution -is that it enforces an important divide - design and programming. By -limiting the programmer to just using simple variables and loops in -the HTML, the template remains accessible to designers and other -non-perl people. The use of HTML-esque syntax goes further to make -the format understandable to others. In the future this similarity -could be used to extend existing HTML editors/analyzers to support -HTML::Template. - -An advantage of this module over home-grown tag-replacement schemes is -the support for loops. In my work I am often called on to produce -tables of data in html. Producing them using simplistic HTML -templates results in CGIs containing lots of HTML since the HTML -itself cannot represent loops. The introduction of loop statements in -the HTML simplifies this situation considerably. The designer can -layout a single row and the programmer can fill it in as many times as -necessary - all they must agree on is the parameter names. - -For all that, I think the best thing about this module is that it does -just one thing and it does it quickly and carefully. It doesn't try -to replace Perl and HTML, it just augments them to interact a little -better. And it's pretty fast. - -=head1 The Tags - -Note: even though these tags look like HTML they are a little -different - they're allowed to "break the rules". Something like: - - - -is not really valid HTML, but it is a perfectly valid use and will -work as planned. - -The "NAME=" in the tag is optional, although for extensibility's sake I -recommend using it. Example - "" is acceptable. - -If you're a fanatic about valid HTML and would like your templates -to conform to valid HTML syntax, you may optionally type template tags -in the form of HTML comments. This may be of use to HTML authors who -would like to validate their templates' HTML syntax prior to -HTML::Template processing, or who use DTD-savvy editing tools. - - - -In order to realize a dramatic savings in bandwidth, the standard -(non-comment) tags will be used throughout the rest of this -documentation. - -=head2 - -The tag is very simple. For each tag in the -template you call $template->param(PARAMETER_NAME => "VALUE"). When -the template is output the is replaced with the VALUE text -you specified. If you don't set a parameter it just gets skipped in -the output. - -Optionally you can use the "ESCAPE=HTML" option in the tag to indicate -that you want the value to be HTML-escaped before being returned from -output (the old ESCAPE=1 syntax is still supported). This means that -the ", <, >, and & characters get translated into ", <, > -and & respectively. This is useful when you want to use a -TMPL_VAR in a context where those characters would cause trouble. -Example: - - "> - -If you called param() with a value like sam"my you'll get in trouble -with HTML's idea of a double-quote. On the other hand, if you use -ESCAPE=HTML, like this: - - "> - -You'll get what you wanted no matter what value happens to be passed in for -param. You can also write ESCAPE="HTML", ESCAPE='HTML' and ESCAPE='1'. -Substitute a 0 for the HTML and you turn off escaping, which is the default -anyway. - -There is also the "ESCAPE=URL" option which may be used for VARs that -populate a URL. It will do URL escaping, like replacing ' ' with '+' -and '/' with '%2F'. - -=head2 - -The tag is a bit more complicated. The tag -allows you to delimit a section of text and give it a name. Inside -the you place s. Now you pass to param() a list -(an array ref) of parameter assignments (hash refs). The loop -iterates over this list and produces output from the text block for -each pass. Unset parameters are skipped. Here's an example: - - In the template: - - - Name:

- Job:

-

- - - - In the script: - - $template->param(EMPLOYEE_INFO => [ - { name => 'Sam', job => 'programmer' }, - { name => 'Steve', job => 'soda jerk' }, - ] - ); - print $template->output(); - - - The output: - - Name: Sam

- Job: programmer

-

- Name: Steve

- Job: soda jerk

-

- -As you can see above the takes a list of variable -assignments and then iterates over the loop body producing output. - -Often you'll want to generate a 's contents -programmatically. Here's an example of how this can be done (many -other ways are possible!): - - # a couple of arrays of data to put in a loop: - my @words = qw(I Am Cool); - my @numbers = qw(1 2 3); - - my @loop_data = (); # initialize an array to hold your loop - - while (@words and @numbers) { - my %row_data; # get a fresh hash for the row data - - # fill in this row - $row_data{WORD} = shift @words; - $row_data{NUMBER} = shift @numbers; - - # the crucial step - push a reference to this row into the loop! - push(@loop_data, \%row_data); - } - - # finally, assign the loop data to the loop param, again with a - # reference: - $template->param(THIS_LOOP => \@loop_data); - -The above example would work with a template like: - - - Word:
- Number:

- - -It would produce output like: - - Word: I - Number: 1 - - Word: Am - Number: 2 - - Word: Cool - Number: 3 - - -s within s are fine and work as you would -expect. If the syntax for the param() call has you stumped, here's an -example of a param call with one nested loop: - - $template->param('ROW',[ - { name => 'Bobby', - nicknames => [ - { name => 'the big bad wolf' }, - { name => 'He-Man' }, - ], - }, - ], - ); - -Basically, each gets an array reference. Inside the array -are any number of hash references. These hashes contain the -name=>value pairs for a single pass over the loop template. - -Inside a , the only variables that are usable are the ones -from the . The variables in the outer blocks are not -visible within a template loop. For the computer-science geeks among -you, a introduces a new scope much like a perl subroutine -call. If you want your variables to be global you can use -'global_vars' option to new described below. - -=head2 - -This tag includes a template directly into the current template at the -point where the tag is found. The included template contents are used -exactly as if its contents were physically included in the master -template. - -The file specified can be a full path - beginning with a '/'. If it -isn't a full path, the path to the enclosing file is tried first. -After that the path in the environment variable HTML_TEMPLATE_ROOT is -tried next, if it exists. Next, the "path" new() option is consulted. -As a final attempt, the filename is passed to open() directly. See -below for more information on HTML_TEMPLATE_ROOT and the "path" option -to new(). - -As a protection against infinitly recursive includes, an arbitary -limit of 10 levels deep is imposed. You can alter this limit with the -"max_includes" option. See the entry for the "max_includes" option -below for more details. - -=head2 - -The tag allows you to include or not include a block of the -template based on the value of a given parameter name. If the -parameter is given a value that is true for Perl - like '1' - then the -block is included in the output. If it is not defined, or given a -false value - like '0' - then it is skipped. The parameters are -specified the same way as with TMPL_VAR. - -Example Template: - - - Some text that only gets displayed if BOOL is true! - - -Now if you call $template->param(BOOL => 1) then the above block will -be included by output. - - blocks can include any valid HTML::Template -construct - VARs and LOOPs and other IF/ELSE blocks. Note, however, -that intersecting a and a is invalid. - - Not going to work: - - - - - -If the name of a TMPL_LOOP is used in a TMPL_IF, the IF block will -output if the loop has at least one row. Example: - - - This will output if the loop is not empty. - - - - .... - - -WARNING: Much of the benefit of HTML::Template is in decoupling your -Perl and HTML. If you introduce numerous cases where you have -TMPL_IFs and matching Perl if()s, you will create a maintenance -problem in keeping the two synchronized. I suggest you adopt the -practice of only using TMPL_IF if you can do so without requiring a -matching if() in your Perl code. - -=head2 - -You can include an alternate block in your TMPL_IF block by using -TMPL_ELSE. NOTE: You still end the block with , not -! - - Example: - - - Some text that is included only if BOOL is true - - Some text that is included only if BOOL is false - - -=head2 - -This tag is the opposite of . The block is output if the -CONTROL_PARAMETER is set false or not defined. You can use - with just as you can with . - - Example: - - - Some text that is output only if BOOL is FALSE. - - Some text that is output only if BOOL is TRUE. - - -If the name of a TMPL_LOOP is used in a TMPL_UNLESS, the UNLESS block -output if the loop has zero rows. - - - This will output if the loop is empty. - - - - .... - - -=cut - -=head1 Methods - -=head2 new() - -Call new() to create a new Template object: - - my $template = HTML::Template->new( filename => 'file.tmpl', - option => 'value' - ); - -You must call new() with at least one name => value pair specifying how -to access the template text. You can use "filename => 'file.tmpl'" to -specify a filename to be opened as the template. Alternately you can -use: - - my $t = HTML::Template->new( scalarref => $ref_to_template_text, - option => 'value' - ); - -and - - my $t = HTML::Template->new( arrayref => $ref_to_array_of_lines , - option => 'value' - ); - - -These initialize the template from in-memory resources. In almost -every case you'll want to use the filename parameter. If you're -worried about all the disk access from reading a template file just -use mod_perl and the cache option detailed below. - -You can also read the template from an already opened filehandle, -either traditionally as a glob or as a FileHandle: - - my $t = HTML::Template->new( filehandle => *FH, option => 'value'); - -The four new() calling methods can also be accessed as below, if you -prefer. - - my $t = HTML::Template->new_file('file.tmpl', option => 'value'); - - my $t = HTML::Template->new_scalar_ref($ref_to_template_text, - option => 'value'); - - my $t = HTML::Template->new_array_ref($ref_to_array_of_lines, - option => 'value'); - - my $t = HTML::Template->new_filehandle($fh, - option => 'value'); - -And as a final option, for those that might prefer it, you can call new as: - - my $t = HTML::Template->new(type => 'filename', - source => 'file.tmpl'); - -Which works for all three of the source types. - -If the environment variable HTML_TEMPLATE_ROOT is set and your -filename doesn't begin with /, then the path will be relative to the -value of $HTML_TEMPLATE_ROOT. Example - if the environment variable -HTML_TEMPLATE_ROOT is set to "/home/sam" and I call -HTML::Template->new() with filename set to "sam.tmpl", the -HTML::Template will try to open "/home/sam/sam.tmpl" to access the -template file. You can also affect the search path for files with the -"path" option to new() - see below for more information. - -You can modify the Template object's behavior with new. These options -are available: - -=over 4 - -=item * - -die_on_bad_params - if set to 0 the module will let you call -$template->param(param_name => 'value') even if 'param_name' doesn't -exist in the template body. Defaults to 1. - -=item * - -strict - if set to 0 the module will allow things that look like they might be TMPL_* tags to get by without dieing. Example: - - - -Would normally cause an error, but if you call new with strict => 0, -HTML::Template will ignore it. Defaults to 1. - -=item * - -cache - if set to 1 the module will cache in memory the parsed -templates based on the filename parameter and modification date of the -file. This only applies to templates opened with the filename -parameter specified, not scalarref or arrayref templates. Caching -also looks at the modification times of any files included using - tags, but again, only if the template is opened with -filename parameter. - -This is mainly of use in a persistent environment like -Apache/mod_perl. It has absolutely no benefit in a normal CGI -environment since the script is unloaded from memory after every -request. For a cache that does work for normal CGIs see the -'shared_cache' option below. - -Note that different new() parameter settings do not cause a cache -refresh, only a change in the modification time of the template will -trigger a cache refresh. For most usages this is fine. My simplistic -testing shows that using cache yields a 90% performance increase under -mod_perl. Cache defaults to 0. - -=item * - -shared_cache - if set to 1 the module will store its cache in shared -memory using the IPC::SharedCache module (available from CPAN). The -effect of this will be to maintain a single shared copy of each parsed -template for all instances of HTML::Template to use. This can be a -significant reduction in memory usage in a multiple server -environment. As an example, on one of our systems we use 4MB of -template cache and maintain 25 httpd processes - shared_cache results -in saving almost 100MB! Of course, some reduction in speed versus -normal caching is to be expected. Another difference between normal -caching and shared_cache is that shared_cache will work in a CGI -environment - normal caching is only useful in a persistent -environment like Apache/mod_perl. - -By default HTML::Template uses the IPC key 'TMPL' as a shared root -segment (0x4c504d54 in hex), but this can be changed by setting the -'ipc_key' new() parameter to another 4-character or integer key. -Other options can be used to affect the shared memory cache correspond -to IPC::SharedCache options - ipc_mode, ipc_segment_size and -ipc_max_size. See L for a description of how these -work - in most cases you shouldn't need to change them from the -defaults. - -For more information about the shared memory cache system used by -HTML::Template see L. - -=item * - -double_cache - if set to 1 the module will use a combination of -shared_cache and normal cache mode for the best possible caching. Of -course, it also uses the most memory of all the cache modes. All the -same ipc_* options that work with shared_cache apply to double_cache -as well. By default double_cache is off. - -=item * - -blind_cache - if set to 1 the module behaves exactly as with normal -caching but does not check to see if the file has changed on each -request. This option should be used with caution, but could be of use -on high-load servers. My tests show blind_cache performing only 1 to -2 percent faster than cache under mod_perl. - -NOTE: Combining this option with shared_cache can result in stale -templates stuck permanently in shared memory! - -=item * - -file_cache - if set to 1 the module will store its cache in a file -using the Storable module. It uses no additional memory, and my -simplistic testing shows that it yields a 50% performance advantage. -Like shared_cache, it will work in a CGI environment. Default is 0. - -If you set this option you must set the "file_cache_dir" option. See -below for details. - -NOTE: Storable using flock() to ensure safe access to cache files. -Using file_cache on a system or filesystem (NFS) without flock() -support is dangerous. - - -=item * - -file_cache_dir - sets the directory where the module will store the -cache files if file_cache is enabled. Your script will need write -permissions to this directory. You'll also need to make sure the -sufficient space is available to store the cache files. - -=item * - -file_cache_dir_mode - sets the file mode for newly created file_cache -directories and subdirectories. Defaults to 0700 for security but -this may be inconvenient if you do not have access to the account -running the webserver. - -=item * - -double_file_cache - if set to 1 the module will use a combination of -file_cache and normal cache mode for the best possible caching. The -file_cache_* options that work with file_cache apply to double_file_cache -as well. By default double_file_cache is 0. - -=item * - -associate - this option allows you to inherit the parameter values -from other objects. The only requirement for the other object is that -it have a param() method that works like HTML::Template's param(). A -good candidate would be a CGI.pm query object. Example: - - my $query = new CGI; - my $template = HTML::Template->new(filename => 'template.tmpl', - associate => $query); - -Now, $template->output() will act as though - - $template->param('FormField', $cgi->param('FormField')); - -had been specified for each key/value pair that would be provided by -the $cgi->param() method. Parameters you set directly take precedence -over associated parameters. - -You can specify multiple objects to associate by passing an anonymous -array to the associate option. They are searched for parameters in -the order they appear: - - my $template = HTML::Template->new(filename => 'template.tmpl', - associate => [$query, $other_obj]); - -The old associateCGI() call is still supported, but should be -considered obsolete. - -NOTE: The parameter names are matched in a case-insensitve manner. If -you have two parameters in a CGI object like 'NAME' and 'Name' one -will be chosen randomly by associate. This behavior can be changed by -the following option. - -=item * - -case_sensitive - setting this option to true causes HTML::Template to -treat template variable names case-sensitively. The following example -would only set one parameter without the "case_sensitive" option: - - my $template = HTML::Template->new(filename => 'template.tmpl', - case_sensitive => 1); - $template->param( - FieldA => 'foo', - fIELDa => 'bar', - ); - -This option defaults to off. - -=item * - -loop_context_vars - when this parameter is set to true (it is false by -default) four loop context variables are made available inside a loop: -__FIRST__, __LAST__, __INNER__, __ODD__. They can be used with -, and to control how a loop is -output. Example: - - - - This only outputs on the first pass. - - - - This outputs every other pass, on the odd passes. - - - - This outputs every other pass, on the even passes. - - - - This outputs on passes that are neither first nor last. - - - - This only outputs on the last pass. - - - -One use of this feature is to provide a "separator" similar in effect -to the perl function join(). Example: - - - and - , . - - -Would output (in a browser) something like: - - Apples, Oranges, Brains, Toes, and Kiwi. - -Given an appropriate param() call, of course. NOTE: A loop with only -a single pass will get both __FIRST__ and __LAST__ set to true, but -not __INNER__. - -=item * - -path - you can set this variable with a list of paths to search for -files specified with the "filename" option to new() and for files -included with the tag. This list is only consulted -when the filename is relative. The HTML_TEMPLATE_ROOT environment -variable is always tried first if it exists. In the case of a - file, the path to the including file is also tried -before path is consulted. - -Example: - - my $template = HTML::Template->new( filename => 'file.tmpl', - path => [ '/path/to/templates', - '/alternate/path' - ] - ); - -NOTE: the paths in the path list must be expressed as UNIX paths, -separated by the forward-slash character ('/'). - -=item * - -no_includes - set this option to 1 to disallow the tag -in the template file. This can be used to make opening untrusted -templates B less dangerous. Defaults to 0. - -=item * - -max_includes - set this variable to determine the maximum depth that -includes can reach. Set to 10 by default. Including files to a depth -greater than this value causes an error message to be displayed. Set -to 0 to disable this protection. - -=item * - -search_path_on_include - if set to a true value the module will search -from the top of the array of paths specified by the path option on -every and use the first matching template found. The -normal behavior is to look only in the current directory for a -template to include. Defaults to 0. - -=item * - -global_vars - normally variables declared outside a loop are not -available inside a loop. This option makes s like global -variables in Perl - they have unlimited scope. This option also -affects and . - -Example: - - This is a normal variable: .

- - - Here it is inside the loop:

- - -Normally this wouldn't work as expected, since 's -value outside the loop is not available inside the loop. - -=item * - -filter - this option allows you to specify a filter for your template -files. A filter is a subroutine that will be called after -HTML::Template reads your template file but before it starts parsing -template tags. - -In the most simple usage, you simply assign a code reference to the -filter parameter. This subroutine will recieve a single arguement - a -reference to a string containing the template file text. Here is an -example that accepts templates with tags that look like "!!!ZAP_VAR -FOO!!!" and transforms them into HTML::Template tags: - - my $filter = sub { - my $text_ref = shift; - $$text_ref =~ s/!!!ZAP_(.*?)!!!//g; - } - - # open zap.tmpl using the above filter - my $template = HTML::Template->new(filename => 'zap.tmpl', - filter => $filter); - -More complicated usages are possible. You can request that your -filter receieve the template text as an array of lines rather than as -a single scalar. To do that you need to specify your filter using a -hash-ref. In this form you specify the filter using the "sub" key and -the desired argument format using the "format" key. The available -formats are "scalar" and "array". Using the "array" format will incur -a performance penalty but may be more convenient in some situations. - - my $template = HTML::Template->new(filename => 'zap.tmpl', - filter => { sub => $filter, - format => 'array' }); - -You may also have multiple filters. This allows simple filters to be -combined for more elaborate functionality. To do this you specify an -array of filters. The filters are applied in the order they are -specified. - - my $template = HTML::Template->new(filename => 'zap.tmpl', - filter => [ - { sub => \&decompress, - format => 'scalar' }, - { sub => \&remove_spaces, - format => 'array' } - ]); - -The specified filters will be called for any TMPL_INCLUDEed files just -as they are for the main template file. - -=item * - -vanguard_compatibility_mode - if set to 1 the module will expect to -see s that look like %NAME% in addition to the standard -syntax. Also sets die_on_bad_params => 0. If you're not at Vanguard -Media trying to use an old format template don't worry about this one. -Defaults to 0. - -=item * - -debug - if set to 1 the module will write random debugging information -to STDERR. Defaults to 0. - -=item * - -stack_debug - if set to 1 the module will use Data::Dumper to print -out the contents of the parse_stack to STDERR. Defaults to 0. - -=item * - -cache_debug - if set to 1 the module will send information on cache -loads, hits and misses to STDERR. Defaults to 0. - -=item * - -shared_cache_debug - if set to 1 the module will turn on the debug -option in IPC::SharedCache - see L for -details. Defaults to 0. - -=item * - -memory_debug - if set to 1 the module will send information on cache -memory usage to STDERR. Requires the GTop module. Defaults to 0. - -=back 4 - -=cut - - -use integer; # no floating point math so far! -use strict; # and no funny business, either. - -use Carp; # generate better errors with more context -use File::Spec; # generate paths that work on all platforms - -# define accessor constants used to improve readability of array -# accesses into "objects". I used to use 'use constant' but that -# seems to cause occasional irritating warnings in older Perls. -package HTML::Template::LOOP; -sub TEMPLATE_HASH { 0; } -sub PARAM_SET { 1 }; - -package HTML::Template::COND; -sub VARIABLE { 0 }; -sub VARIABLE_TYPE { 1 }; -sub VARIABLE_TYPE_VAR { 0 }; -sub VARIABLE_TYPE_LOOP { 1 }; -sub JUMP_IF_TRUE { 2 }; -sub JUMP_ADDRESS { 3 }; -sub WHICH { 4 }; -sub WHICH_IF { 0 }; -sub WHICH_UNLESS { 1 }; - -# back to the main package scope. -package HTML::Template; - -# open a new template and return an object handle -sub new { - my $pkg = shift; - my $self; { my %hash; $self = bless(\%hash, $pkg); } - - # the options hash - my $options = {}; - $self->{options} = $options; - - # set default parameters in options hash - %$options = ( - debug => 0, - stack_debug => 0, - timing => 0, - search_path_on_include => 0, - cache => 0, - blind_cache => 0, - file_cache => 0, - file_cache_dir => '', - file_cache_dir_mode => 0700, - cache_debug => 0, - shared_cache_debug => 0, - memory_debug => 0, - die_on_bad_params => 1, - vanguard_compatibility_mode => 0, - associate => [], - path => [], - strict => 1, - loop_context_vars => 0, - max_includes => 10, - shared_cache => 0, - double_cache => 0, - double_file_cache => 0, - ipc_key => 'TMPL', - ipc_mode => 0666, - ipc_segment_size => 65536, - ipc_max_size => 0, - global_vars => 0, - no_includes => 0, - case_sensitive => 0, - filter => [], - ); - - # load in options supplied to new() - for (my $x = 0; $x <= $#_; $x += 2) { - defined($_[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value"); - $options->{lc($_[$x])} = $_[($x + 1)]; - } - - # blind_cache = 1 implies cache = 1 - $options->{blind_cache} and $options->{cache} = 1; - - # shared_cache = 1 implies cache = 1 - $options->{shared_cache} and $options->{cache} = 1; - - # file_cache = 1 implies cache = 1 - $options->{file_cache} and $options->{cache} = 1; - - # double_cache is a combination of shared_cache and cache. - $options->{double_cache} and $options->{cache} = 1; - $options->{double_cache} and $options->{shared_cache} = 1; - - # double_file_cache is a combination of file_cache and cache. - $options->{double_file_cache} and $options->{cache} = 1; - $options->{double_file_cache} and $options->{file_cache} = 1; - - # vanguard_compatibility_mode implies die_on_bad_params = 0 - $options->{vanguard_compatibility_mode} and - $options->{die_on_bad_params} = 0; - - # handle the "type", "source" parameter format (does anyone use it?) - if (exists($options->{type})) { - exists($options->{source}) or croak("HTML::Template->new() called with 'type' parameter set, but no 'source'!"); - ($options->{type} eq 'filename' or $options->{type} eq 'scalarref' or - $options->{type} eq 'arrayref' or $options->{type} eq 'filehandle') or - croak("HTML::Template->new() : type parameter must be set to 'filename', 'arrayref', 'scalarref' or 'filehandle'!"); - - $options->{$options->{type}} = $options->{source}; - delete $options->{type}; - delete $options->{source}; - } - - # associate should be an array of one element if it's not - # already an array. - if (ref($options->{associate}) ne 'ARRAY') { - $options->{associate} = [ $options->{associate} ]; - } - - # path should be an array if it's not already - if (ref($options->{path}) ne 'ARRAY') { - $options->{path} = [ $options->{path} ]; - } - - # filter should be an array if it's not already - if (ref($options->{filter}) ne 'ARRAY') { - $options->{filter} = [ $options->{filter} ]; - } - - # make sure objects in associate area support param() - foreach my $object (@{$options->{associate}}) { - defined($object->can('param')) or - croak("HTML::Template->new called with associate option, containing object of type " . ref($object) . " which lacks a param() method!"); - } - - # check for syntax errors: - my $source_count = 0; - exists($options->{filename}) and $source_count++; - exists($options->{filehandle}) and $source_count++; - exists($options->{arrayref}) and $source_count++; - exists($options->{scalarref}) and $source_count++; - if ($source_count != 1) { - croak("HTML::Template->new called with multiple (or no) template sources specified! A valid call to new() has exactly one filename => 'file' OR exactly one scalarref => \\\$scalar OR exactly one arrayref => \\\@array OR exactly one filehandle => \*FH"); - } - - # do some memory debugging - this is best started as early as possible - if ($options->{memory_debug}) { - # memory_debug needs GTop - eval { require GTop; }; - croak("Could not load GTop. You must have GTop installed to use HTML::Template in memory_debug mode. The error was: $@") - if ($@); - $self->{gtop} = GTop->new(); - $self->{proc_mem} = $self->{gtop}->proc_mem($$); - print STDERR "\n### HTML::Template Memory Debug ### START ", $self->{proc_mem}->size(), "\n"; - } - - if ($options->{file_cache}) { - # make sure we have a file_cache_dir option - croak("You must specify the file_cache_dir option if you want to use file_cache.") - unless defined $options->{file_cache_dir} and - length $options->{file_cache_dir}; - - # file_cache needs some extra modules loaded - eval { require Storable; }; - croak("Could not load Storable. You must have Storable installed to use HTML::Template in file_cache mode. The error was: $@") - if ($@); - eval { require Digest::MD5; }; - croak("Could not load Digest::MD5. You must have Digest::MD5 installed to use HTML::Template in file_cache mode. The error was: $@") - if ($@); - } - - if ($options->{shared_cache}) { - # shared_cache needs some extra modules loaded - eval { require IPC::SharedCache; }; - croak("Could not load IPC::SharedCache. You must have IPC::SharedCache installed to use HTML::Template in shared_cache mode. The error was: $@") - if ($@); - - # initialize the shared cache - my %cache; - tie %cache, 'IPC::SharedCache', - ipc_key => $options->{ipc_key}, - load_callback => [\&_load_shared_cache, $self], - validate_callback => [\&_validate_shared_cache, $self], - debug => $options->{shared_cache_debug}, - ipc_mode => $options->{ipc_mode}, - max_size => $options->{ipc_max_size}, - ipc_segment_size => $options->{ipc_segment_size}; - $self->{cache} = \%cache; - } - - print STDERR "### HTML::Template Memory Debug ### POST CACHE INIT ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - # initialize data structures - $self->_init; - - print STDERR "### HTML::Template Memory Debug ### POST _INIT CALL ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - # drop the shared cache - leaving out this step results in the - # template object evading garbage collection since the callbacks in - # the shared cache tie hold references to $self! This was not easy - # to find, by the way. - delete $self->{cache} if $options->{shared_cache}; - - return $self; -} - -# an internally used new that receives its parse_stack and param_map as input -sub _new_from_loop { - my $pkg = shift; - my $self; { my %hash; $self = bless(\%hash, $pkg); } - - # the options hash - my $options = {}; - $self->{options} = $options; - - # set default parameters in options hash - a subset of the options - # valid in a normal new(). Since _new_from_loop never calls _init, - # many options have no relevance. - %$options = ( - debug => 0, - stack_debug => 0, - die_on_bad_params => 1, - associate => [], - loop_context_vars => 0, - ); - - # load in options supplied to new() - for (my $x = 0; $x <= $#_; $x += 2) { - defined($_[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value"); - $options->{lc($_[$x])} = $_[($x + 1)]; - } - - $self->{param_map} = $options->{param_map}; - $self->{parse_stack} = $options->{parse_stack}; - delete($options->{param_map}); - delete($options->{parse_stack}); - - return $self; -} - -# a few shortcuts to new(), of possible use... -sub new_file { - my $pkg = shift; return $pkg->new('filename', @_); -} -sub new_filehandle { - my $pkg = shift; return $pkg->new('filehandle', @_); -} -sub new_array_ref { - my $pkg = shift; return $pkg->new('arrayref', @_); -} -sub new_scalar_ref { - my $pkg = shift; return $pkg->new('scalarref', @_); -} - -# initializes all the object data structures, either from cache or by -# calling the appropriate routines. -sub _init { - my $self = shift; - my $options = $self->{options}; - - if ($options->{double_cache}) { - # try the normal cache, return if we have it. - $self->_fetch_from_cache(); - return if (defined $self->{param_map} and defined $self->{parse_stack}); - - # try the shared cache - $self->_fetch_from_shared_cache(); - - # put it in the local cache if we got it. - $self->_commit_to_cache() - if (defined $self->{param_map} and defined $self->{parse_stack}); - } elsif ($options->{double_file_cache}) { - # try the normal cache, return if we have it. - $self->_fetch_from_cache(); - return if (defined $self->{param_map} and defined $self->{parse_stack}); - - # try the file cache - $self->_fetch_from_file_cache(); - - # put it in the local cache if we got it. - $self->_commit_to_cache() - if (defined $self->{param_map} and defined $self->{parse_stack}); - } elsif ($options->{shared_cache}) { - # try the shared cache - $self->_fetch_from_shared_cache(); - } elsif ($options->{file_cache}) { - # try the file cache - $self->_fetch_from_file_cache(); - } elsif ($options->{cache}) { - # try the normal cache - $self->_fetch_from_cache(); - } - - # if we got a cache hit, return - return if (defined $self->{param_map} and defined $self->{parse_stack}); - - # if we're here, then we didn't get a cached copy, so do a full - # init. - $self->_init_template(); - $self->_parse(); - - # now that we have a full init, cache the structures if cacheing is - # on. shared cache is already cool. - if($options->{file_cache}){ - $self->_commit_to_file_cache(); - } - $self->_commit_to_cache() if (($options->{cache} - and not $options->{shared_cache} - and not $options->{file_cache}) or - ($options->{double_cache}) or - ($options->{double_file_cache})); -} - -# Caching subroutines - they handle getting and validating cache -# records from either the in-memory or shared caches. - -# handles the normal in memory cache -use vars qw( %CACHE ); -sub _fetch_from_cache { - my $self = shift; - my $options = $self->{options}; - - # return if there's no cache entry for this filename - return unless exists($options->{filename}); - my $filepath = $self->_find_file($options->{filename}); - return unless (defined($filepath) and - exists $CACHE{$filepath}); - - $options->{filepath} = $filepath; - - # validate the cache - my $mtime = $self->_mtime($filepath); - if (defined $mtime) { - # return if the mtime doesn't match the cache - if (defined($CACHE{$filepath}{mtime}) and - ($mtime != $CACHE{$filepath}{mtime})) { - $options->{cache_debug} and - print STDERR "CACHE MISS : $filepath : $mtime\n"; - return; - } - - # if the template has includes, check each included file's mtime - # and return if different - if (exists($CACHE{$filepath}{included_mtimes})) { - foreach my $filename (keys %{$CACHE{$filepath}{included_mtimes}}) { - next unless - defined($CACHE{$filepath}{included_mtimes}{$filename}); - - my $included_mtime = (stat($filename))[9]; - if ($included_mtime != $CACHE{$filepath}{included_mtimes}{$filename}) { - $options->{cache_debug} and - print STDERR "### HTML::Template Cache Debug ### CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n"; - - return; - } - } - } - } - - # got a cache hit! - - $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n"; - - $self->{param_map} = $CACHE{$filepath}{param_map}; - $self->{parse_stack} = $CACHE{$filepath}{parse_stack}; - exists($CACHE{$filepath}{included_mtimes}) and - $self->{included_mtimes} = $CACHE{$filepath}{included_mtimes}; - - # clear out values from param_map from last run - $self->_normalize_options(); - $self->clear_params(); -} - -sub _commit_to_cache { - my $self = shift; - my $options = $self->{options}; - - my $filepath = $options->{filepath}; - if (not defined $filepath) { - $filepath = $self->_find_file($options->{filename}); - confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") - unless defined($filepath); - $options->{filepath} = $filepath; - } - - $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE LOAD : $filepath\n"; - - $options->{blind_cache} or - $CACHE{$filepath}{mtime} = $self->_mtime($filepath); - $CACHE{$filepath}{param_map} = $self->{param_map}; - $CACHE{$filepath}{parse_stack} = $self->{parse_stack}; - exists($self->{included_mtimes}) and - $CACHE{$filepath}{included_mtimes} = $self->{included_mtimes}; -} - -# generates MD5 from filepath to determine filename for cache file -sub _get_cache_filename { - my ($self, $filepath) = @_; - - # hash the filename ... - my $hash = Digest::MD5->md5_hex($filepath); - - # ... and build a path out of it. Using the first two charcters - # gives us 255 buckets. This means you can have 255,000 templates - # in the cache before any one directory gets over a few thousand - # files in it. That's probably pretty good for this planet. If not - # then it should be configurable. - if (wantarray) { - return (substr($hash,0,2), substr($hash,2)) - } else { - return File::Spec->join($self->{options}{file_cache_dir}, - substr($hash,0,2), substr($hash,2)); - } -} - -# handles the file cache -sub _fetch_from_file_cache { - my $self = shift; - my $options = $self->{options}; - return unless exists($options->{filename}); - - # return if there's no cache entry for this filename - my $filepath = $self->_find_file($options->{filename}); - return unless defined $filepath; - my $cache_filename = $self->_get_cache_filename($filepath); - return unless -e $cache_filename; - - eval { - $self->{record} = Storable::lock_retrieve($cache_filename); - }; - croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $@") - if $@; - croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $!") - unless defined $self->{record}; - - ($self->{mtime}, - $self->{included_mtimes}, - $self->{param_map}, - $self->{parse_stack}) = @{$self->{record}}; - - $options->{filepath} = $filepath; - - # validate the cache - my $mtime = $self->_mtime($filepath); - if (defined $mtime) { - # return if the mtime doesn't match the cache - if (defined($self->{mtime}) and - ($mtime != $self->{mtime})) { - $options->{cache_debug} and - print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : $mtime\n"; - ($self->{mtime}, - $self->{included_mtimes}, - $self->{param_map}, - $self->{parse_stack}) = (undef, undef, undef, undef); - return; - } - - # if the template has includes, check each included file's mtime - # and return if different - if (exists($self->{included_mtimes})) { - foreach my $filename (keys %{$self->{included_mtimes}}) { - next unless - defined($self->{included_mtimes}{$filename}); - - my $included_mtime = (stat($filename))[9]; - if ($included_mtime != $self->{included_mtimes}{$filename}) { - $options->{cache_debug} and - print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n"; - ($self->{mtime}, - $self->{included_mtimes}, - $self->{param_map}, - $self->{parse_stack}) = (undef, undef, undef, undef); - return; - } - } - } - } - - # got a cache hit! - $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE HIT : $filepath\n"; - - # clear out values from param_map from last run - $self->_normalize_options(); - $self->clear_params(); -} - -sub _commit_to_file_cache { - my $self = shift; - my $options = $self->{options}; - - my $filepath = $options->{filepath}; - if (not defined $filepath) { - $filepath = $self->_find_file($options->{filename}); - confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") - unless defined($filepath); - $options->{filepath} = $filepath; - } - - my ($cache_dir, $cache_file) = $self->_get_cache_filename($filepath); - $cache_dir = File::Spec->join($options->{file_cache_dir}, $cache_dir); - if (not -d $cache_dir) { - if (not -d $options->{file_cache_dir}) { - mkdir($options->{file_cache_dir},$options->{file_cache_dir_mode}) - or croak("HTML::Template->new() : can't mkdir $options->{file_cache_dir} (file_cache => 1): $!"); - } - mkdir($cache_dir,$options->{file_cache_dir_mode}) - or croak("HTML::Template->new() : can't mkdir $cache_dir (file_cache => 1): $!"); - } - - $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE LOAD : $options->{filepath}\n"; - - my $result; - eval { - $result = Storable::lock_store([ $self->{mtime}, - $self->{included_mtimes}, - $self->{param_map}, - $self->{parse_stack} ], - scalar File::Spec->join($cache_dir, $cache_file) - ); - }; - croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $@") - if $@; - croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $!") - unless defined $result; -} - -# Shared cache routines. -sub _fetch_from_shared_cache { - my $self = shift; - my $options = $self->{options}; - - my $filepath = $self->_find_file($options->{filename}); - return unless defined $filepath; - - # fetch from the shared cache. - $self->{record} = $self->{cache}{$filepath}; - - ($self->{mtime}, - $self->{included_mtimes}, - $self->{param_map}, - $self->{parse_stack}) = @{$self->{record}} - if defined($self->{record}); - - $options->{cache_debug} and defined($self->{record}) and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n"; - # clear out values from param_map from last run - $self->_normalize_options(), $self->clear_params() - if (defined($self->{record})); - delete($self->{record}); - - return $self; -} - -sub _validate_shared_cache { - my ($self, $filename, $record) = @_; - my $options = $self->{options}; - - $options->{shared_cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE VALIDATE : $filename\n"; - - return 1 if $options->{blind_cache}; - - my ($c_mtime, $included_mtimes, $param_map, $parse_stack) = @$record; - - # if the modification time has changed return false - my $mtime = $self->_mtime($filename); - if (defined $mtime and defined $c_mtime - and $mtime != $c_mtime) { - $options->{cache_debug} and - print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : $mtime\n"; - return 0; - } - - # if the template has includes, check each included file's mtime - # and return false if different - if (defined $mtime and defined $included_mtimes) { - foreach my $fname (keys %$included_mtimes) { - next unless defined($included_mtimes->{$fname}); - if ($included_mtimes->{$fname} != (stat($fname))[9]) { - $options->{cache_debug} and - print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : INCLUDE $fname\n"; - return 0; - } - } - } - - # all done - return true - return 1; -} - -sub _load_shared_cache { - my ($self, $filename) = @_; - my $options = $self->{options}; - my $cache = $self->{cache}; - - $self->_init_template(); - $self->_parse(); - - $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE LOAD : $options->{filepath}\n"; - - print STDERR "### HTML::Template Memory Debug ### END CACHE LOAD ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - return [ $self->{mtime}, - $self->{included_mtimes}, - $self->{param_map}, - $self->{parse_stack} ]; -} - -# utility function - given a filename performs documented search and -# returns a full path of undef if the file cannot be found. -sub _find_file { - my ($self, $filename, $extra_path) = @_; - my $options = $self->{options}; - my $filepath; - - # first check for a full path - return File::Spec->canonpath($filename) - if (File::Spec->file_name_is_absolute($filename) and (-e $filename)); - - # try the extra_path if one was specified - if (defined($extra_path)) { - $extra_path->[$#{$extra_path}] = $filename; - $filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path)); - return File::Spec->canonpath($filepath) if -e $filepath; - } - - # try pre-prending HTML_Template_Root - if (exists($ENV{HTML_TEMPLATE_ROOT})) { - $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename); - return File::Spec->canonpath($filepath) if -e $filepath; - } - - # try "path" option list.. - foreach my $path (@{$options->{path}}) { - $filepath = File::Spec->canonpath(File::Spec->catfile($path, $filename)); - return File::Spec->canonpath($filepath) if -e $filepath; - } - - # try even a relative path from the current directory... - return File::Spec->canonpath($filename) if -e $filename; - - return undef; -} - -# utility function - computes the mtime for $filename -sub _mtime { - my ($self, $filepath) = @_; - my $options = $self->{options}; - - return(undef) if ($options->{blind_cache}); - - # make sure it still exists in the filesystem - (-r $filepath) or Carp::confess("HTML::Template : template file $filepath does not exist or is unreadable."); - - # get the modification time - return (stat(_))[9]; -} - -# utility function - enforces new() options across LOOPs that have -# come from a cache. Otherwise they would have stale options hashes. -sub _normalize_options { - my $self = shift; - my $options = $self->{options}; - - my @pstacks = ($self->{parse_stack}); - while(@pstacks) { - my $pstack = pop(@pstacks); - foreach my $item (@$pstack) { - next unless (ref($item) eq 'HTML::Template::LOOP'); - foreach my $template (values %{$item->[HTML::Template::LOOP::TEMPLATE_HASH]}) { - # must be the same list as the call to _new_from_loop... - $template->{options}{debug} = $options->{debug}; - $template->{options}{stack_debug} = $options->{stack_debug}; - $template->{options}{die_on_bad_params} = $options->{die_on_bad_params}; - $template->{options}{case_sensitive} = $options->{case_sensitive}; - - push(@pstacks, $template->{parse_stack}); - } - } - } -} - -# initialize the template buffer -sub _init_template { - my $self = shift; - my $options = $self->{options}; - - print STDERR "### HTML::Template Memory Debug ### START INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - if (exists($options->{filename})) { - my $filepath = $options->{filepath}; - if (not defined $filepath) { - $filepath = $self->_find_file($options->{filename}); - confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") - unless defined($filepath); - # we'll need this for future reference - to call stat() for example. - $options->{filepath} = $filepath; - } - - confess("HTML::Template->new() : Cannot open included file $options->{filename} : $!") - unless defined(open(TEMPLATE, $filepath)); - $self->{mtime} = $self->_mtime($filepath); - - # read into scalar, note the mtime for the record - $self->{template} = ""; - while (read(TEMPLATE, $self->{template}, 10240, length($self->{template}))) {} - close(TEMPLATE); - - } elsif (exists($options->{scalarref})) { - # copy in the template text - $self->{template} = ${$options->{scalarref}}; - - delete($options->{scalarref}); - } elsif (exists($options->{arrayref})) { - # if we have an array ref, join and store the template text - $self->{template} = join("", @{$options->{arrayref}}); - - delete($options->{arrayref}); - } elsif (exists($options->{filehandle})) { - # just read everything in in one go - local $/ = undef; - $self->{template} = readline($options->{filehandle}); - - delete($options->{filehandle}); - } else { - confess("HTML::Template : Need to call new with filename, filehandle, scalarref or arrayref parameter specified."); - } - - print STDERR "### HTML::Template Memory Debug ### END INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - # handle filters if necessary - $self->_call_filters(\$self->{template}) if @{$options->{filter}}; - - return $self; -} - -# handle calling user defined filters -sub _call_filters { - my $self = shift; - my $template_ref = shift; - my $options = $self->{options}; - - my ($format, $sub); - foreach my $filter (@{$options->{filter}}) { - croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.") - unless ref $filter; - - # translate into CODE->HASH - $filter = { 'format' => 'scalar', 'sub' => $filter } - if (ref $filter eq 'CODE'); - - if (ref $filter eq 'HASH') { - $format = $filter->{'format'}; - $sub = $filter->{'sub'}; - - # check types and values - croak("HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.") - unless defined $format and defined $sub; - croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'") - unless $format eq 'array' or $format eq 'scalar'; - croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref") - unless ref $sub and ref $sub eq 'CODE'; - - # catch errors - eval { - if ($format eq 'scalar') { - # call - $sub->($template_ref); - } else { - # modulate - my @array = map { $_."\n" } split("\n", $$template_ref); - # call - $sub->(\@array); - # demodulate - $$template_ref = join("", @array); - } - }; - croak("HTML::Template->new() : fatal error occured during filter call: $@") if $@; - } else { - croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref"); - } - } - # all done - return $template_ref; -} - -# _parse sifts through a template building up the param_map and -# parse_stack structures. -# -# The end result is a Template object that is fully ready for -# output(). -sub _parse { - my $self = shift; - my $options = $self->{options}; - - $options->{debug} and print STDERR "### HTML::Template Debug ### In _parse:\n"; - - # setup the stacks and maps - they're accessed by typeglobs that - # reference the top of the stack. They are masked so that a loop - # can transparently have its own versions. - use vars qw(@pstack %pmap @ifstack @ucstack %top_pmap); - local (*pstack, *ifstack, *pmap, *ucstack, *top_pmap); - - # the pstack is the array of scalar refs (plain text from the - # template file), VARs, LOOPs, IFs and ELSEs that output() works on - # to produce output. Looking at output() should make it clear what - # _parse is trying to accomplish. - my @pstacks = ([]); - *pstack = $pstacks[0]; - $self->{parse_stack} = $pstacks[0]; - - # the pmap binds names to VARs, LOOPs and IFs. It allows param() to - # access the right variable. NOTE: output() does not look at the - # pmap at all! - my @pmaps = ({}); - *pmap = $pmaps[0]; - *top_pmap = $pmaps[0]; - $self->{param_map} = $pmaps[0]; - - # the ifstack is a temporary stack containing pending ifs and elses - # waiting for a /if. - my @ifstacks = ([]); - *ifstack = $ifstacks[0]; - - # the ucstack is a temporary stack containing conditions that need - # to be bound to param_map entries when their block is finished. - # This happens when a conditional is encountered before any other - # reference to its NAME. Since a conditional can reference VARs and - # LOOPs it isn't possible to make the link right away. - my @ucstacks = ([]); - *ucstack = $ucstacks[0]; - - # the loopstack is another temp stack for closing loops. unlike - # those above it doesn't get scoped inside loops, therefore it - # doesn't need the typeglob magic. - my @loopstack = (); - - # the fstack is a stack of filenames and counters that keeps track - # of which file we're in and where we are in it. This allows - # accurate error messages even inside included files! - # fcounter, fmax and fname are aliases for the current file's info - use vars qw($fcounter $fname $fmax); - local (*fcounter, *fname, *fmax); - - my @fstack = ([$options->{filename} || "main template", - 1, - scalar @{[$self->{template} =~ m/(\n)/g]} + 1 - ]); - (*fname, *fcounter, *fmax) = \ ( @{$fstack[0]} ); - - my $NOOP = HTML::Template::NOOP->new(); - my $ESCAPE = HTML::Template::ESCAPE->new(); - my $URLESCAPE = HTML::Template::URLESCAPE->new(); - - # all the tags that need NAMEs: - my %need_names = map { $_ => 1 } - qw(TMPL_VAR TMPL_LOOP TMPL_IF TMPL_UNLESS TMPL_INCLUDE); - - # variables used below that don't need to be my'd in the loop - my ($name, $which, $escape); - - # handle the old vanguard format - $options->{vanguard_compatibility_mode} and - $self->{template} =~ s/%([-\w\/\.+]+)%//g; - - # now split up template on '<', leaving them in - my @chunks = split(m/(?=<)/, $self->{template}); - - # all done with template - delete $self->{template}; - - # loop through chunks, filling up pstack - my $last_chunk = $#chunks; - CHUNK: for (my $chunk_number = 0; - $chunk_number <= $last_chunk; - $chunk_number++) { - next unless defined $chunks[$chunk_number]; - my $chunk = $chunks[$chunk_number]; - - # a general regex to match any and all TMPL_* tags - if ($chunk =~ /^< - (?:!--\s*)? - ( - \/?[Tt][Mm][Pp][Ll]_ - (?: - (?:[Vv][Aa][Rr]) - | - (?:[Ll][Oo][Oo][Pp]) - | - (?:[Ii][Ff]) - | - (?:[Ee][Ll][Ss][Ee]) - | - (?:[Uu][Nn][Ll][Ee][Ss][Ss]) - | - (?:[Ii][Nn][Cc][Ll][Uu][Dd][Ee]) - ) - ) # $1 => $which - start of the tag - - \s* - - # ESCAPE attribute - (?: - [Ee][Ss][Cc][Aa][Pp][Ee] - \s*=\s* - (?: - ( 0 | (?:"0") | (?:'0') ) # $2 => ESCAPE off - | - ( 1 | (?:"1") | (?:'1') | - (?:[Hh][Tt][Mm][Ll]) | - (?:"[Hh][Tt][Mm][Ll]") | - (?:'[Hh][Tt][Mm][Ll]') | - (?:[Uu][Rr][Ll]) | - (?:"[Uu][Rr][Ll]") | - (?:'[Uu][Rr][Ll]') | - ) # $3 => ESCAPE on - ) - )* # allow multiple ESCAPEs - - \s* - - # NAME attribute - (?: - (?: - [Nn][Aa][Mm][Ee] - \s*=\s* - )? - (?: - "([^">]*)" # $4 => double-quoted NAME value " - | - '([^'>]*)' # $5 => single-quoted NAME value - | - ([^\s=>]*) # $6 => unquoted NAME value - ) - )? - - \s* - - # ESCAPE attribute - (?: - [Ee][Ss][Cc][Aa][Pp][Ee] - \s*=\s* - (?: - ( 0 | (?:"0") | (?:'0') ) # $7 => ESCAPE off - | - ( 1 | (?:"1") | (?:'1') | - (?:[Hh][Tt][Mm][Ll]) | - (?:"[Hh][Tt][Mm][Ll]") | - (?:'[Hh][Tt][Mm][Ll]') | - (?:[Uu][Rr][Ll]) | - (?:"[Uu][Rr][Ll]") | - (?:'[Uu][Rr][Ll]') | - ) # $8 => ESCAPE on - ) - )* # allow multiple ESCAPEs - - \s* - - (?:--)?> - (.*) # $9 => $post - text that comes after the tag - $/sx) { - - $which = uc($1); # which tag is it - - $escape = $3 || $8; - $escape = 0 if $2 || $7; # ESCAPE=0 - $escape = 0 unless defined($escape); - - # what name for the tag? undef for a /tag at most, one of the - # following three will be defined - undef $name; - $name = $4 if defined($4); - $name = $5 if defined($5); - $name = $6 if defined($6); - - # allow mixed case in filenames, otherwise flatten - $name = lc($name) unless ($which eq 'TMPL_INCLUDE' or $options->{case_sensitive}); - - my $post = $9; # what comes after on the line - - # die if we need a name and didn't get one - die "HTML::Template->new() : No NAME given to a $which tag at $fname : line $fcounter." if (!defined($name) and $need_names{$which}); - - # die if we got an escape but can't use one - die "HTML::Template->new() : ESCAPE option invalid in a $which tag at $fname : line $fcounter." if ( $escape and ($which ne 'TMPL_VAR')); - - # take actions depending on which tag found - if ($which eq 'TMPL_VAR') { - $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : parsed VAR $name\n"; - - # if we already have this var, then simply link to the existing - # HTML::Template::VAR, else create a new one. - my $var; - if (exists $pmap{$name}) { - $var = $pmap{$name}; - (ref($var) eq 'HTML::Template::VAR') or - die "HTML::Template->new() : Already used param name $name as a TMPL_LOOP, found in a TMPL_VAR at $fname : line $fcounter."; - } else { - $var = HTML::Template::VAR->new(); - $pmap{$name} = $var; - $top_pmap{$name} = HTML::Template::VAR->new() - if $options->{global_vars} and not exists $top_pmap{$name}; - } - - # if ESCAPE was set, push an ESCAPE op on the stack before - # the variable. output will handle the actual work. - if ($escape) { - if ($escape =~ /^"?[Uu][Rr][Ll]"?$/) { - push(@pstack, $URLESCAPE); - } else { - push(@pstack, $ESCAPE); - } - } - - push(@pstack, $var); - - } elsif ($which eq 'TMPL_LOOP') { - # we've got a loop start - $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP $name start\n"; - - # if we already have this loop, then simply link to the existing - # HTML::Template::LOOP, else create a new one. - my $loop; - if (exists $pmap{$name}) { - $loop = $pmap{$name}; - (ref($loop) eq 'HTML::Template::LOOP') or - die "HTML::Template->new() : Already used param name $name as a TMPL_VAR, TMPL_IF or TMPL_UNLESS, found in a TMP_LOOP at $fname : line $fcounter!"; - - } else { - # store the results in a LOOP object - actually just a - # thin wrapper around another HTML::Template object. - $loop = HTML::Template::LOOP->new(); - $pmap{$name} = $loop; - } - - # get it on the loopstack, pstack of the enclosing block - push(@pstack, $loop); - push(@loopstack, [$loop, $#pstack]); - - # magic time - push on a fresh pmap and pstack, adjust the typeglobs. - # this gives the loop a separate namespace (i.e. pmap and pstack). - push(@pstacks, []); - *pstack = $pstacks[$#pstacks]; - push(@pmaps, {}); - *pmap = $pmaps[$#pmaps]; - push(@ifstacks, []); - *ifstack = $ifstacks[$#ifstacks]; - push(@ucstacks, []); - *ucstack = $ucstacks[$#ucstacks]; - - # auto-vivify __FIRST__, __LAST__ and __INNER__ if - # loop_context_vars is set. Otherwise, with - # die_on_bad_params set output() will might cause errors - # when it tries to set them. - if ($options->{loop_context_vars}) { - $pmap{__first__} = HTML::Template::VAR->new(); - $pmap{__inner__} = HTML::Template::VAR->new(); - $pmap{__last__} = HTML::Template::VAR->new(); - $pmap{__odd__} = HTML::Template::VAR->new(); - } - - } elsif ($which eq '/TMPL_LOOP') { - $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP end\n"; - - my $loopdata = pop(@loopstack); - die "HTML::Template->new() : found with no matching at $fname : line $fcounter!" unless defined $loopdata; - - my ($loop, $starts_at) = @$loopdata; - - # resolve pending conditionals - foreach my $uc (@ucstack) { - my $var = $uc->[HTML::Template::COND::VARIABLE]; - if (exists($pmap{$var})) { - $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; - } else { - $pmap{$var} = HTML::Template::VAR->new(); - $top_pmap{$var} = HTML::Template::VAR->new() - if $options->{global_vars} and not exists $top_pmap{$var}; - $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; - } - if (ref($pmap{$var}) eq 'HTML::Template::VAR') { - $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; - } else { - $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; - } - } - - # get pmap and pstack for the loop, adjust the typeglobs to - # the enclosing block. - my $param_map = pop(@pmaps); - *pmap = $pmaps[$#pmaps]; - my $parse_stack = pop(@pstacks); - *pstack = $pstacks[$#pstacks]; - - scalar(@ifstack) and die "HTML::Template->new() : Dangling or in loop ending at $fname : line $fcounter."; - pop(@ifstacks); - *ifstack = $ifstacks[$#ifstacks]; - pop(@ucstacks); - *ucstack = $ucstacks[$#ucstacks]; - - # instantiate the sub-Template, feeding it parse_stack and - # param_map. This means that only the enclosing template - # does _parse() - sub-templates get their parse_stack and - # param_map fed to them already filled in. - $loop->[HTML::Template::LOOP::TEMPLATE_HASH]{$starts_at} - = HTML::Template->_new_from_loop( - parse_stack => $parse_stack, - param_map => $param_map, - debug => $options->{debug}, - die_on_bad_params => $options->{die_on_bad_params}, - loop_context_vars => $options->{loop_context_vars}, - case_sensitive => $options->{case_sensitive}, - ); - - } elsif ($which eq 'TMPL_IF' or $which eq 'TMPL_UNLESS' ) { - $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which $name start\n"; - - # if we already have this var, then simply link to the existing - # HTML::Template::VAR/LOOP, else defer the mapping - my $var; - if (exists $pmap{$name}) { - $var = $pmap{$name}; - } else { - $var = $name; - } - - # connect the var to a conditional - my $cond = HTML::Template::COND->new($var); - if ($which eq 'TMPL_IF') { - $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_IF; - $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 0; - } else { - $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_UNLESS; - $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 1; - } - - # push unconnected conditionals onto the ucstack for - # resolution later. Otherwise, save type information now. - if ($var eq $name) { - push(@ucstack, $cond); - } else { - if (ref($var) eq 'HTML::Template::VAR') { - $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; - } else { - $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; - } - } - - # push what we've got onto the stacks - push(@pstack, $cond); - push(@ifstack, $cond); - - } elsif ($which eq '/TMPL_IF' or $which eq '/TMPL_UNLESS') { - $options->{debug} and print STDERR "### HTML::Template Debug ###$fname : line $fcounter : $which end\n"; - - my $cond = pop(@ifstack); - die "HTML::Template->new() : found with no matching at $fname : line $fcounter." unless defined $cond; - if ($which eq '/TMPL_IF') { - die "HTML::Template->new() : found incorrectly terminating a (use ) at $fname : line $fcounter.\n" - if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_UNLESS); - } else { - die "HTML::Template->new() : found incorrectly terminating a (use ) at $fname : line $fcounter.\n" - if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_IF); - } - - # connect the matching to this "address" - place a NOOP to - # hold the spot. This allows output() to treat an IF in the - # assembler-esque "Conditional Jump" mode. - push(@pstack, $NOOP); - $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack; - - } elsif ($which eq 'TMPL_ELSE') { - $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : ELSE\n"; - - my $cond = pop(@ifstack); - die "HTML::Template->new() : found with no matching or at $fname : line $fcounter." unless defined $cond; - - - my $else = HTML::Template::COND->new($cond->[HTML::Template::COND::VARIABLE]); - $else->[HTML::Template::COND::WHICH] = $cond->[HTML::Template::COND::WHICH]; - $else->[HTML::Template::COND::JUMP_IF_TRUE] = not $cond->[HTML::Template::COND::JUMP_IF_TRUE]; - - # need end-block resolution? - if (defined($cond->[HTML::Template::COND::VARIABLE_TYPE])) { - $else->[HTML::Template::COND::VARIABLE_TYPE] = $cond->[HTML::Template::COND::VARIABLE_TYPE]; - } else { - push(@ucstack, $else); - } - - push(@pstack, $else); - push(@ifstack, $else); - - # connect the matching to this "address" - thus the if, - # failing jumps to the ELSE address. The else then gets - # elaborated, and of course succeeds. On the other hand, if - # the IF fails and falls though, output will reach the else - # and jump to the /if address. - $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack; - - } elsif ($which eq 'TMPL_INCLUDE') { - # handle TMPL_INCLUDEs - $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : INCLUDE $name \n"; - - # no includes here, bub - $options->{no_includes} and croak("HTML::Template : Illegal attempt to use TMPL_INCLUDE in template file : (no_includes => 1)"); - - my $filename = $name; - - # look for the included file... - my @path = split('/', $options->{filepath}); - my $filepath; - if ($options->{search_path_on_include} or not @path) { - $filepath = $self->_find_file($filename); - } else { - $filepath = $self->_find_file($filename, \@path); - } - die "HTML::Template->new() : Cannot open included file $filename : file not found." - unless defined($filepath); - die "HTML::Template->new() : Cannot open included file $filename : $!" - unless defined(open(TEMPLATE, $filepath)); - - # read into the array - my $included_template = ""; - while(read(TEMPLATE, $included_template, 10240, length($included_template))) {} - close(TEMPLATE); - - # call filters if necessary - $self->_call_filters(\$included_template) if @{$options->{filter}}; - - if ($included_template) { # not empty - # handle the old vanguard format - this needs to happen here - # since we're not about to do a next CHUNKS. - $options->{vanguard_compatibility_mode} and - $included_template =~ s/%([-\w\/\.+]+)%//g; - - # collect mtimes for included files - if ($options->{cache} and !$options->{blind_cache}) { - $self->{included_mtimes}{$filepath} = (stat($filepath))[9]; - } - - # adjust the fstack to point to the included file info - push(@fstack, [$filepath, 1, - scalar @{[$included_template =~ m/(\n)/g]} + 1]); - (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} ); - - # make sure we aren't infinitely recursing - die "HTML::Template->new() : likely recursive includes - parsed $options->{max_includes} files deep and giving up (set max_includes higher to allow deeper recursion)." if ($options->{max_includes} and (scalar(@fstack) > $options->{max_includes})); - - # stick the remains of this chunk onto the bottom of the - # included text. - $included_template .= $post; - $post = undef; - - # move the new chunks into place. - splice(@chunks, $chunk_number, 1, - split(m/(?=<)/, $included_template)); - - # recalculate stopping point - $last_chunk = $#chunks; - - # start in on the first line of the included text - nothing - # else to do on this line. - $chunk = $chunks[$chunk_number]; - - redo CHUNK; - } - } else { - # zuh!? - die "HTML::Template->new() : Unknown or unmatched TMPL construct at $fname : line $fcounter."; - } - # push the rest after the tag - if (defined($post)) { - if (ref($pstack[$#pstack]) eq 'SCALAR') { - ${$pstack[$#pstack]} .= $post; - } else { - push(@pstack, \$post); - } - } - } else { # just your ordinary markup - # make sure we didn't reject something TMPL_* but badly formed - if ($options->{strict}) { - die "HTML::Template->new() : Syntax error in tag at $fname : $fcounter." if ($chunk =~ /<(?:!--\s*)?\/?[Tt][Mm][Pp][Ll]_/); - } - - # push the rest and get next chunk - if (defined($chunk)) { - if (ref($pstack[$#pstack]) eq 'SCALAR') { - ${$pstack[$#pstack]} .= $chunk; - } else { - push(@pstack, \$chunk); - } - } - } - # count newlines in chunk and advance line count - $fcounter += scalar(@{[$chunk =~ m/(\n)/g]}); - # if we just crossed the end of an included file - # pop off the record and re-alias to the enclosing file's info - pop(@fstack), (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} ) - if ($fcounter > $fmax); - - } # next CHUNK - - # make sure we don't have dangling IF or LOOP blocks - scalar(@ifstack) and die "HTML::Template->new() : At least one or not terminated at end of file!"; - scalar(@loopstack) and die "HTML::Template->new() : At least one not terminated at end of file!"; - - # resolve pending conditionals - foreach my $uc (@ucstack) { - my $var = $uc->[HTML::Template::COND::VARIABLE]; - if (exists($pmap{$var})) { - $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; - } else { - $pmap{$var} = HTML::Template::VAR->new(); - $top_pmap{$var} = HTML::Template::VAR->new() - if $options->{global_vars} and not exists $top_pmap{$var}; - $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; - } - if (ref($pmap{$var}) eq 'HTML::Template::VAR') { - $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; - } else { - $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; - } - } - - # want a stack dump? - if ($options->{stack_debug}) { - require 'Data/Dumper.pm'; - print STDERR "### HTML::Template _param Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n"; - } - - # get rid of filters - they cause runtime errors if Storable tries - # to store them. This can happen under global_vars. - delete $options->{filter}; -} - -# a recursive sub that associates each loop with the loops above -# (treating the top-level as a loop) -sub _globalize_vars { - my $self = shift; - - # associate with the loop (and top-level templates) above in the tree. - push(@{$self->{options}{associate}}, @_); - - # recurse down into the template tree, adding ourself to the end of - # list. - push(@_, $self); - map { $_->_globalize_vars(@_) } - map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}} - grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}}; -} - -# method used to recursively un-hook associate -sub _unglobalize_vars { - my $self = shift; - - # disassociate - $self->{options}{associate} = undef; - - # recurse down into the template tree disassociating - map { $_->_unglobalize_vars() } - map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}} - grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}}; -} - -=head2 param - -param() can be called in a number of ways - -1) To return a list of parameters in the template : - - my @parameter_names = $self->param(); - - -2) To return the value set to a param : - - my $value = $self->param('PARAM'); - -3) To set the value of a parameter : - - # For simple TMPL_VARs: - $self->param(PARAM => 'value'); - - # with a subroutine reference that gets called to get the value - # of the scalar. The sub will recieve the template object as a - # parameter. - $self->param(PARAM => sub { return 'value' }); - - # And TMPL_LOOPs: - $self->param(LOOP_PARAM => - [ - { PARAM => VALUE_FOR_FIRST_PASS, ... }, - { PARAM => VALUE_FOR_SECOND_PASS, ... } - ... - ] - ); - -4) To set the value of a a number of parameters : - - # For simple TMPL_VARs: - $self->param(PARAM => 'value', - PARAM2 => 'value' - ); - - # And with some TMPL_LOOPs: - $self->param(PARAM => 'value', - PARAM2 => 'value', - LOOP_PARAM => - [ - { PARAM => VALUE_FOR_FIRST_PASS, ... }, - { PARAM => VALUE_FOR_SECOND_PASS, ... } - ... - ], - ANOTHER_LOOP_PARAM => - [ - { PARAM => VALUE_FOR_FIRST_PASS, ... }, - { PARAM => VALUE_FOR_SECOND_PASS, ... } - ... - ] - ); - -5) To set the value of a a number of parameters using a hash-ref : - - $self->param( - { - PARAM => 'value', - PARAM2 => 'value', - LOOP_PARAM => - [ - { PARAM => VALUE_FOR_FIRST_PASS, ... }, - { PARAM => VALUE_FOR_SECOND_PASS, ... } - ... - ], - ANOTHER_LOOP_PARAM => - [ - { PARAM => VALUE_FOR_FIRST_PASS, ... }, - { PARAM => VALUE_FOR_SECOND_PASS, ... } - ... - ] - } - ); - -=cut - - -sub param { - my $self = shift; - my $options = $self->{options}; - my $param_map = $self->{param_map}; - - # the no-parameter case - return list of parameters in the template. - return keys(%$param_map) unless scalar(@_); - - my $first = shift; - my $type = ref $first; - - # the one-parameter case - could be a parameter value request or a - # hash-ref. - if (!scalar(@_) and !length($type)) { - my $param = $options->{case_sensitive} ? $first : lc $first; - - # check for parameter existence - $options->{die_on_bad_params} and !exists($param_map->{$param}) and - croak("HTML::Template : Attempt to get nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params set => 1)"); - - return undef unless (exists($param_map->{$param}) and - defined($param_map->{$param})); - - return ${$param_map->{$param}} if - (ref($param_map->{$param}) eq 'HTML::Template::VAR'); - return $param_map->{$param}[HTML::Template::LOOP::PARAM_SET]; - } - - if (!scalar(@_)) { - croak("HTML::Template->param() : Single reference arg to param() must be a hash-ref! You gave me a $type.") - unless $type eq 'HASH' or - (ref($first) and UNIVERSAL::isa($first, 'HASH')); - push(@_, %$first); - } else { - unshift(@_, $first); - } - - croak("HTML::Template->param() : You gave me an odd number of parameters to param()!") - unless ((@_ % 2) == 0); - - # strangely, changing this to a "while(@_) { shift, shift }" type - # loop causes perl 5.004_04 to die with some nonsense about a - # read-only value. - for (my $x = 0; $x <= $#_; $x += 2) { - my $param = $options->{case_sensitive} ? $_[$x] : lc $_[$x]; - my $value = $_[($x + 1)]; - - # check that this param exists in the template - $options->{die_on_bad_params} and !exists($param_map->{$param}) and - croak("HTML::Template : Attempt to set nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params => 1)"); - - # if we're not going to die from bad param names, we need to ignore - # them... - next unless (exists($param_map->{$param})); - - # figure out what we've got, taking special care to allow for - # objects that are compatible underneath. - my $value_type = ref($value); - if (defined($value_type) and length($value_type) and ($value_type eq 'ARRAY' or ((ref($value) !~ /^(CODE)|(HASH)|(SCALAR)$/) and $value->isa('ARRAY')))) { - (ref($param_map->{$param}) eq 'HTML::Template::LOOP') or - croak("HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!"); - $param_map->{$param}[HTML::Template::LOOP::PARAM_SET] = [@{$value}]; - } else { - (ref($param_map->{$param}) eq 'HTML::Template::VAR') or - croak("HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!"); - ${$param_map->{$param}} = $value; - } - } -} - -=pod - -=head2 clear_params() - -Sets all the parameters to undef. Useful internally, if nowhere else! - -=cut - -sub clear_params { - my $self = shift; - my $type; - foreach my $name (keys %{$self->{param_map}}) { - $type = ref($self->{param_map}{$name}); - undef(${$self->{param_map}{$name}}) - if ($type eq 'HTML::Template::VAR'); - undef($self->{param_map}{$name}[HTML::Template::LOOP::PARAM_SET]) - if ($type eq 'HTML::Template::LOOP'); - } -} - - -# obsolete implementation of associate -sub associateCGI { - my $self = shift; - my $cgi = shift; - (ref($cgi) eq 'CGI') or - croak("Warning! non-CGI object was passed to HTML::Template::associateCGI()!\n"); - push(@{$self->{options}{associate}}, $cgi); - return 1; -} - - -=head2 output() - -output() returns the final result of the template. In most situations -you'll want to print this, like: - - print $template->output(); - -When output is called each occurrence of is -replaced with the value assigned to "name" via param(). If a named -parameter is unset it is simply replaced with ''. are -evaluated once per parameter set, accumlating output on each pass. - -Calling output() is guaranteed not to change the state of the -Template object, in case you were wondering. This property is mostly -important for the internal implementation of loops. - -You may optionally supply a filehandle to print to automatically as -the template is generated. This may improve performance and lower -memory consumption. Example: - - $template->output(print_to => *STDOUT); - -The return value is undefined when using the "print_to" option. - -=cut - -use vars qw(%URLESCAPE_MAP); -sub output { - my $self = shift; - my $options = $self->{options}; - - croak("HTML::Template->output() : You gave me an odd number of parameters to output()!") - unless ((@_ % 2) == 0); - my %args = @_; - - print STDERR "### HTML::Template Memory Debug ### START OUTPUT ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - $options->{debug} and print STDERR "### HTML::Template Debug ### In output\n"; - - # want a stack dump? - if ($options->{stack_debug}) { - require 'Data/Dumper.pm'; - print STDERR "### HTML::Template output Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n"; - } - - # globalize vars - this happens here to localize the circular - # references created by global_vars. - $self->_globalize_vars() if ($options->{global_vars}); - - # support the associate magic, searching for undefined params and - # attempting to fill them from the associated objects. - if (scalar(@{$options->{associate}})) { - # prepare case-mapping hashes to do case-insensitive matching - # against associated objects. This allows CGI.pm to be - # case-sensitive and still work with asssociate. - my (%case_map, $lparam); - foreach my $associated_object (@{$options->{associate}}) { - # what a hack! This should really be optimized out for case_sensitive. - if ($options->{case_sensitive}) { - map { - $case_map{$associated_object}{$_} = $_ - } $associated_object->param(); - } else { - map { - $case_map{$associated_object}{lc($_)} = $_ - } $associated_object->param(); - } - } - - foreach my $param (keys %{$self->{param_map}}) { - unless (defined($self->param($param))) { - OBJ: foreach my $associated_object (@{$options->{associate}}) { - $self->param($param, scalar $associated_object->param($case_map{$associated_object}{$param})), last OBJ - if (exists($case_map{$associated_object}{$param})); - } - } - } - } - - use vars qw($line @parse_stack); local(*line, *parse_stack); - - # walk the parse stack, accumulating output in $result - *parse_stack = $self->{parse_stack}; - my $result = ''; - - tie $result, 'HTML::Template::PRINTSCALAR', $args{print_to} - if (defined $args{print_to}); - - my $type; - my $parse_stack_length = $#parse_stack; - for (my $x = 0; $x <= $parse_stack_length; $x++) { - *line = \$parse_stack[$x]; - $type = ref($line); - - if ($type eq 'SCALAR') { - $result .= $$line; - } elsif ($type eq 'HTML::Template::VAR' and ref($$line) eq 'CODE') { - defined($$line) and $result .= $$line->($self); - } elsif ($type eq 'HTML::Template::VAR') { - defined($$line) and $result .= $$line; - } elsif ($type eq 'HTML::Template::LOOP') { - if (defined($line->[HTML::Template::LOOP::PARAM_SET])) { - eval { $result .= $line->output($x, $options->{loop_context_vars}); }; - croak("HTML::Template->output() : fatal error in loop output : $@") - if $@; - } - } elsif ($type eq 'HTML::Template::COND') { - if ($line->[HTML::Template::COND::JUMP_IF_TRUE]) { - if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) { - if (defined ${$line->[HTML::Template::COND::VARIABLE]}) { - if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}->($self); - } else { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}; - } - } - } else { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if - (defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] and - scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]}); - } - } else { - if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) { - if (defined ${$line->[HTML::Template::COND::VARIABLE]}) { - if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}->($self); - } else { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}; - } - } else { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; - } - } else { - $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if - (not defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] or - not scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]}); - } - } - } elsif ($type eq 'HTML::Template::NOOP') { - next; - } elsif ($type eq 'HTML::Template::ESCAPE') { - $x++; - *line = \$parse_stack[$x]; - if (defined($$line)) { - my $toencode = $$line; - - # straight from the CGI.pm bible. - $toencode=~s/&/&/g; - $toencode=~s/\"/"/g; #" - $toencode=~s/>/>/g; - $toencode=~s/hex map if one isn't already available - unless (exists($URLESCAPE_MAP{chr(1)})) { - for (0..255) { $URLESCAPE_MAP{chr($_)} = sprintf('%%%02X', $_); } - } - # do the translation (RFC 2396 ^uric) - $toencode =~ s!([^a-zA-Z0-9_.\-])!$URLESCAPE_MAP{$1}!g; - $result .= $toencode; - } - } else { - confess("HTML::Template::output() : Unknown item in parse_stack : " . $type); - } - } - - # undo the globalization circular refs - $self->_unglobalize_vars() if ($options->{global_vars}); - - print STDERR "### HTML::Template Memory Debug ### END OUTPUT ", $self->{proc_mem}->size(), "\n" - if $options->{memory_debug}; - - return undef if defined $args{print_to}; - return $result; -} - -=pod - -=head2 query() - -This method allow you to get information about the template structure. -It can be called in a number of ways. The simplest usage of query is -simply to check whether a parameter name exists in the template, using -the C option: - - if ($template->query(name => 'foo')) { - # do something if a varaible of any type - # named FOO is in the template - } - -This same usage returns the type of the parameter. The type is the -same as the tag minus the leading 'TMPL_'. So, for example, a -TMPL_VAR parameter returns 'VAR' from query(). - - if ($template->query(name => 'foo') eq 'VAR') { - # do something if FOO exists and is a TMPL_VAR - } - -Note that the variables associated with TMPL_IFs and TMPL_UNLESSs will -be identified as 'VAR' unless they are also used in a TMPL_LOOP, in -which case they will return 'LOOP'. - -C also allows you to get a list of parameters inside a loop -(and inside loops inside loops). Example loop: - - - - - - - - - - -And some query calls: - - # returns 'LOOP' - $type = $template->query(name => 'EXAMPLE_LOOP'); - - # returns ('bop', 'bee', 'example_inner_loop') - @param_names = $template->query(loop => 'EXAMPLE_LOOP'); - - # both return 'VAR' - $type = $template->query(name => ['EXAMPLE_LOOP', 'BEE']); - $type = $template->query(name => ['EXAMPLE_LOOP', 'BOP']); - - # and this one returns 'LOOP' - $type = $template->query(name => ['EXAMPLE_LOOP', - 'EXAMPLE_INNER_LOOP']); - - # and finally, this returns ('inner_bee', 'inner_bop') - @inner_param_names = $template->query(loop => ['EXAMPLE_LOOP', - 'EXAMPLE_INNER_LOOP']); - - # for non existent parameter names you get undef - # this returns undef. - $type = $template->query(name => 'DWEAZLE_ZAPPA'); - - # calling loop on a non-loop parameter name will cause an error. - # this dies: - $type = $template->query(loop => 'DWEAZLE_ZAPPA'); - -As you can see above the C option returns a list of parameter -names and both C and C take array refs in order to refer -to parameters inside loops. It is an error to use C with a -parameter that is not a loop. - -Note that all the names are returned in lowercase and the types are -uppercase. - -Just like C, C with no arguements returns all the -parameter names in the template at the top level. - -=cut - -sub query { - my $self = shift; - $self->{options}{debug} and print STDERR "### HTML::Template Debug ### query(", join(', ', @_), ")\n"; - - # the no-parameter case - return $self->param() - return $self->param() unless scalar(@_); - - croak("HTML::Template::query() : Odd number of parameters passed to query!") - if (scalar(@_) % 2); - croak("HTML::Template::query() : Wrong number of parameters passed to query - should be 2.") - if (scalar(@_) != 2); - - my ($opt, $path) = (lc shift, shift); - croak("HTML::Template::query() : invalid parameter ($opt)") - unless ($opt eq 'name' or $opt eq 'loop'); - - # make path an array unless it already is - $path = [$path] unless (ref $path); - - # find the param in question. - my @objs = $self->_find_param(@$path); - return undef unless scalar(@objs); - my ($obj, $type); - - # do what the user asked with the object - if ($opt eq 'name') { - # we only look at the first one. new() should make sure they're - # all the same. - ($obj, $type) = (shift(@objs), shift(@objs)); - return undef unless defined $obj; - return 'VAR' if $type eq 'HTML::Template::VAR'; - return 'LOOP' if $type eq 'HTML::Template::LOOP'; - croak("HTML::Template::query() : unknown object ($type) in param_map!"); - - } elsif ($opt eq 'loop') { - my %results; - while(@objs) { - ($obj, $type) = (shift(@objs), shift(@objs)); - croak("HTML::Template::query() : Search path [", join(', ', @$path), "] doesn't end in a TMPL_LOOP - it is an error to use the 'loop' option on a non-loop parameter. To avoid this problem you can use the 'name' option to query() to check the type first.") - unless ((defined $obj) and ($type eq 'HTML::Template::LOOP')); - - # SHAZAM! This bit extracts all the parameter names from all the - # loop objects for this name. - map {$results{$_} = 1} map { keys(%{$_->{'param_map'}}) } - values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]}); - } - # this is our loop list, return it. - return keys(%results); - } -} - -# a function that returns the object(s) corresponding to a given path and -# its (their) ref()(s). Used by query() in the obvious way. -sub _find_param { - my $self = shift; - my $spot = $self->{options}{case_sensitive} ? shift : lc shift; - - # get the obj and type for this spot - my $obj = $self->{'param_map'}{$spot}; - return unless defined $obj; - my $type = ref $obj; - - # return if we're here or if we're not but this isn't a loop - return ($obj, $type) unless @_; - return unless ($type eq 'HTML::Template::LOOP'); - - # recurse. this is a depth first seach on the template tree, for - # the algorithm geeks in the audience. - return map { $_->_find_param(@_) } - values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]}); -} - -# HTML::Template::VAR, LOOP, etc are *light* objects - their internal -# spec is used above. No encapsulation or information hiding is to be -# assumed. - -package HTML::Template::VAR; - -sub new { - my ($pkg) = @_; - my $value; - my $self = \$value; - bless($self, $pkg); - return $self; -} - -package HTML::Template::LOOP; - -sub new { - my ($pkg) = shift; - my $self = []; - bless($self, $pkg); - return $self; -} - -sub output { - my $self = shift; - my $index = shift; - my $loop_context_vars = shift; - my $template = $self->[TEMPLATE_HASH]{$index}; - my $value_sets_array = $self->[PARAM_SET]; - return unless defined($value_sets_array); - - my $result = ''; - my $count = 0; - my $odd = 0; - foreach my $value_set (@$value_sets_array) { - if ($loop_context_vars) { - if ($count == 0) { - @{$value_set}{qw(__first__ __inner__ __last__)} = (1,0,$#{$value_sets_array} == 0); - } elsif ($count == $#{$value_sets_array}) { - @{$value_set}{qw(__first__ __inner__ __last__)} = (0,0,1); - } else { - @{$value_set}{qw(__first__ __inner__ __last__)} = (0,1,0); - } - $odd = $value_set->{__odd__} = not $odd; - } - $template->param($value_set); - $result .= $template->output; - $template->clear_params; - @{$value_set}{qw(__first__ __last__ __inner__ __odd__)} = (0,0,0,0) - if ($loop_context_vars); - $count++; - } - - return $result; -} - -package HTML::Template::COND; - -sub new { - my $pkg = shift; - my $var = shift; - my $self = []; - $self->[VARIABLE] = $var; - - bless($self, $pkg); - return $self; -} - -package HTML::Template::NOOP; -sub new { - my $unused; - my $self = \$unused; - bless($self, $_[0]); - return $self; -} - -package HTML::Template::ESCAPE; -sub new { - my $unused; - my $self = \$unused; - bless($self, $_[0]); - return $self; -} - -package HTML::Template::URLESCAPE; -sub new { - my $unused; - my $self = \$unused; - bless($self, $_[0]); - return $self; -} - -# scalar-tying package for output(print_to => *HANDLE) implementation -package HTML::Template::PRINTSCALAR; -use strict; - -sub TIESCALAR { bless \$_[1], $_[0]; } -sub FETCH { } -sub STORE { - my $self = shift; - local *FH = $$self; - print FH @_; -} -1; -__END__ - -=head1 FREQUENTLY ASKED QUESTIONS - -In the interest of greater understanding I've started a FAQ section of -the perldocs. Please look in here before you send me email. - -1) Is there a place to go to discuss HTML::Template and/or get help? - -There's a mailing-list for HTML::Template at htmltmpl @ lists.vm.com. -Send a blank message to htmltmpl-subscribe @ lists.vm.com to join! - -2) I want support for ! How about it? - -Maybe. I definitely encourage people to discuss their ideas for -HTML::Template on the mailing list. Please be ready to explain to me -how the new tag fits in with HTML::Template's mission to provide a -fast, lightweight system for using HTML templates. - -NOTE: Offering to program said addition and provide it in the form of -a patch to the most recent version of HTML::Template will definitely -have a softening effect on potential opponents! - -3) I found a bug, can you fix it? - -That depends. Did you send me the VERSION of HTML::Template, a test -script and a test template? If so, then almost certainly. - -If you're feeling really adventurous, HTML::Template has a publically -available CVS server. See below for more information in the PUBLIC -CVS SERVER section. - -4) s from the main template aren't working inside a ! Why? - -This is the intended behavior. introduces a separate -scope for s much like a subroutine call in Perl introduces a -separate scope for "my" variables. - -If you want your s to be global you can set the -'global_vars' option when you call new(). See above for documentation -of the 'global_vars' new() option. - -5) Why do you use /[Tt]/ instead of /t/i? It's so ugly! - -Simple - the case-insensitive match switch is very inefficient. -According to _Mastering_Regular_Expressions_ from O'Reilly Press, -/[Tt]/ is faster and more space efficient than /t/i - by as much as -double against long strings. //i essentially does a lc() on the -string and keeps a temporary copy in memory. - -When this changes, and it is in the 5.6 development series, I will -gladly use //i. Believe me, I realize [Tt] is hideously ugly. - -6) How can I pre-load my templates using cache-mode and mod_perl? - -Add something like this to your startup.pl: - - use HTML::Template; - use File::Find; - - print STDERR "Pre-loading HTML Templates...\n"; - find( - sub { - return unless /\.tmpl$/; - HTML::Template->new( - filename => "$File::Find::dir/$_", - cache => 1, - ); - }, - '/path/to/templates', - '/another/path/to/templates/' - ); - -Note that you'll need to modify the "return unless" line to specify -the extension you use for your template files - I use .tmpl, as you -can see. You'll also need to specify the path to your template files. - -One potential problem: the "/path/to/templates/" must be EXACTLY the -same path you use when you call HTML::Template->new(). Otherwise the -cache won't know they're the same file and will load a new copy - -instead getting a speed increase, you'll double your memory usage. To -find out if this is happening set cache_debug => 1 in your application -code and look for "CACHE MISS" messages in the logs. - -7) What characters are allowed in TMPL_* NAMEs? - -Numbers, letters, '.', '/', '+', '-' and '_'. - -8) How can I execute a program from inside my template? - -Short answer: you can't. Longer answer: you shouldn't since this -violates the fundamental concept behind HTML::Template - that design -and code should be seperate. - -But, inevitably some people still want to do it. At times it has even -seemed that HTML::Template development might split over this issue, so -I will attempt a compromise. Here is a method you can use to allow -your template authors to evaluate arbitrary perl scripts from within -the template. - -First, tell all your designers that when they want to run a perl -script named "program.pl" they should use a tag like: - - - -Then, have all your programmers call this subroutine instead of -calling HTML::Template::new directly. They still use the same -parameters, but they also get the program execution. - - sub new_template { - # get the template object - my $template = HTML::Template->new(@_); - - # find program parameters and fill them in - my @params = $template->param(); - for my $param (@params) { - if ($param =~ /^__execute_(.*)__$/) { - $template->param($param, do($1)); - } - } - - # return the template object - return $template; - } - -The programs called in this way should return a string containing -their output. A more complicated subroutine could be written to -capture STDOUT from the scripts, but this one is simple enough to -include in the FAQ. Another improvement would be to use query() to -enable program execution inside loops. - -9) Can I get a copy of these docs in Japanese? - -Yes you can. See Kawai Takanori's translation at: - - http://member.nifty.ne.jp/hippo2000/perltips/html/template.htm - - -=head1 BUGS - -I am aware of no bugs - if you find one, join the mailing list and -tell us about it (htmltmpl @ lists.vm.com). You can join the -HTML::Template mailing-list by sending a blank email to -htmltmpl-subscribe @ lists.vm.com. Of course, you can still email me -directly (sam @ tregar.com) with bugs, but I reserve the right to -forward bug reports to the mailing list. - -When submitting bug reports, be sure to include full details, -including the VERSION of the module, a test script and a test template -demonstrating the problem! - -If you're feeling really adventurous, HTML::Template has a publically -available CVS server. See below for more information in the PUBLIC -CVS SERVER section. - -=head1 CREDITS - -This module was the brain child of my boss, Jesse Erlbaum -(jesse @ vm.com) here at Vanguard Media. The most original idea in this -module - the - was entirely his. - -Fixes, Bug Reports, Optimizations and Ideas have been generously -provided by: - - Richard Chen - Mike Blazer - Adriano Nagelschmidt Rodrigues - Andrej Mikus - Ilya Obshadko - Kevin Puetz - Steve Reppucci - Richard Dice - Tom Hukins - Eric Zylberstejn - David Glasser - Peter Marelas - James William Carlson - Frank D. Cringle - Winfried Koenig - Matthew Wickline - Doug Steinwand - Drew Taylor - Tobias Brox - Michael Lloyd - Simran Gambhir - Chris Houser - Larry Moore - Todd Larason - Jody Biggs - T.J. Mather - Martin Schroth - Dave Wolfe - uchum - Kawai Takanori - Peter Guelich - Chris Nokleberg - Ralph Corderoy - William Ward - Ade Olonoh - Mark Stosberg - Lance Thomas - Roland Giersig - Jere Julian - Peter Leonard - -Thanks! - -=head1 PUBLIC CVS SERVER - -HTML::Template now has a publicly accessible CVS server provided by -SourceForge (www.sourceforge.net). You can access it by going to -http://sourceforge.net/cvs/?group_id=1075. Give it a try! - -=head1 AUTHOR - -Sam Tregar, sam @ tregar.com (you can also find me on the mailing list -at htmltmpl @ lists.vm.com - join it by sending a blank message to -htmltmpl-subscribe @ lists.vm.com). - -=head1 LICENSE - -HTML::Template : A module for using HTML Templates with Perl -Copyright (C) 2000 Sam Tregar (sam @ tregar.com) - -This module is free software; you can redistribute it and/or modify it -under the terms of either: - -a) the GNU General Public License as published by the Free Software -Foundation; either version 1, or (at your option) any later version, -or - -b) the "Artistic License" which comes with this module. - -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. See either -the GNU General Public License or the Artistic License for more details. - -You should have received a copy of the Artistic License with this -module, in the file ARTISTIC. If not, I'll be glad to provide one. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:57 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:57 +0900 Subject: [Affelio-cvs 704] CVS update: affelio_farm/admin/skelton/affelio/templates/default/owner_side Message-ID: <20051024192057.A33F82AC03C@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_access_log.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_access_log.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_access_log.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_access_log.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_access_log.tmpl Tue Oct 25 04:20:57 2005 @@ -1,66 +0,0 @@ - - - - -

- - -
-
???????ゃ??障????
- - - - - - -
- - Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_delete_confirm.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_delete_confirm.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_delete_confirm.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_delete_confirm.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_delete_confirm.tmpl Tue Oct 25 04:20:46 2005 @@ -1,21 +0,0 @@ - -
- -
- - -
-
-
- -
-
- -
-
- - - -
- -
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_edit.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_edit.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_edit.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_edit.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/edit_diary_edit.tmpl Tue Oct 25 04:20:46 2005 @@ -1,56 +0,0 @@ -
- - -
- - -
-
- -
- -
- -
- () -
- -
- - - - - - - - - -
: " size="32">

<a> <b> <big> <blockquote> <em> <i> <p> <strong> <small> <u>
1
2
- -
- -
- -

- - - -
- -
- () -
- -
- - -
-
- - - -
- -
- -
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/error.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/error.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/error.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/error.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/error.tmpl Tue Oct 25 04:20:46 2005 @@ -1,9 +0,0 @@ -
- - -
-
- -
-

-
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog.tmpl Tue Oct 25 04:20:46 2005 @@ -1,74 +0,0 @@ - -
- - -
-
-Recent Entries
- -
-
-
- - - - -
-
-
-Set RDF URL
-
- -
-
- -
-
-
-Remove RDF
- -
-
-
- -
- - -

- -

- -

















- -
- -
- - - -
- -
- - -
- -
- -
-
- - -
-
- -
-
-

- - - -
-
- -
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog_conf.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog_conf.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog_conf.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog_conf.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/external_blog_conf.tmpl Tue Oct 25 04:20:46 2005 @@ -1,15 +0,0 @@ -
-
- -
Import Blog -
-
-
- -
- -RDF URL: - - -
-
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/footer.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/footer.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/footer.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/footer.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/footer.tmpl Tue Oct 25 04:20:46 2005 @@ -1,5 +0,0 @@ -
- - - - Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/list_diary.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/list_diary.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/list_diary.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/list_diary.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/list_diary.tmpl Tue Oct 25 04:20:46 2005 @@ -1,38 +0,0 @@ -
- -
-
-
-
- -
- - -
-
- -
-
/
-
-
-

-
-
- -">鐚?TMPL_VAR NAME="COMMENT_NO">鐚?/a>鐔?-">() - -鐔?a href="edit_diary.cgi?id="> - - -
-
-
- - -
-

-
-
- -
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/menu.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/menu.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/menu.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/menu.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/menu.tmpl Tue Oct 25 04:20:46 2005 @@ -1,94 +0,0 @@ - - -
- - - - -

- - -

-
Entry Archives
- -&month="> -/ - -
-
-
-
- - - - -
-
Recent Entries
- -"> - - -
-
-
-
-
- - -
-
Recent Comments
- -/ - - -
-
-
-
-
- - - -
-
Recent Trackbacks
- - - - -()
-
-
-
-
- - - -
-
Import BLOG
- -blog - - - -
-
-
- - - -" target="_blank"> - - -
-
- - - - - -

















- -
- -
- Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/owner.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/owner.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/owner.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/owner.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/owner.tmpl Tue Oct 25 04:20:46 2005 @@ -1,64 +0,0 @@ -
- -
Diary(Owner mode) -
-
- -
- - -
-
- -
-
-

- /> - -
- disabled> - -
URL: readonly> - -
() -
-

- -
-
-
- - - - -
-
- - - -
-
-
- -
-
-
- - - - - - - -
Title
Content

<a> <b> <big> <blockquote> <em> <i> <p> <strong> <small> <u>
-
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/rss.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/rss.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/rss.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/rss.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/rss.tmpl Tue Oct 25 04:20:46 2005 @@ -1,37 +0,0 @@ - - - -"> -<TMPL_VAR NAME="NICKNAME"> Affelio Diary - - Affelio Diary -ja-jp - - - - " /> - - - - - - -"> -<TMPL_VAR NAME="TITLE"> - - -]]> - - - - - - - - Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/show_diary.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/show_diary.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/show_diary.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/show_diary.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/show_diary.tmpl Tue Oct 25 04:20:46 2005 @@ -1,52 +0,0 @@ - - - -
- -
-/ : -
-
- -
-
-
-

-
-
-
- - - -
- -
-
- -
- - - -

- -() -

-
- -
-
-
- - - -
-
-
-
Please write your comment
-
- - -
-
-
-
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/show_trackback.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/show_trackback.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/show_trackback.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/show_trackback.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/show_trackback.tmpl Tue Oct 25 04:20:46 2005 @@ -1,38 +0,0 @@ - - -
- -
- - -
Trackbacks
-
-
- -
-
- -
- -
-
- - -
-
- -
-

-Received By:
-
-()
-
-
-Excerpt:
-
-
-
-
-
- -
Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/tpingrdf.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/tpingrdf.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/tpingrdf.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/tpingrdf.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/tpingrdf.tmpl Tue Oct 25 04:20:46 2005 @@ -1,18 +0,0 @@ - - - Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment.tmpl Tue Oct 25 04:20:46 2005 @@ -1,39 +0,0 @@ - - - - -
-
- -
篁ヤ????絎鴻??潟??潟??????-
-
- -
-
- -
-
- -
-
-
-
- - - -
-
- - -
?潟??潟???????
-
- -
-
- - -
-
-
- Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment_confirm.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment_confirm.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment_confirm.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment_confirm.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/write_comment_confirm.tmpl Tue Oct 25 04:20:46 2005 @@ -1,20 +0,0 @@ - -
-
- - -
-
- -
-
-

-
- -: - - - - -
- Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary.tmpl Tue Oct 25 04:20:46 2005 @@ -1,52 +0,0 @@ - - - - - -
-
- -
?ヨ??????
-
-
-
-
- - - - - - -
?帥????
" />
-
- -
-
-
- - - -
- - - - - -
篁ヤ????絎鴻??ヨ???申????障?



- - -
-
-
- - - -
- - - -
?ヨ???申????障????
-
-
- Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_confirm.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_confirm.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_confirm.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_confirm.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_confirm.tmpl Tue Oct 25 04:20:46 2005 @@ -1,27 +0,0 @@ -
-
- -
-
-
-
-
-
- - - - - - - - - - -
Title
Content

1
2
- - -
- - -
- Index: affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_edit.tmpl diff -u affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_edit.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_edit.tmpl:removed --- affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_edit.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/diary/templates/write_diary_edit.tmpl Tue Oct 25 04:20:46 2005 @@ -1,24 +0,0 @@ -
- -
- - -
-
- -
-
-
- - - - - - - -
Title
Contents

<a> <b> <big> <blockquote> <em> <i> <p> <strong> <small> <u>
- -
-
- - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:47 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:47 +0900 Subject: [Affelio-cvs 642] CVS update: affelio_farm/admin/skelton/affelio/apps/sampleapp Message-ID: <20051024192047.41E7A2AC030@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/sampleapp/AF_app.cfg diff -u affelio_farm/admin/skelton/affelio/apps/sampleapp/AF_app.cfg:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/sampleapp/AF_app.cfg:removed --- affelio_farm/admin/skelton/affelio/apps/sampleapp/AF_app.cfg:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/sampleapp/AF_app.cfg Tue Oct 25 04:20:47 2005 @@ -1,12 +0,0 @@ -[this_installation] -title=篆冴??ヨ? - -[application] -app_name=message board -app_version=1.0 -app_desc=?<??祉??吾??若??≪?????若??с? -app_author=Affelio project -guest_index=index.cgi -owner_index= -action_types=write -action_types_desc=?<??祉??御???昭??Index: affelio_farm/admin/skelton/affelio/apps/sampleapp/README diff -u affelio_farm/admin/skelton/affelio/apps/sampleapp/README:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/sampleapp/README:removed --- affelio_farm/admin/skelton/affelio/apps/sampleapp/README:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/sampleapp/README Tue Oct 25 04:20:47 2005 @@ -1,20 +0,0 @@ -This "simple_message_board" application is a simple Affelio application -which allows users to leave instant message and read previous messages. -Reading previous messages and leaving new message is permitted if the -accessing user is allowed to do so, according to the Affelio access -control. - -AFAppConfig.cgi ---------------- - Configuration file. - - -index.cgi ---------- - A CGI program which outputs the main page. - - -writeexec.cgi -------------- - A CGI program which processes new message post from a browser. - Index: affelio_farm/admin/skelton/affelio/apps/sampleapp/index.cgi diff -u affelio_farm/admin/skelton/affelio/apps/sampleapp/index.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/sampleapp/index.cgi:removed --- affelio_farm/admin/skelton/affelio/apps/sampleapp/index.cgi:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/sampleapp/index.cgi Tue Oct 25 04:20:47 2005 @@ -1,48 +0,0 @@ -#!/usr/bin/perl - -use strict; -use lib("../../lib"); -use AffelioApp; -use lib("../../extlib"); -use CGI; -use Cwd; - -my $cgi = new CGI(); - -#AffelioApp?????? -my $afap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi); - -#Content-type?????-print "Content-type: text/html;"; -print "Pragma: no-cache", "\n\n"; - -#HTML Header Part?????-my $out_head = $afap->get_HTML_header("Message Board Application"); -print $out_head; - -################################################## -#Application-dependent????吾???- -my $write_access = $afap->check_access("write"); -#Output textarea if "write" access_type is permitted for this user. -if($write_access){ - - #print out textarea - -} - -#Print previous messages if "DF_read" access_type is permitted for this user. -my $read_access = $afap->check_access("DF_read"); -if($read_access){ - - #Show previous message - -} - -################################################## -#HTML Footer Part?????-my $out_foot = $afap->get_HTML_footer(); -print $out_foot; - -#EOF From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:47 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:47 +0900 Subject: [Affelio-cvs 643] CVS update: affelio_farm/admin/skelton/affelio/apps/sampleapp/data Message-ID: <20051024192047.63B112AC043@users.sourceforge.jp> From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:47 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:47 +0900 Subject: [Affelio-cvs 644] CVS update: affelio_farm/admin/skelton/affelio/bin Message-ID: <20051024192047.947A12AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/bin/get_content.cgi diff -u affelio_farm/admin/skelton/affelio/bin/get_content.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/bin/get_content.cgi:removed --- affelio_farm/admin/skelton/affelio/bin/get_content.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/bin/get_content.cgi Tue Oct 25 04:20:47 2005 @@ -1,288 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: get_content.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -$| = 1; - -use lib("../extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Error qw(:try); - -use lib("../lib"); -use Affelio; -use Affelio::App::FriendRoutines qw(get_summed_permission_list); -use Affelio::misc::CGIError; -use Affelio::misc::Debug qw(debug_print); -use Affelio::misc::MyCrypt qw(url_decode msg_decrypt); -use Affelio::misc::Time qw(get_timestamp); -use Affelio::misc::NetMisc qw(get_remote_host); -use Affelio::misc::WebInput; - -debug_print("get_content: start.\n"); - -############################################################################ -#Load Affelio and CGI -############################################################################ -my $q = new CGI; -my $cfg_dir = "../config/"; -my $af = new Affelio(ConfigDir => $cfg_dir); -debug_print("get_content.cgi: AF loaded."); -my $wi = new Affelio::misc::WebInput(); - - -############################################################################ -#Retrieve args -############################################################################ -my $module = $wi->PTN_word($q->param("module")); -if($module eq "" || !defined($module)){ - error($q,"Input parameters are not defined.(module)"); -} - -my $content = $wi->PTN_getcontent_content($q->param("content")); -if($content eq "" || !defined($content)){ - error($q,"Input parameters are not defined.(content)"); -} - - -############################################################################ -#Check session w/ cookie -############################################################################ -my $q = new CGI; -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -my $ck_visitor_type=0; -my $ck_visitor_type_str="pb"; -my $ck_visitor_afid = ""; -my $session; -if($sid ==0 || !defined($sid)){ -}else{ - $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - - if(!$session){ - debug_print("get_content: session not found. [pb]"); - $ck_visitor_type=0; - $ck_visitor_type_str="pb"; - $ck_visitor_afid = $session->param("user_afid"); - }elsif($session->param("type") eq "self"){ - debug_print("get_content: session found. [self]"); - $ck_visitor_type=3; - $ck_visitor_type_str="self"; - $ck_visitor_afid = $session->param("user_afid"); - }elsif($session->param("type") eq "f1"){ - debug_print("get_content: session found. [f1]"); - $ck_visitor_type=2; - $ck_visitor_type_str="f1"; - $ck_visitor_afid = $session->param("user_afid"); - }elsif($session->param("type") eq "f2"){ - debug_print("get_content: session found. [f2]"); - $ck_visitor_type=1; - $ck_visitor_type_str="f2"; - $ck_visitor_afid = $session->param("user_afid"); - } -} -debug_print("get_content: After cookie checking..."); -debug_print("get_content: \t visitor_type =[$ck_visitor_type] [$ck_visitor_type_str]"); -debug_print("get_content: \t visitor_afid =[$ck_visitor_afid]"); - - -############################################################################ -#CFID check -############################################################################ -my $CFID_timestamp; -my $CFID_expire; -my $CFID_remotehost; -my $CFID_visitor_afid; -my $CFID_visitor_type=0; -my $CFID_visitor_type_str="pb"; - -if( ($ck_visitor_type <= 2) - && ( $q->param("referrer") ne "") - && ( $q->param("cfid") ne "" ) - ){ - - my $referrer = $wi->PTN_URL($q->param("referrer")); - debug_print("get_content: referrer = $referrer\n"); #referrer URL - - my $passAB = $af->{fm}->get_attribute_by_afid($referrer, "password"); - if($passAB eq "" || !defined($passAB)){ - error($q,"Parameters are not defined. (1): Your peer does not have shared password with you..."); - } - - my $cfid = msg_decrypt( url_decode($q->param("cfid") ) , $passAB) ; - if($cfid eq "" || !defined($cfid)){ - error($q,"Parameters are not defined. (2): Invalid encryption: After decryption, we could not valid your encrypted message..."); - } - - ####################################################################### - #Check cfid - ($CFID_timestamp, $CFID_expire, $CFID_remotehost, $CFID_visitor_afid, $CFID_visitor_type_str) = split('\*', $cfid); - - #check timestamp - #check expire - #check remotehost - #check visitor_afid - - debug_print("get_content: Information extracted from CFID"); - debug_print("get_content: \ttimestamp =$CFID_timestamp\n"); - debug_print("get_content: \texpire =$CFID_expire\n"); - debug_print("get_content: \tremote_host =$CFID_remotehost\n"); - debug_print("get_content: \tvisitor_afid =$CFID_visitor_afid\n"); - debug_print("get_content: \tvisitor_type(original) =$CFID_visitor_type_str\n"); - - #check visitor_type_str - if($CFID_visitor_type_str eq "self") { - $CFID_visitor_type_str = "f1"; - $CFID_visitor_type =2; - }elsif($CFID_visitor_type_str eq "f1") { - $CFID_visitor_type_str = "f2"; - $CFID_visitor_type =1; - }else{ - $CFID_visitor_type_str = "pb"; - $CFID_visitor_type =0; - } - debug_print("get_content: \tvisitor_type(decreased) =$CFID_visitor_type_str\n"); - -} - -############################################################################ -#Well, after all, who is it? -############################################################################ -my $visitor_type=0; #3=self 2=f1 1=f2 0=pb -my $visitor_type_str="pb"; -my $visitor_afid=""; - -if($ck_visitor_type == 3){ - - $visitor_type = $ck_visitor_type; - $visitor_type_str = $ck_visitor_type_str; - $visitor_afid = $ck_visitor_afid; - -}elsif($ck_visitor_type > $CFID_visitor_type){ - - $visitor_type = $ck_visitor_type; - $visitor_type_str = $ck_visitor_type_str; - $visitor_afid = $ck_visitor_afid; - -}else{ - - $visitor_type = $CFID_visitor_type; - $visitor_type_str = $CFID_visitor_type_str; - $visitor_afid = $CFID_visitor_afid; -} - -####################################### -#Is this visitor a friend of this site? - -if($visitor_type < 3){ - my $tmp1 = $af->{fm}->get_attribute_by_afid($visitor_afid, "password"); - - if($tmp1 ne ""){ - $visitor_type = 2; - $visitor_type_str="f1"; - $visitor_afid = $CFID_visitor_afid; - } -} - -debug_print("get_content: Finally..."); -debug_print("get_content: \tvisitor_type = [$visitor_type] [$visitor_type_str]"); -debug_print("get_content: \tvisitor_type = [$visitor_afid]"); -debug_print("get_content: \tmodule = [$module]\n"); -debug_print("get_content: \tcontent = [$content]\n"); - - -############################################################################ -#Output content -############################################################################ -if($module eq "core"){ - - if($content eq "/profile/profile_face.jpg"){ - - #Get summarized permission list for the given user - my @list - = get_summed_permission_list($af, - $visitor_afid, - $visitor_type_str); - - debug_print("get_content: Got summarized permission..."); - debug_print("get_content: \t[@list]"); - - my $permission = $list[5] ; - debug_print("get_content: Pic perm: $permission"); - - my $actual_file=""; - if( $permission ==1) - { - $actual_file = "$af->{site__user_dir}/profile_face.jpg"; - }else{ - $actual_file = "$af->{site__fs_root}/skins/$af->{userpref__skin}/0_face.jpg"; - } - debug_print("/profile/profile_face.jpg => $actual_file"); - open(IMG, "< $actual_file"); - print "Content-type: image/jpeg\n"; - print "Pragma: no-cache\n\n"; - binmode (IMG); - binmode (STDOUT); - print ; - close IMG; - - } - - if($content eq "/profile/mystatus"){ - - debug_print("get_content: mystatus!"); - my $mystatus=" "; - if( $visitor_type >= 2){ - $mystatus = $af->{user__currentstatus}; - } - print "Content-type:application/x-javascript\n\n"; - print "document.write(\"$mystatus\");"; - print "\n\n"; - exit(1); - } - - if($content eq "/profile/mystatus_iframe"){ - - debug_print("get_content: mystatus!"); - my $mystatus=" "; - if( $visitor_type >= 2){ - $mystatus = $af->{user__currentstatus}; - } - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache\n\n"; - - # " ni kiwo tsukero!!!! escape! escape! " --> \" - print "
$mystatus
"; - debug_print("get_content: mystatus!"); - exit(1); - } - - print "Content-type: text/html; charset=UTF-8\n"; - print "Pragma: no-cache\n\n"; - print ""; - exit(1); - -} -exit(1); Index: affelio_farm/admin/skelton/affelio/bin/loginexec.cgi diff -u affelio_farm/admin/skelton/affelio/bin/loginexec.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/bin/loginexec.cgi:removed --- affelio_farm/admin/skelton/affelio/bin/loginexec.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/bin/loginexec.cgi Tue Oct 25 04:20:47 2005 @@ -1,136 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: loginexec.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use lib("../extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Error qw(:try); - -use lib("../lib"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::Debug; -use Affelio::misc::Time; -use Affelio::misc::NetMisc; -use Affelio::misc::MyCrypt; -use Affelio::misc::WebInput; -use Affelio::SNS::Handshaker_c; - -my $q = new CGI; - -############################################################################ -#Load Affelio -############################################################################ -my $cfg_dir = "../config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e); -}; -my $wi = new Affelio::misc::WebInput; - -############################################################################ -#Authentication check -############################################################################ -my $username = $wi->PTN_word($q->param("username")); -my $password = $wi->PTN_through($q->param("password")); -my $forward_URL = $wi->PTN_URL($q->param("forward_URL")); - -debug_print(" username = $username\n"); -debug_print(" password = $password\n"); -debug_print(" $af->{site__password}\n"); -debug_print(" $forward_URL\n"); - -if( (verify_password($password, $af->{site__password}) > 0) - && ($username eq $af->{site__username}) ){ - - debug_print("loginexec.cgi: AUTH Ok.\n"); - #login OK -}else{ - - #login failed. - debug_print("loginexec.cgi: AUTH NG.\n"); - - my $TMPL_FILE - = "$af->{site__fs_root}/templates/$af->{site__template}/owner_side/loginfailed.tmpl"; - my $tmpl = new HTML::Template( filename => $TMPL_FILE); - $tmpl->param(web_root => $af->{site__web_root}); - $tmpl->param("tmpl_path" => "$af->{site__web_root}/templates/$af->{site__template}"); - print "Content-type: text/html; charset=UTF-8\n\n"; - print $af->translate_templateL10N($tmpl->output); - - debug_print("loginexec.cgi: exit(1).\n"); - exit(1); -} - - -############################################################################ -#Startup session -############################################################################ -my $ss = new CGI::Session("driver:File", - undef, - {Directory=> $af->{site__session_dir}}); - -#Set values into session -$ss->param("user_afid", $af->{site__web_root}); -$ss->param("user_nickname", $af->{user__nickname}); -$ss->param("type", "self"); -#current time -#expire time - -$ss->expire('+12h'); - -debug_print("loginexec.cgi: startup_session finished.\n"); - - -############################################################################ -#Output -############################################################################ - -#Retrieve a sesion_id -my $session_id = $ss->id(); - -#Prepare a cookie with the session_id -my $cookie = $q->cookie ( -name => "affelio-$af->{user__nickname}", - -value => $session_id, - -path => URL2path($af->{site__web_root})); - -debug_print("loginexec.cgi: new cookie [$session_id]\n"); -debug_print("loginexec.cgi: new cookie [" . URL2domain($af->{site__web_root}) . "]\n"); -debug_print("loginexec.cgi: new cookie [" . URL2path($af->{site__web_root}) . "]\n"); - - -#Print output -if($forward_URL ne ""){ - print $q->redirect( -url => $forward_URL, - -cookie => $cookie); -}else{ - print $q->redirect( -url => "$af->{site__web_root}/admin.cgi", - -cookie => $cookie); -} - -exit(1); Index: affelio_farm/admin/skelton/affelio/bin/logoutexec.cgi diff -u affelio_farm/admin/skelton/affelio/bin/logoutexec.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/bin/logoutexec.cgi:removed --- affelio_farm/admin/skelton/affelio/bin/logoutexec.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/bin/logoutexec.cgi Tue Oct 25 04:20:47 2005 @@ -1,78 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: logoutexec.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -use lib("../extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Error qw(:try); - -use lib("../lib"); -use Affelio; -use Affelio::SNS::Handshaker_c; -use Affelio::misc::CGIError; -use Affelio::misc::Debug; -use Affelio::misc::NetMisc; -use Affelio::misc::MyCrypt; -use Affelio::misc::Time; - -my $q = new CGI; -############################################################################ -#Load Affelio -############################################################################ -my $cfg_dir = "../config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e); -}; -my $wi = new Affelio::misc::WebInput; - -############################################################################ -#Check session w/ cookie -############################################################################ -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -my $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - - -if($session){ - #Output expired cookie and redirect the user to index. - $session->delete(); - undef($session); - - #Output expired cookie and redirect the user to index. - my $cookie = $q->cookie ( -name => "affelio-$af->{user__nickname}", - -value => $sid, - -path => URL2path($af->{site__web_root}), - -expires => "-1d" - ); - - print $q->redirect( -url => $af->{site__web_root}, - -cookie => $cookie); - -} Index: affelio_farm/admin/skelton/affelio/bin/recv_mail_ack.cgi diff -u affelio_farm/admin/skelton/affelio/bin/recv_mail_ack.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/bin/recv_mail_ack.cgi:removed --- affelio_farm/admin/skelton/affelio/bin/recv_mail_ack.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/bin/recv_mail_ack.cgi Tue Oct 25 04:20:47 2005 @@ -1,205 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: recv_mail_ack.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; -use lib("../extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use File::Copy; -use Math::BigInt; -use Crypt::DH; -use Error qw(:try); - -use lib("../lib/"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::Debug; -use Affelio::misc::MyCrypt; -use Affelio::SNS::Handshaker_c; -use Affelio::SNS::Handshaker_tmpDB; -use Affelio::exception::Exception; -use Affelio::exception::IOException; -use Affelio::misc::WebInput; - -my $q = new CGI; - -############################################################################ -#Load Affelio -my $cfg_dir = "../config/"; -my $af; -try{ - $af = new Affelio(ConfigDir => $cfg_dir); -}catch Error with{ - my $e = shift; - error($q, "Affelio load error.\n" . $e); -}; -my $wi = new Affelio::misc::WebInput; - -############################################################################ -#Sesion check (as admin) -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -my $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - -my $TMPL_FILE=""; -if( (!$session) || ($session->param("type") ne "self") ){ - # Is the session alive? - # Is the user the admin of this site? - # if not.... - debug_print("recv_mail_ack.cgi: login is needed."); - - $TMPL_FILE - = "$af->{site__fs_root}/templates/$af->{site__template}/owner_side/login.tmpl"; - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - $tmpl->param(reason_msg => "You haven't been authenticated."); - $tmpl->param("tmpl_path" => "$af->{site__web_root}/templates/$af->{site__template}/owner_side/"); - print "Content-type: text/html; charset=UTF-8\n\n"; - print $af->translate_templateL10N($tmpl->output); - exit(1); -} -debug_print("recv_mail_ack.cgi: Session as the admin is OK."); - - -############################################################################ -#Read CGI input -my $session_id=""; -$session_id = $wi->PTN_word($q->param("id")); -if(!$session_id){ - die "id is not defined. [$session_id]"; -} -debug_print("recv_mail_ack: $session_id\n"); - - -############################################################################ -#Read temporarily-saved session -my $dummy; -my $timestamp; -my $peer_af_id; -my $peer_name; -my $peer_nickname; -my $peer_DH_pub_key_str; -my $peer_DH_pub_key; - -############################################################################ -#remove a record from tmpDB -my $tmpdb= new Affelio::SNS::Handshaker_tmpDB($af); -my @ret= $tmpdb->remove_received_Handshake($session_id); - -if(!defined(@ret)){ - #No such session exists!! - debug_print("recv_mail_ack: session not found.\n"); - error($q, "Affelio load error.\nNo such session exists!"); -}else{ - ($dummy, $timestamp, $peer_af_id, - $peer_nickname, $peer_DH_pub_key_str) = @ret; - - $peer_DH_pub_key = Math::BigInt->new($peer_DH_pub_key_str); -} -debug_print("recv_mail_ack: $session_id, $timestamp, $peer_af_id, $peer_nickname, $peer_DH_pub_key_str\n"); - -############################################################################ -#DH key generation -my $mydh = Crypt::DH->new; -#RFC 2412 - The OAKLEY Key Determination Protocol -#Group 1: A 768 bit prime -my $DH_g="2"; -my $DH_p="1552518092300708935130918131258481755631334049434514313202351194902966239949102107258669453876591642442910007680288864229150803718918046342632727613031282983744380820890196288509170691316593175367469551763119843371637221007210577919"; -$mydh->g($DH_g); -$mydh->p($DH_p); -# -#Step (1): create my public_key -$mydh->generate_keys; -my $my_DH_pub_key = $mydh->pub_key; -my $my_DH_pub_key_str = $mydh->pub_key->bstr; - - -############################################################################ -#send FriendshipReply -my $ret=""; -try{ - $ret = reply_HandShake(dest_uri => "$peer_af_id/bin/xml-rpc-serv.cgi", - timestamp => $timestamp, - my_nickname => $af->{user__nickname}, - my_domain => $af->{user__domain}, - my_AFID => $af->{site__web_root}, - DH_pub_key_str => $my_DH_pub_key_str - ); -}catch Error with { - my $E = shift; - error($q, "HandShake reply output an error!\n$E"); -}; - -debug_print("recv_mail_ack: reply_HandShake finished."); - -############################################################################ -#generate Password -my $pass = $mydh->compute_key($peer_DH_pub_key)->bstr; -debug_print("recv_mail_ack: PASSWORD=[$pass]\n"); - - -############################################################################ -#Add peer to my friends list. -try{ - $af->{fm}->add_friend($peer_af_id, - $peer_nickname, - $timestamp, - $pass); -}catch Error with{ - my $E = shift; - error($q, "Error from FriendManager\n$E\n"); -}; -debug_print("recv_mail_ack: added to my friends list."); -sleep(2); - -############################################################################ -#Get peer's friends list. -try{ - $ret = get_F2List(dest_uri => "$peer_af_id/bin/xml-rpc-serv.cgi", - timestamp => 0); -}catch Error with { - my $E = shift; - error($q, "HandShake was successful!\n But, get_F2List reply output an error!\n$E"); -}; -debug_print("recv_mail_ack: get_F2List finished."); -debug_print("recv_mail_ack: List I've got is [$ret]"); -# -# -################################################## -#Save the F2 list into my DB -#$af->{fm}->save_F2List($ret, $peer_af_id); - -############################################################################ -#print output HTML -my $TMPL_FILE = "../templates/$af->{site__template}/owner_side/mail_ack_recved.tmpl"; -my $tmpl = new HTML::Template( filename => $TMPL_FILE); -$tmpl->param(peer_af_id => $peer_af_id); -$tmpl->param(peer_nickname => $peer_nickname); -$tmpl->param(home_url => $af->{site__web_root}); -$tmpl->param("tmpl_path" => "$af->{site__web_root}/templates/$af->{site__template}"); - -print "Content-type: text/html; charset=UTF-8\n\n"; -print $af->translate_templateL10N($tmpl->output); - - Index: affelio_farm/admin/skelton/affelio/bin/send_handshake.cgi diff -u affelio_farm/admin/skelton/affelio/bin/send_handshake.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/bin/send_handshake.cgi:removed --- affelio_farm/admin/skelton/affelio/bin/send_handshake.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/bin/send_handshake.cgi Tue Oct 25 04:20:47 2005 @@ -1,171 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# -# $Id: send_handshake.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; -use lib("../extlib"); -use CGI qw(-unique_headers); -$CGI::DISABLE_UPLOADS = 1; -$CGI::POST_MAX = 102_400; -use CGI::Session qw(-ip_match); -use HTML::Template; -use Fcntl qw( :DEFAULT :flock); -use Crypt::DH; -use Error qw(:try); - -use lib("../lib"); -use Affelio; -use Affelio::misc::CGIError; -use Affelio::misc::Debug; -use Affelio::misc::Time qw(get_timestamp); -use Affelio::misc::WebInput; -use Affelio::SNS::Handshaker_c; -use Affelio::SNS::Handshaker_tmpDB; -use Affelio::exception::Exception; -use Affelio::exception::IOException; - -############################################################################ -#Load Affelio -my $cfg_dir = "../config/"; -my $af = new Affelio(ConfigDir => $cfg_dir); - -############################################################################ -#Sesion check (as admin) -my $q = new CGI; -my $sid = $q->cookie("affelio-$af->{user__nickname}"); -my $session = new CGI::Session(undef, - $sid, - {Directory=> $af->{site__session_dir}}); - -my $TMPL_FILE=""; -if( (!$session) || ($session->param("type") ne "self") ){ - # Is the session alive? - # Is the user the admin of this site? - # if not.... - debug_print("send_handshake.cgi: login is needed."); - - $TMPL_FILE - = "$af->{site__fs_root}/templates/$af->{site__template}/owner_side/login.tmpl"; - my $tmpl = new HTML::Template( filename => $TMPL_FILE, - die_on_bad_params => 0); - $tmpl->param(reason_msg => "You haven't been authenticated."); - $tmpl->param("tmpl_path" => "$af->{site__web_root}/templates/$af->{site__template}/owner_side/"); - print "Content-type: text/html; charset=UTF-8\n\n"; - print $af->translate_templateL10N($tmpl->output); - exit(1); -} -debug_print("send_handshake.cgi: Session as the admin is OK."); - -############################################################################ -#Read input -my $target_url=""; -my $target_xml_url=""; - -$target_url = $q->param("URL"); -if(!$target_url){ - error($q,"Target URL is not defined."); -} - -###################### -#Distill valid URL -###################### -my $wi = new Affelio::misc::WebInput; -$target_url = $wi->PTN_URL($target_url); -if($target_url eq ""){ - error($q,"Target URL is invalid!!"); -} - -###################### -#Remove "/" from the end of $target_url -###################### -$target_url =~ s/\/$//; -debug_print("send_HandShake: $target_url\n"); -$target_xml_url = $target_url . "/bin/xml-rpc-serv.cgi"; -debug_print("send_HandShake: $target_xml_url\n"); - -########################################### -# Get current time; -my $cur_time = get_timestamp(); - - -########################################### -#DH key generation -my $mydh = Crypt::DH->new; -#RFC 2412 - The OAKLEY Key Determination Protocol -#Group 1: A 768 bit prime -my $DH_g="2"; -my $DH_p="1552518092300708935130918131258481755631334049434514313202351194902966239949102107258669453876591642442910007680288864229150803718918046342632727613031282983744380820890196288509170691316593175367469551763119843371637221007210577919"; -$mydh->g($DH_g); -$mydh->p($DH_p); -# -#Step (1): create my public_key -$mydh->generate_keys; -my $my_DH_pub_key_str = $mydh->pub_key->bstr; -my $my_DH_pri_key_str = $mydh->priv_key->bstr; - -debug_print("send_HandShake: pri_key = $my_DH_pri_key_str [" . length($my_DH_pri_key_str) . "]digits"); -debug_print("send_HandShake: pub_key = $my_DH_pub_key_str [" . length($my_DH_pub_key_str) . "]digits"); - - -########################################### -# Send HandShake to the URL -my $ret=""; -try{ - $ret = send_HandShake(dest_uri => $target_xml_url, - timestamp => $cur_time, - my_nickname => $af->{user__nickname}, - my_AFID => $af->{site__web_root}, - DH_pub_key_str => $my_DH_pub_key_str - ); -}catch Affelio::exception::IOException with{ - my $E = shift; - error($q, "
" . $E . "
"); -}catch Affelio::exception::Exception with{ - my $E = shift; - error($q, "
" . $E .  "
"); -}; -if($ret->{flerror} == 1){ - #XML-RPC communication was successful. - #But the peer returned error. denyetc... - error($q, "
XML-RPC peer denied RPC.
"); -} - - -########################################### -# Save peer's info into pending_DB -my $tmpdb= new Affelio::SNS::Handshaker_tmpDB($af); -$tmpdb->add_sent_Handshake($cur_time, - $target_xml_url, - "", - $cur_time, - $my_DH_pri_key_str); -debug_print("send_HandShake: DB(W) $target_url => $cur_time\n"); - - -########################################### -# Print output -my $TMPL_FILE = "../templates/$af->{site__template}/owner_side/handshake_sent.tmpl"; -my $tmpl = new HTML::Template( filename => $TMPL_FILE); -$tmpl->param(target_url => $target_url); -$tmpl->param(mypage_url => "$af->{site__web_root}/admin.cgi"); -$tmpl->param("tmpl_path" => "$af->{site__web_root}/templates/$af->{site__template}"); - -print "Content-type: text/html; charset=UTF-8\n\n"; -print $af->translate_templateL10N($tmpl->output); - Index: affelio_farm/admin/skelton/affelio/bin/xml-rpc-serv.cgi diff -u affelio_farm/admin/skelton/affelio/bin/xml-rpc-serv.cgi:1.1.1.1 affelio_farm/admin/skelton/affelio/bin/xml-rpc-serv.cgi:removed --- affelio_farm/admin/skelton/affelio/bin/xml-rpc-serv.cgi:1.1.1.1 Tue Oct 25 04:14:39 2005 +++ affelio_farm/admin/skelton/affelio/bin/xml-rpc-serv.cgi Tue Oct 25 04:20:47 2005 @@ -1,48 +0,0 @@ -#!/usr/bin/perl - -# Copyright (C) 2005 FishGrove Inc. -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License -# as published by the Free Software Foundation; either version 2 -# of the License, or (at your option) any later version. -# -# 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. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# $Id: xml-rpc-serv.cgi,v 1.1.1.1 2005/10/24 19:14:39 slash5234 Exp $ - -use strict; - -my($AF_DIR); - -BEGIN { -# if ($0 =~ m!(.*[/\\])!) { -# $AF_DIR = $1; -# } else { - $AF_DIR = '../'; -# } - unshift @INC, $AF_DIR . 'lib/'; - unshift @INC, $AF_DIR . 'extlib/'; -} -use XMLRPC::Transport::HTTP; -use Affelio::SNS::Handshaker_s; - -$Affelio::SNS::Handshaker_s::AF_DIR = $AF_DIR; - -######################################################################## -{ - local $SIG{__WARN__} = sub { }; - my $server = XMLRPC::Transport::HTTP::CGI->new; - $server->dispatch_to('affelio'); - $server->handle; -} - -######################################################################## - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:47 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:47 +0900 Subject: [Affelio-cvs 645] CVS update: affelio_farm/admin/skelton/affelio/config Message-ID: <20051024192047.B93212AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/config/.htaccess diff -u affelio_farm/admin/skelton/affelio/config/.htaccess:1.1.1.1 affelio_farm/admin/skelton/affelio/config/.htaccess:removed --- affelio_farm/admin/skelton/affelio/config/.htaccess:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/config/.htaccess Tue Oct 25 04:20:47 2005 @@ -1,8 +0,0 @@ -AuthUserFile /dev/null -AuthGroupFile /dev/null -AuthType Basic - - -order deny,allow -deny from all - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:48 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:48 +0900 Subject: [Affelio-cvs 646] CVS update: affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us Message-ID: <20051024192048.0E8582AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_flist.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_flist.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_flist.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_flist.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_flist.aftmpl Tue Oct 25 04:20:47 2005 @@ -1,68 +0,0 @@ - -
- - - - - -
- - -
-Friends of - -( mode) - -login/logout
-
-Current user::  
-Current mode:  
-
-
-Username: -Password: - -    LOGOUT -
-
-
- -
-index | profile | friends -
- - -
- - - - - - - - - - - - - -
- - -
-
-
-Friends:
-Friends of friends: -
-
- -
-
Friends of
- -
- -
- -
-
Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_index.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_index.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_index.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_index.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_index.aftmpl Tue Oct 25 04:20:47 2005 @@ -1,80 +0,0 @@ - -
- - - - - -
- - -
-'s Affelio:   Welcom, ">! - -( mode) - -login/logout
-
-Current user::  
-Current mode:  
-
-
-Username: -Password: - -    LOGOUT -
-
-
- -
-index | profile | friends -
- - -
- - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - -
- - - -
- -
-
Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_profile.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_profile.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_profile.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_profile.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/body_profile.aftmpl Tue Oct 25 04:20:47 2005 @@ -1,71 +0,0 @@ - -
- - - - - -
- - -
-'s Affelio:   Profile opened to "> - -( mode) - -login/logout
-
-Current user::  
-Current mode:  
-
-
-Username: -Password: - -    LOGOUT -
-
-
- - -
-index | profile | friends -
- - -
- - - - - - - - - - - - - - - - -
- - - -
- -
-
Detailed Profile
- -
- -
- -
-
Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/footer.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/footer.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/footer.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/footer.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/footer.aftmpl Tue Oct 25 04:20:47 2005 @@ -1,15 +0,0 @@ - -
- - - -
-Powered by Affelio: Affelio Project (2004-2005) -
- - -
- - - - Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/header.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/header.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/header.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/header.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/en_us/header.aftmpl Tue Oct 25 04:20:48 2005 @@ -1,39 +0,0 @@ - - - - - -Affelio: <AF_VAR ESCAPE="HTML" NAME="app__page_title"> - -Affelio: <AF_VAR ESCAPE="HTML" NAME="profile_nickname">'s Affelio Page - - -/style.css" media="screen"> - - -/style.css" media="screen"> - - - - - - - -
- - - - - - - - - - -
- -
- - - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:47 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:47 +0900 Subject: [Affelio-cvs 647] CVS update: affelio_farm/admin/skelton/affelio/defaults Message-ID: <20051024192047.DC3322AC030@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/defaults/AFuser_CORE_prof_attr.csv diff -u affelio_farm/admin/skelton/affelio/defaults/AFuser_CORE_prof_attr.csv:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/AFuser_CORE_prof_attr.csv:removed --- affelio_farm/admin/skelton/affelio/defaults/AFuser_CORE_prof_attr.csv:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/AFuser_CORE_prof_attr.csv Tue Oct 25 04:20:47 2005 @@ -1,23 +0,0 @@ -0,nickname,1 -1,n_family,1 -2,n_other,1 -3,n_given,1 -4,bday,1 -5,myimage,2 -6,intromesg1,1 -7,intromesg2,1 -8,email1,1 -9,email1_desc,1 -10,email2,1 -11,email2_desc,1 -12,url1,1 -13,url1_desc,1 -14,url2,1 -15,url2_desc,1 -16,im1,1 -17,im1_desc,1 -18,im2,1 -19,im2_desc,1 -20,im3,1 -21,im3_desc,1 -22,currentstatus,1 Index: affelio_farm/admin/skelton/affelio/defaults/preference.cfg diff -u affelio_farm/admin/skelton/affelio/defaults/preference.cfg:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/preference.cfg:removed --- affelio_farm/admin/skelton/affelio/defaults/preference.cfg:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/preference.cfg Tue Oct 25 04:20:47 2005 @@ -1,5 +0,0 @@ -[preference] -emailack_friendship_recv = yes -preferred_hosting_service = http://my.affelio.jp/hosting/ -skin = standard - Index: affelio_farm/admin/skelton/affelio/defaults/profile_face.jpg Index: affelio_farm/admin/skelton/affelio/defaults/script.js diff -u affelio_farm/admin/skelton/affelio/defaults/script.js:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/script.js:removed --- affelio_farm/admin/skelton/affelio/defaults/script.js:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/script.js Tue Oct 25 04:20:47 2005 @@ -1,18 +0,0 @@ -if(document.getElementById){ - document.writeln(''); -} - -function showHide(id){ - var disp = document.getElementById(id).style.display; - if(disp == "block"){ - document.getElementById(id).style.display = "none"; - }else{ - document.getElementById(id).style.display = "block"; - } - return false; -} - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:48 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:48 +0900 Subject: [Affelio-cvs 648] CVS update: affelio_farm/admin/skelton/affelio/defaults/af_templates/ja Message-ID: <20051024192048.372302AC02F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_flist.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_flist.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_flist.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_flist.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_flist.aftmpl Tue Oct 25 04:20:48 2005 @@ -1,68 +0,0 @@ - -
- - - - - -
- - -
-???????>?荀?- -(?≪??? - -login/ougout
-
-?上?????違??鰹???AF_VAR ESCAPE="HTML" NAME="client_afid">
-?上?????若?鐚????AF_VAR ESCAPE="HTML" NAME="client_relationship">
-
-
-????ゃ?ID: -???????? - -???????≪???/A> - -
-
- -
-index | profile | friends -
- - -
- - - - - - - - - - - - - -
- - -
-
-
-????: 篋?BR> -????????: 篋?-
-
- -
-
????????/div> - -
- -
- -
-
Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_index.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_index.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_index.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_index.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_index.aftmpl Tue Oct 25 04:20:48 2005 @@ -1,80 +0,0 @@ - -
- - - - - -
- - -
-'s Affelio:   ??????">???鐚?- -(?≪??? - -login/logout
-
-?上?????違??鰹???AF_VAR ESCAPE="HTML" NAME="client_afid">
-?上?????若?鐚????AF_VAR ESCAPE="HTML" NAME="client_relationship">
-
-
-????ゃ?ID: -???????? - -???????≪???/A> - -
-
- - - - -
- - - - - - - - - - - - - - - - - - - - - - - - - - -
- - -
-
鐚?AF_VAR ESCAPE="HTML" NAME="profile_currentstatus">
-
- (/index.cgi?mode=profile">more...) -
-
- - - -
- -
-
Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_profile.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_profile.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_profile.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_profile.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/body_profile.aftmpl Tue Oct 25 04:20:48 2005 @@ -1,70 +0,0 @@ - -
- - - - - -
- - -
-'s Affelio:   ">????後??????????????若? - -(?≪??? - -login/logout
-
-?上?????違??鰹???AF_VAR ESCAPE="HTML" NAME="client_afid">
-?上?????若?鐚????AF_VAR ESCAPE="HTML" NAME="client_relationship">
-
-
-????ゃ?ID: -???????? - -???????≪???/A> - -
-
- -
-index | profile | friends -
- - -
- - - - - - - - - - - - - - - - -
- - - -
- -
-
???????若?荅括完
- -
- -
- -
-
Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/footer.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/footer.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/footer.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/footer.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/footer.aftmpl Tue Oct 25 04:20:48 2005 @@ -1,15 +0,0 @@ - -
- - - -
-Powered by Affelio: Affelio Project (2004-2005) -
- - -
- - - - Index: affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/header.aftmpl diff -u affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/header.aftmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/header.aftmpl:removed --- affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/header.aftmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/defaults/af_templates/ja/header.aftmpl Tue Oct 25 04:20:48 2005 @@ -1,39 +0,0 @@ - - - - - -Affelio: <AF_VAR ESCAPE="HTML" NAME="app__page_title"> - -Affelio: <AF_VAR ESCAPE="HTML" NAME="profile_nickname">????若? - - -/style.css" media="screen"> - - -/style.css" media="screen"> - - - - - - - -
- - - - - - - - - - -
- -
- - - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:48 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:48 +0900 Subject: [Affelio-cvs 649] CVS update: affelio_farm/admin/skelton/affelio/extlib Message-ID: <20051024192048.81AFA2AC030@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Error.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Error.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Error.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Error.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Error.pm Tue Oct 25 04:20:48 2005 @@ -1,744 +0,0 @@ -# Error.pm -# -# Copyright (c) 1997-8 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# Based on my original Error.pm, and Exceptions.pm by Peter Seibel -# and adapted by Jesse Glick . -# -# but modified ***significantly*** - -package Error; - -use strict; -use vars qw($VERSION); -use 5.004; - -$VERSION = "0.15"; - -use overload ( - '""' => 'stringify', - '0+' => 'value', - 'bool' => sub { return 1; }, - 'fallback' => 1 -); - -$Error::Depth = 0; # Depth to pass to caller() -$Error::Debug = 0; # Generate verbose stack traces - @ Error::STACK = (); # Clause stack for try -$Error::THROWN = undef; # last error thrown, a workaround until die $ref works - -my $LAST; # Last error created -my %ERROR; # Last error associated with package - -# Exported subs are defined in Error::subs - -sub import { - shift; - local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; - Error::subs->import(@_); -} - -# I really want to use last for the name of this method, but it is a keyword -# which prevent the syntax last Error - -sub prior { - shift; # ignore - - return $LAST unless @_; - - my $pkg = shift; - return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef - unless ref($pkg); - - my $obj = $pkg; - my $err = undef; - if($obj->isa('HASH')) { - $err = $obj->{'__Error__'} - if exists $obj->{'__Error__'}; - } - elsif($obj->isa('GLOB')) { - $err = ${*$obj}{'__Error__'} - if exists ${*$obj}{'__Error__'}; - } - - $err; -} - -# Return as much information as possible about where the error -# happened. The -stacktrace element only exists if $Error::DEBUG -# was set when the error was created - -sub stacktrace { - my $self = shift; - - return $self->{'-stacktrace'} - if exists $self->{'-stacktrace'}; - - my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; - - $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) - unless($text =~ /\n$/s); - - $text; -} - -# Allow error propagation, ie -# -# $ber->encode(...) or -# return Error->prior($ber)->associate($ldap); - -sub associate { - my $err = shift; - my $obj = shift; - - return unless ref($obj); - - if($obj->isa('HASH')) { - $obj->{'__Error__'} = $err; - } - elsif($obj->isa('GLOB')) { - ${*$obj}{'__Error__'} = $err; - } - $obj = ref($obj); - $ERROR{ ref($obj) } = $err; - - return; -} - -sub new { - my $self = shift; - my($pkg,$file,$line) = caller($Error::Depth); - - my $err = bless { - '-package' => $pkg, - '-file' => $file, - '-line' => $line, - @_ - }, $self; - - $err->associate($err->{'-object'}) - if(exists $err->{'-object'}); - - # To always create a stacktrace would be very inefficient, so - # we only do it if $Error::Debug is set - - if($Error::Debug) { - require Carp; - local $Carp::CarpLevel = $Error::Depth; - my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; - my $trace = Carp::longmess($text); - # Remove try calls from the trace - $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; - $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; - $err->{'-stacktrace'} = $trace - } - - $@ = $LAST = $ERROR{$pkg} = $err; -} - -# Throw an error. this contains some very gory code. - -sub throw { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - # if we are not rethrow-ing then create the object to throw - $self = $self->new(@_) unless ref($self); - - die $Error::THROWN = $self; -} - -# syntactic sugar for -# -# die with Error( ... ); - -sub with { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - $self->new(@_); -} - -# syntactic sugar for -# -# record Error( ... ) and return; - -sub record { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - $self->new(@_); -} - -# catch clause for -# -# try { ... } catch CLASS with { ... } - -sub catch { - my $pkg = shift; - my $code = shift; - my $clauses = shift || {}; - my $catch = $clauses->{'catch'} ||= []; - - unshift @$catch, $pkg, $code; - - $clauses; -} - -# Object query methods - -sub object { - my $self = shift; - exists $self->{'-object'} ? $self->{'-object'} : undef; -} - -sub file { - my $self = shift; - exists $self->{'-file'} ? $self->{'-file'} : undef; -} - -sub line { - my $self = shift; - exists $self->{'-line'} ? $self->{'-line'} : undef; -} - -sub text { - my $self = shift; - exists $self->{'-text'} ? $self->{'-text'} : undef; -} - -# overload methods - -sub stringify { - my $self = shift; - defined $self->{'-text'} ? $self->{'-text'} : "Died"; -} - -sub value { - my $self = shift; - exists $self->{'-value'} ? $self->{'-value'} : undef; -} - -package Error::Simple; - - @ Error::Simple::ISA = qw(Error); - -sub new { - my $self = shift; - my $text = "" . shift; - my $value = shift; - my(@args) = (); - - local $Error::Depth = $Error::Depth + 1; - - @args = ( -file => $1, -line => $2) - if($text =~ s/ at (\S+) line (\d+)(\.\n)?$//s); - - push(@args, '-value', 0 + $value) - if defined($value); - - $self->SUPER::new(-text => $text, @args); -} - -sub stringify { - my $self = shift; - my $text = $self->SUPER::stringify; - $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) - unless($text =~ /\n$/s); - $text; -} - -########################################################################## -########################################################################## - -# Inspired by code from Jesse Glick and -# Peter Seibel - -package Error::subs; - -use Exporter (); -use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); - - @ EXPORT_OK = qw(try with finally except otherwise); -%EXPORT_TAGS = (try => \@EXPORT_OK); - - @ ISA = qw(Exporter); - -sub run_clauses ($$$\@) { - my($clauses,$err,$wantarray,$result) = @_; - my $code = undef; - - $err = new Error::Simple($err) unless ref($err); - - CATCH: { - - # catch - my $catch; - if(defined($catch = $clauses->{'catch'})) { - my $i = 0; - - CATCHLOOP: - for( ; $i < @$catch ; $i += 2) { - my $pkg = $catch->[$i]; - unless(defined $pkg) { - #except - splice(@$catch,$i,2,$catch->[$i+1]->()); - $i -= 2; - next CATCHLOOP; - } - elsif($err->isa($pkg)) { - $code = $catch->[$i+1]; - while(1) { - my $more = 0; - local($Error::THROWN); - my $ok = eval { - if($wantarray) { - @{$result} = $code->($err,\$more); - } - elsif(defined($wantarray)) { - @{$result} = (); - $result->[0] = $code->($err,\$more); - } - else { - $code->($err,\$more); - } - 1; - }; - if( $ok ) { - next CATCHLOOP if $more; - undef $err; - } - else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - $err = new Error::Simple($err) - unless ref($err); - } - last CATCH; - }; - } - } - } - - # otherwise - my $owise; - if(defined($owise = $clauses->{'otherwise'})) { - my $code = $clauses->{'otherwise'}; - my $more = 0; - my $ok = eval { - if($wantarray) { - @{$result} = $code->($err,\$more); - } - elsif(defined($wantarray)) { - @{$result} = (); - $result->[0] = $code->($err,\$more); - } - else { - $code->($err,\$more); - } - 1; - }; - if( $ok ) { - undef $err; - } - else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - $err = new Error::Simple($err) - unless ref($err); - } - } - } - $err; -} - -sub try (&;$) { - my $try = shift; - my $clauses = @_ ? shift : {}; - my $ok = 0; - my $err = undef; - my @result = (); - - unshift @Error::STACK, $clauses; - - my $wantarray = wantarray(); - - do { - local $Error::THROWN = undef; - - $ok = eval { - if($wantarray) { - @result = $try->(); - } - elsif(defined $wantarray) { - $result[0] = $try->(); - } - else { - $try->(); - } - 1; - }; - - $err = defined($Error::THROWN) ? $Error::THROWN : $@ - unless $ok; - }; - - shift @Error::STACK; - - $err = run_clauses($clauses,$err,wantarray, @ result) - unless($ok); - - $clauses->{'finally'}->() - if(defined($clauses->{'finally'})); - - throw $err if defined($err); - - wantarray ? @result : $result[0]; -} - -# Each clause adds a sub to the list of clauses. The finally clause is -# always the last, and the otherwise clause is always added just before -# the finally clause. -# -# All clauses, except the finally clause, add a sub which takes one argument -# this argument will be the error being thrown. The sub will return a code ref -# if that clause can handle that error, otherwise undef is returned. -# -# The otherwise clause adds a sub which unconditionally returns the users -# code reference, this is why it is forced to be last. -# -# The catch clause is defined in Error.pm, as the syntax causes it to -# be called as a method - -sub with (&;$) { - @_ -} - -sub finally (&) { - my $code = shift; - my $clauses = { 'finally' => $code }; - $clauses; -} - -# The except clause is a block which returns a hashref or a list of -# key-value pairs, where the keys are the classes and the values are subs. - -sub except (&;$) { - my $code = shift; - my $clauses = shift || {}; - my $catch = $clauses->{'catch'} ||= []; - - my $sub = sub { - my $ref; - my(@array) = $code->($_[0]); - if(@array == 1 && ref($array[0])) { - $ref = $array[0]; - $ref = [ %$ref ] - if(UNIVERSAL::isa($ref,'HASH')); - } - else { - $ref = \@array; - } - @$ref - }; - - unshift @{$catch}, undef, $sub; - - $clauses; -} - -sub otherwise (&;$) { - my $code = shift; - my $clauses = shift || {}; - - if(exists $clauses->{'otherwise'}) { - require Carp; - Carp::croak("Multiple otherwise clauses"); - } - - $clauses->{'otherwise'} = $code; - - $clauses; -} - -1; -__END__ - -=head1 NAME - -Error - Error/exception handling in an OO-ish way - -=head1 SYNOPSIS - - use Error qw(:try); - - throw Error::Simple( "A simple error"); - - sub xyz { - ... - record Error::Simple("A simple error") - and return; - } - - unlink($file) or throw Error::Simple("$file: $!",$!); - - try { - do_some_stuff(); - die "error!" if $condition; - throw Error::Simple -text => "Oops!" if $other_condition; - } - catch Error::IO with { - my $E = shift; - print STDERR "File ", $E->{'-file'}, " had a problem\n"; - } - except { - my $E = shift; - my $general_handler=sub {send_message $E->{-description}}; - return { - UserException1 => $general_handler, - UserException2 => $general_handler - }; - } - otherwise { - print STDERR "Well I don't know what to say\n"; - } - finally { - close_the_garage_door_already(); # Should be reliable - }; # Don't forget the trailing ; or you might be surprised - -=head1 DESCRIPTION - -The C package provides two interfaces. Firstly C provides -a procedural interface to exception handling. Secondly C is a -base class for errors/exceptions that can either be thrown, for -subsequent catch, or can simply be recorded. - -Errors in the class C should not be thrown directly, but the -user should throw errors from a sub-class of C. - -=head1 PROCEDURAL INTERFACE - -C exports subroutines to perform exception handling. These will -be exported if the C<:try> tag is used in the C line. - -=over 4 - -=item try BLOCK CLAUSES - -C is the main subroutine called by the user. All other subroutines -exported are clauses to the try subroutine. - -The BLOCK will be evaluated and, if no error is throw, try will return -the result of the block. - -C are the subroutines below, which describe what to do in the -event of an error being thrown within BLOCK. - -=item catch CLASS with BLOCK - -This clauses will cause all errors that satisfy C<$err-Eisa(CLASS)> -to be caught and handled by evaluating C. - -C will be passed two arguments. The first will be the error -being thrown. The second is a reference to a scalar variable. If this -variable is set by the catch block then, on return from the catch -block, try will continue processing as if the catch block was never -found. - -To propagate the error the catch block may call C<$err-Ethrow> - -If the scalar reference by the second argument is not set, and the -error is not thrown. Then the current try block will return with the -result from the catch block. - -=item except BLOCK - -When C is looking for a handler, if an except clause is found -C is evaluated. The return value from this block should be a -HASHREF or a list of key-value pairs, where the keys are class names -and the values are CODE references for the handler of errors of that -type. - -=item otherwise BLOCK - -Catch any error by executing the code in C - -When evaluated C will be passed one argument, which will be the -error being processed. - -Only one otherwise block may be specified per try block - -=item finally BLOCK - -Execute the code in C either after the code in the try block has -successfully completed, or if the try block throws an error then -C will be executed after the handler has completed. - -If the handler throws an error then the error will be caught, the -finally block will be executed and the error will be re-thrown. - -Only one finally block may be specified per try block - -=back - -=head1 CLASS INTERFACE - -=head2 CONSTRUCTORS - -The C object is implemented as a HASH. This HASH is initialized -with the arguments that are passed to it's constructor. The elements -that are used by, or are retrievable by the C class are listed -below, other classes may add to these. - - -file - -line - -text - -value - -object - -If C<-file> or C<-line> are not specified in the constructor arguments -then these will be initialized with the file name and line number where -the constructor was called from. - -If the error is associated with an object then the object should be -passed as the C<-object> argument. This will allow the C package -to associate the error with the object. - -The C package remembers the last error created, and also the -last error associated with a package. This could either be the last -error created by a sub in that package, or the last error which passed -an object blessed into that package as the C<-object> argument. - -=over 4 - -=item throw ( [ ARGS ] ) - -Create a new C object and throw an error, which will be caught -by a surrounding C block, if there is one. Otherwise it will cause -the program to exit. - -C may also be called on an existing error to re-throw it. - -=item with ( [ ARGS ] ) - -Create a new C object and returns it. This is defined for -syntactic sugar, eg - - die with Some::Error ( ... ); - -=item record ( [ ARGS ] ) - -Create a new C object and returns it. This is defined for -syntactic sugar, eg - - record Some::Error ( ... ) - and return; - -=back - -=head2 STATIC METHODS - -=over 4 - -=item prior ( [ PACKAGE ] ) - -Return the last error created, or the last error associated with -C - -=back - -=head2 OBJECT METHODS - -=over 4 - -=item stacktrace - -If the variable C<$Error::Debug> was non-zero when the error was -created, then C returns a string created by calling -C. If the variable was zero the C returns -the text of the error appended with the filename and line number of -where the error was created, providing the text does not end with a -newline. - -=item object - -The object this error was associated with - -=item file - -The file where the constructor of this error was called from - -=item line - -The line where the constructor of this error was called from - -=item text - -The text of the error - -=back - -=head2 OVERLOAD METHODS - -=over 4 - -=item stringify - -A method that converts the object into a string. This method may simply -return the same as the C method, or it may append more -information. For example the file name and line number. - -By default this method returns the C<-text> argument that was passed to -the constructor, or the string C<"Died"> if none was given. - -=item value - -A method that will return a value that can be associated with the -error. For example if an error was created due to the failure of a -system call, then this may return the numeric value of C<$!> at the -time. - -By default this method returns the C<-value> argument that was passed -to the constructor. - -=back - -=head1 PRE-DEFINED ERROR CLASSES - -=over 4 - -=item Error::Simple - -This class can be used to hold simple error strings and values. It's -constructor takes two arguments. The first is a text value, the second -is a numeric value. These values are what will be returned by the -overload methods. - -If the text value ends with C as $@ strings do, then -this infomation will be used to set the C<-file> and C<-line> arguments -of the error object. - -This class is used internally if an eval'd block die's with an error -that is a plain string. - -=back - -=head1 KNOWN BUGS - -None, but that does not mean there are not any. - -=head1 AUTHORS - -Graham Barr - -The code that inspired me to write this was originally written by -Peter Seibel and adapted by Jesse Glick -. - -=head1 MAINTAINER - -Arun Kumar U - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/Jcode.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Jcode.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Jcode.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Jcode.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Jcode.pm Tue Oct 25 04:20:48 2005 @@ -1,829 +0,0 @@ -# -# $Id: Jcode.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# - -=head1 NAME - -Jcode - Japanese Charset Handler - -=head1 SYNOPSIS - - use Jcode; - # - # traditional - Jcode::convert(\$str, $ocode, $icode, "z"); - # or OOP! - print Jcode->new($str)->h2z->tr($from, $to)->utf8; - -=cut - -=head1 DESCRIPTION - -Jcode.pm supports both object and traditional approach. -With object approach, you can go like; - -$iso_2022_jp = Jcode->new($str)->h2z->jis; - -Which is more elegant than; - -$iso_2022_jp = &jcode::convert(\$str,'jis',jcode::getcode(\str), "z"); - -For those unfamiliar with objects, Jcode.pm still supports getcode() -and convert(). - -=cut - - package Jcode; -use 5.004; -use Carp; -use strict; -use vars qw($RCSID $VERSION $DEBUG); - -$RCSID = q$Id: Jcode.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $; -$VERSION = do { my @r = (q$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; -$DEBUG = 0; - -use Exporter; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - @ ISA = qw(Exporter); - @ EXPORT = qw(jcode getcode); - @ EXPORT_OK = qw($RCSID $VERSION $DEBUG); -%EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); - - -use vars qw($USE_CACHE $NOXS); - -$USE_CACHE = 1; -$NOXS = 0; - -print $RCSID, "\n" if $DEBUG; - -use Jcode::Constants qw(:all); - -use overload - q("") => sub { ${$_[0]->[0]} }, - q(==) => sub {overload::StrVal($_[0]) eq overload::StrVal($_[1])}, - q(=) => sub { $_[0]->set( $_[1] ) }, - q(.=) => sub { $_[0]->append( $_[1] ) }, - fallback => 1, - ; - -=head1 Methods - -Methods mentioned here all return Jcode object unless otherwise mentioned. - -=over 4 - -=item $j = Jcode-Enew($str [, $icode]); - -Creates Jcode object $j from $str. Input code is automatically checked -unless you explicitly set $icode. For available charset, see L -below. - -The object keeps the string in EUC format enternaly. When the object -itself is evaluated, it returns the EUC-converted string so you can -"print $j;" without calling access method if you are using EUC -(thanks to function overload). - -=item Passing Reference - -Instead of scalar value, You can use reference as - - Jcode->new(\$str); - -This saves time a little bit. In exchange of the value of $str being -converted. (In a way, $str is now "tied" to jcode object). - - =item $j-Eset($str [, $icode]); - -Sets $j's internal string to $str. Handy when you use Jcode object repeatedly -(saves time and memory to create object). - - # converts mailbox to SJIS format - my $jconv = new Jcode; -$/ = 00; -while(<>){ - print $jconv->set(\$_)->mime_decode->sjis; -} - -=item $j-Eappend($str [, $icode]); - -Appends $str to $j's internal string. - -=back - -=cut - -sub new { - my $class = shift; - my ($thingy, $icode) = @_; - my $r_str = ref $thingy ? $thingy : \$thingy; - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - convert($r_str, 'euc', $icode); - my $self = [ - $r_str, - $icode, - $nmatch, - ]; - carp "Object of class $class created" if $DEBUG >= 2; - bless $self, $class; -} - -sub r_str { $_[0]->[0] } -sub icode { $_[0]->[1] } -sub nmatch { $_[0]->[2] } - -sub set { - my $self = shift; - my ($thingy, $icode) = @_; - my $r_str = ref $thingy ? $thingy : \$thingy; - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - convert($r_str, 'euc', $icode); - $self->[0] = $r_str; - $self->[1] = $icode; - $self->[2] = $nmatch; - return $self; -} - -sub append { - my $self = shift; - my ($thingy, $icode) = @_; - my $r_str = ref $thingy ? $thingy : \$thingy; - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - convert($r_str, 'euc', $icode); - ${$self->[0]} .= $$r_str; - $self->[1] = $icode; - $self->[2] = $nmatch; - return $self; -} - -=over 4 - - =item $j = jcode($str [, $icode]); - -shortcut for Jcode->new() so you can go like; - -$sjis = jcode($str)->sjis; - -=item $euc = $j-Eeuc; - -=item $jis = $j-Ejis; - -=item $sjis = $j-Esjis; - -What you code is what you get :) - -=item $iso_2022_jp = $j-Eiso_2022_jp - -Same as $j->h2z->jis. -Hankaku Kanas are forcibly converted to Zenkaku. - -=back - -=cut - -sub jcode { return Jcode->new(@_) } -sub euc { return ${$_[0]->[0]} } -sub jis { return &euc_jis(${$_[0]->[0]})} -sub sjis { return &euc_sjis(${$_[0]->[0]})} -sub iso_2022_jp{return $_[0]->h2z->jis} - -=over 4 - - =item [@lines =] $jcode-Ejfold([$bytes_per_line, $newline_str]); - -folds lines in jcode string every $bytes_per_line (default: 72) -in a way that does not clobber the multibyte string. -(Sorry, no Kinsoku done!) -with a newline string spified by $newline_str (default: \n). - -=back - -=cut - -sub jfold{ - my $self = shift; - my ($bpl, $nl) = @_; - $bpl ||= 72; - $nl ||= "\n"; - my $r_str = $self->[0]; - my (@lines, $len, $i); - while ($$r_str =~ - m/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff])/sgo) - { - if ($len + length($1) > $bpl){ # fold! - $i++; - $len = 0; - } - $lines[$i] .= $1; - $len += length($1); - } - defined($lines[$i]) or pop @lines; - $$r_str = join($nl, @lines); - return wantarray ? @lines : $self; -} - -=pod - -=over 4 - -=item $length = $jcode-Ejlength(); - -returns character length properly, rather than byte length. - -=back - -=cut - -sub jlength { - my $self = shift; - my $r_str = $self->[0]; - return scalar (my @char = $$r_str =~ m/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff])/sgo); -} - -=head2 Methods that use MIME::Base64 - -To use methods below, you need MIME::Base64. To install, simply - - perl -MCPAN -e 'CPAN::Shell->install("MIME::Base64")' - -=over 4 - - =item $mime_header = $j-Emime_encode([$lf, $bpl]); - -Converts $str to MIME-Header documented in RFC1522. -When $lf is specified, it uses $lf to fold line (default: \n). - When $bpl is specified, it uses $bpl for the number of bytes (default: 76; -this number must be smaller than 76). - - =item $j-Emime_decode; - -Decodes MIME-Header in Jcode object. - - You can retrieve the number of matches via $j->nmatch; - -=back - -=cut - -sub mime_encode{ - my $self = shift; - my $r_str = $self->[0]; - my $lf = shift || "\n"; - my $bpl = shift || 76; - - my ($trailing_crlf) = ($$r_str =~ /(\n|\r|\x0d\x0a)$/o); - my $str = _mime_unstructured_header($$r_str, $lf, $bpl); - not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o; - $str; -} - -# -# shamelessly stolen from -# http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 -# - -sub _add_encoded_word { - require MIME::Base64; - my($str, $line, $bpl) = @_; - my $result = ''; - while (length($str)) { - my $target = $str; - $str = ''; - if (length($line) + 22 + - ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl) { - $line =~ s/[ \t\n\r]*$/\n/; - $result .= $line; - $line = ' '; - } - while (1) { - my $iso_2022_jp = jcode($target, 'euc')->iso_2022_jp; - if (my $count = ($iso_2022_jp =~ tr/\x80-\xff//d)){ - $DEBUG and warn $count; - $target = jcode($iso_2022_jp, 'iso_2022_jp')->euc; - } - my $encoded = '=?ISO-2022-JP?B?' . - MIME::Base64::encode_base64($iso_2022_jp, '') - . '?='; - if (length($encoded) + length($line) > $bpl) { - $target =~ - s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o; - $str = $1 . $str; - } else { - $line .= $encoded; - last; - } - } - } - return $result . $line; -} - -sub _mime_unstructured_header { - my ($oldheader, $lf, $bpl) = @_; - my(@words, @wordstmp, $i); - my $header = ''; - $oldheader =~ s/\s+$//; - @wordstmp = split /\s+/, $oldheader; - for ($i = 0; $i < $#wordstmp; $i++) { - if ($wordstmp[$i] !~ /^[\x21-\x7E]+$/ and - $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/) { - $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]"; - } else { - push(@words, $wordstmp[$i]); - } - } - push(@words, $wordstmp[-1]); - for my $word (@words) { - if ($word =~ /^[\x21-\x7E]+$/) { - $header =~ /(?:.*\n)*(.*)/; - if (length($1) + length($word) > $bpl) { - $header .= "$lf $word"; - } else { - $header .= $word; - } - } else { - $header = _add_encoded_word($word, $header, $bpl); - } - $header =~ /(?:.*\n)*(.*)/; - if (length($1) == $bpl) { - $header .= "$lf "; - } else { - $header .= ' '; - } - } - $header =~ s/\n? $/\n/; - $header; -} - -# see http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 -#$lws = '(?:(?:\x0d\x0a)?[ \t])+'; -#$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?='; -#$str =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio; -#$str =~ s/$lws/ /go; $str =~ s/$ew_regex/decode_base64($1)/egio; - -sub mime_decode{ - require MIME::Base64; # not use - my $self = shift; - my $r_str = $self->[0]; - my $re_lws = '(?:(?:\r|\n|\x0d\x0a)?[ \t])+'; - my $re_ew = '=\?[Ii][Ss][Oo]-2022-[Jj][Pp]\?[Bb]\?([A-Za-z0-9+/]+=*)\?='; - $$r_str =~ s/($re_ew)$re_lws(?=$re_ew)/$1/sgo; - $$r_str =~ s/$re_lws/ /go; - $self->[2] = - ($$r_str =~ - s/$re_ew/jis_euc(MIME::Base64::decode_base64($1))/ego - ); - $self; -} - - -=head2 Methods implemented by Jcode::H2Z - -Methods below are actually implemented in Jcode::H2Z. - -=over 4 - - =item $j-Eh2z([$keep_dakuten]); - -Converts X201 kana (Hankaku) to X208 kana (Zenkaku). -When $keep_dakuten is set, it leaves dakuten as is -(That is, "ka + dakuten" is left as is instead of -being converted to "ga") - - You can retrieve the number of matches via $j->nmatch; - -=item $j-Ez2h; - -Converts X208 kana (Zenkaku) to X201 kana (Hankaku). - - You can retrieve the number of matches via $j->nmatch; - -=back - -=cut - -sub h2z { - require Jcode::H2Z; # not use - my $self = shift; - $self->[2] = Jcode::H2Z::h2z($self->[0], @_); - return $self; -} - - -sub z2h { - require Jcode::H2Z; # not use - my $self = shift; - $self->[2] = &Jcode::H2Z::z2h($self->[0], @_); - return $self; -} - - -=head2 Methods implemented in Jcode::Tr - -Methods here are actually implemented in Jcode::Tr. - -=over 4 - - =item $j-Etr($from, $to); - -Applies tr on Jcode object. $from and $to can contain EUC Japanese. - - You can retrieve the number of matches via $j->nmatch; - -=back - -=cut - -sub tr{ - require Jcode::Tr; # not use - my $self = shift; - $self->[2] = Jcode::Tr::tr($self->[0], @_); - return $self; -} - -# -# load needed module depending on the configuration just once! -# - -use vars qw(%PKG_LOADED); -sub load_module{ - my $pkg = shift; - return $pkg if $PKG_LOADED{$pkg}++; - unless ($NOXS){ - eval qq( require $pkg; ); - unless ($@){ - carp "$pkg loaded." if $DEBUG; - return $pkg; - } - } - $pkg .= "::NoXS"; - eval qq( require $pkg; ); - unless ($@){ - carp "$pkg loaded" if $DEBUG; - }else{ - croak "Loading $pkg failed!"; - } - $pkg; -} - -=head2 Methods implemented in Jcode::Unicode - -If your perl does not support XS (or you can't C, -Jcode::Unicode::NoXS will be used. - -See L and L for details - -=over 4 - -=item $ucs2 = $j-Eucs2; - -Returns UCS2 (Raw Unicode) string. - -=item $ucs2 = $j-Eutf8; - -Returns utf8 String. - -=back - -=cut - -sub ucs2{ - load_module("Jcode::Unicode"); - euc_ucs2(${$_[0]->[0]}); -} - -sub utf8{ - load_module("Jcode::Unicode"); - euc_utf8(${$_[0]->[0]}); -} - -=head2 Instance Variables - -If you need to access instance variables of Jcode object, use access -methods below instead of directly accessing them (That's what OOP -is all about) - -FYI, Jcode uses a ref to array instead of ref to hash (common way) to -optimize speed (Actually you don't have to know as long as you use - access methods instead; Once again, that's OOP) - -=over 4 - -=item $j-Er_str - -Reference to the EUC-coded String. - -=item $j-Eicode - -Input charcode in recent operation. - -=item $j-Enmatch - -Number of matches (Used in $j->tr, etc.) - -=back - -=cut - -=head1 Subroutines - -=over 4 - -=item ($code, [$nmatch]) = getcode($str); - -Returns char code of $str. Return codes are as follows - - ascii Ascii (Contains no Japanese Code) - binary Binary (Not Text File) - euc EUC-JP - sjis SHIFT_JIS - jis JIS (ISO-2022-JP) - ucs2 UCS2 (Raw Unicode) - utf8 UTF8 - -When array context is used instead of scaler, it also returns how many -character codes are found. As mentioned above, $str can be \$str -instead. - -B This function is 100% upper-conpatible with -jcode::getcode() -- well, almost; - - * When its return value is an array, the order is the opposite; - jcode::getcode() returns $nmatch first. - - * jcode::getcode() returns 'undef' when the number of EUC characters - is equal to that of SJIS. Jcode::getcode() returns EUC. for - Jcode.pm there is no in-betweens. - -=item Jcode::convert($str, [$ocode, $icode, $opt]); - -Converts $str to char code specified by $ocode. When $icode is specified -also, it assumes $icode for input string instead of the one checked by -getcode(). As mentioned above, $str can be \$str instead. - -B This function is 100% upper-conpatible with -jcode::convert() ! - -=back - -=cut - -sub getcode { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - - my ($code, $nmatch, $sjis, $euc, $utf8) = ("", 0, 0, 0, 0); - if ($$r_str =~ /$RE{BIN}/o) {# 'binary' - my $ucs2; - $ucs2 += length($1) - while $$r_str =~ /(\x00$RE{ASCII})+/go; - if ($ucs2){ # smells like raw unicode - ($code, $nmatch) = ('ucs2', $ucs2); - }else{ - ($code, $nmatch) = ('binary', 0); - } - } - elsif ($$r_str !~ /[\e\x80-\xff]/o) {# not Japanese - ($code, $nmatch) = ('ascii', 1); - }# 'jis' - elsif ($$r_str =~ - m[ - $RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA} - ]ox) -{ - ($code, $nmatch) = ('jis', 1); -} -else { # should be euc|sjis|utf8 - # use of (?:) by Hiroki Ohzaki - $sjis += length($1) - while $$r_str =~ /((?:$RE{SJIS_C})+)/go; - $euc += length($1) - while $$r_str =~ /((?:$RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212})+)/go; - $utf8 += length($1) - while $$r_str =~ /((?:$RE{UTF8})+)/go; - # $utf8 *= 1.5; # M. Takahashi's suggestion - $nmatch = _max($utf8, $sjis, $euc); - carp ">DEBUG:sjis = $sjis, euc = $euc, utf8 = $utf8" if $DEBUG >= 3; - $code = - ($euc > $sjis and $euc > $utf8) ? 'euc' : - ($sjis > $euc and $sjis > $utf8) ? 'sjis' : - ($utf8 > $euc and $utf8 > $sjis) ? 'utf8' : undef; -} -return wantarray ? ($code, $nmatch) : $code; -} - -sub convert{ - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - my ($ocode, $icode, $opt) = @_; - - my $nmatch; - ($icode, $nmatch) = getcode($r_str) unless $icode; - - return $$r_str if $icode eq $ocode and !defined $opt; # do nothin' - - no strict qw(refs); - my $method; - - # convert to EUC - - load_module("Jcode::Unicode") if $icode =~ /ucs2|utf8/o; - if ($icode and defined &{$method = $icode . "_euc"}){ - carp "Dispatching \&$method" if $DEBUG >= 2; - &{$method}($r_str) ; - } - - # h2z or z2h - - if ($opt){ - my $cmd = ($opt =~ /^z/o) ? "h2z" : ($opt =~ /^h/o) ? "z2h" : undef; - if ($cmd){ - require Jcode::H2Z; - &{'Jcode::H2Z::' . $cmd}($r_str); - } - } - - # convert to $ocode - - load_module("Jcode::Unicode") if $ocode =~ /ucs2|utf8/o; - if ($ocode and defined &{$method = "euc_" . $ocode}){ - carp "Dispatching \&$method" if $DEBUG >= 2; - &{$method}($r_str) ; - } - $$r_str; -} - -# JIS<->EUC - -sub jis_euc { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s( - ($RE{JIS_0212}|$RE{JIS_0208}|$RE{JIS_ASC}|$RE{JIS_KANA}) - ([^\e]*) - ) - { - my ($esc, $str) = ($1, $2); - if ($esc !~ /$RE{JIS_ASC}/o) { - $str =~ tr/\x21-\x7e/\xa1-\xfe/; - if ($esc =~ /$RE{JIS_KANA}/o) { - $str =~ s/([\xa1-\xdf])/\x8e$1/og; - } - elsif ($esc =~ /$RE{JIS_0212}/o) { - $str =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; - } - } - $str; - }geox; - $$r_str; -} - -# -# euc_jis -# -# Based upon the contribution of -# Kazuto Ichimura -# optimized by - -sub euc_jis{ - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s{ - ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+) - }{ - my $str = $1; - my $esc = - ( $str =~ tr/\x8E//d ) ? $ESC{KANA} : - ( $str =~ tr/\x8F//d ) ? $ESC{JIS_0212} : - $ESC{JIS_0208}; - $str =~ tr/\xA1-\xFE/\x21-\x7E/; - $esc . $str . $ESC{ASC}; - }geox; - $$r_str =~ - s/\Q$ESC{ASC}\E - (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox; - $$r_str; -} - -# EUC<->SJIS - -my %_S2E = (); -my %_E2S = (); - -sub sjis_euc { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s( - ($RE{SJIS_C}|$RE{SJIS_KANA}) - ) - { - my $str = $1; - unless ($_S2E{$1}){ - my ($c1, $c2) = unpack('CC', $str); - if (0xa1 <= $c1 && $c1 <= 0xdf) { - $c2 = $c1; - $c1 = 0x8e; - } elsif (0x9f <= $c2) { - $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60); - $c2 += 2; - } else { - $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61); - $c2 += 0x60 + ($c2 < 0x7f); - } - $_S2E{$str} = pack('CC', $c1, $c2); - } - $_S2E{$str}; - }geox; - $$r_str; -} - -# - -sub euc_sjis { - my $thingy = shift; - my $r_str = ref $thingy ? $thingy : \$thingy; - $$r_str =~ s( - ($RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212}) - ) - { - my $str = $1; - unless ($_E2S{$str}){ - my ($c1, $c2) = unpack('CC', $str); - if ($c1 == 0x8e) { # SS2 - $_E2S{$str} = chr($c2); - } elsif ($c1 == 0x8f) { # SS3 - $_E2S{$str} = $CHARCODE{UNDEF_SJIS}; - }else { #SS1 or X0208 - if ($c1 % 2) { - $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); - $c2 -= 0x60 + ($c2 < 0xe0); - } else { - $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); - $c2 -= 2; - } - $_E2S{$str} = pack('CC', $c1, $c2); - } - } - $_E2S{$str}; - }geox; - $$r_str; -} - -# -# Util. Functions -# - -sub _max { - my $result = shift; - for my $n (@_){ - $result = $n if $n > $result; - } - return $result; -} - -1; - -__END__ - -=head1 BUGS - -Unicode support by Jcode is far from efficient! - -=head1 IN FUTURE - -Hopefully Jcode will be superceded by Encode module that is part of -the standard module on Perl 5.7 and up - -=head1 ACKNOWLEDGEMENTS - -This package owes a lot in motivation, design, and code, to the jcode.pl -for Perl4 by Kazumasa Utashiro . - -Hiroki Ohzaki has helped me polish regexp from the -very first stage of development. - -And folks at Jcode Mailing list . Without them, I -couldn't have coded this far. - -=head1 SEE ALSO - -L - -L - -http://www.iana.org/assignments/character-sets - -L - -=head1 COPYRIGHT - -Copyright 1999 Dan Kogai - -This library is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. - -=cut - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:48 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:48 +0900 Subject: [Affelio-cvs 650] CVS update: affelio_farm/admin/skelton/affelio/doc Message-ID: <20051024192048.5F0152AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/doc/application_programming.txt diff -u affelio_farm/admin/skelton/affelio/doc/application_programming.txt:1.1.1.1 affelio_farm/admin/skelton/affelio/doc/application_programming.txt:removed --- affelio_farm/admin/skelton/affelio/doc/application_programming.txt:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/doc/application_programming.txt Tue Oct 25 04:20:48 2005 @@ -1,217 +0,0 @@ -========================================================================= -Affelio Programming Guide -========================================================================= - - CHANGES - ------- - Affelio API 1.0.1 May 12, 2005 - Affelio API 1.0 May 11, 2005 - -1.????ゃ?罕?? -=================== - - affelio/ Affelio????????? - affelio/apps/ ?≪?????若??с?root????????? - - affelio/apps/app1 ???????宴??激??潟??c??????? - affelio/apps/app2 ???????吟??????┃臀???????- ... - - -????≪?????若??с?????????????????ゃ?罕?? - - AF_app.cfg Affelio?≪?????若??с???????荐??file??- 綽?????????ц┃臀?????綽???????? - - 篁ヤ?????≪?????若??с??堺???GI????ゃ???TML????ゃ?????若? - 篆??????c??????????????≪?????若??с?????c??????札筝?- ????????┃臀??羈???????- - foo.cgi Affelio?≪?????若??с???????篏????- bar.html CGI????ゃ???TML????ゃ??????- - data/ ?≪?????若??с??堺?????若?篆??????c???- ???箴??????????????????帥??<??????- Affelio????若?茯?┝??????????劫?緇<???? - ??GI??????茯??莨若?????????????篆<???- ???????喝??????????????贋・????????? - ????????????荀с?????????htaccess??- 荐??????????ィ絅???????- -2.AF_app.cfg -=================== - [this_installation]?祉??激???- - .cfg????ゃ????????祉??激??潟?????≪?????若??с????篁?? - ??┃臀???ゃ??鴻??若?鐚??specific????宴??????????Affelio - ????吟????筝???≪?????若??с??????????????c??????? - 茲??荐?舟?с????????翫???ffelio????吟?????祉??激??潟? - 膩????????????潟??????- - title=篆冴??ヨ? Affelio?脂???????????冴??帥???? - - --------------------------------------------- - - [application]?祉??激???- - application?祉??激??潟?????≪?????若??с?????????? - ????吾??潟?荐??????宴?荐??????????幻篁ヤ?????宴???- ?≪?????若??с?????????????菴違????Affelio????吟? - ??幻膩?????綽???????? - - app_name ?≪?????若??с???- - app_version ????吾??括???- - app_desc ?≪?????若??с???????茯?? - - app_desc ?≪?????若??с??????- - guest_index ?蚊?????????????????吾?????ゃ???- (?蚊???????茵?ず????? - - owner_index ???????????????????若?????<???? - (???????帥??ц;腓冴????) - - action_types comma-separated list of action types. - Each action type is the atomic unit which - Affelio user can control access from other - users (via Affelio control panel). - - action_type_desc comma-separated list of action type - description. - - -3.CGI????ゃ??????????篏?-=================== - - Affelio?≪?????若??с?????????GI????違??????ffelio????若?茯?┝ - ??戎?c??≪??祉??九勝????????????荐怨??????潟???????????????- 菴?拭?????- - 箴????ffelio?≪?????若??с?????????イ腓堺?CGI???????若?????????- ?祉???ffelio????若?茯?┝罘????戎?c?茯?┝???????画Η荐怨??筝???????- ????吟?????≪??祉??с??????イ腓堺???TML????ゃ????????吟???拭??- ????障?????吾?莨若???┗???????≪??祉??с????????若?????????昭 - ?帥?篆???????札筝????????篏?????????宴??激??割???????????????- - CGI????違????罕??????????ffelio?≪?????若??с???????CGI?????- ??????絽吾?CGI????違?????違??????? - - (1)?≪??祉?????吟???ffelio????吟???????????号┤??∈茯?- - (2)Affelio????≪??????就?с?HTML?阪? - - ??????????????????AffelioAPI??????????????違??若??冴???? - ?ц???? - - 鐚??絖??CGI????違????Affelio?≪?????若??с???????篏????- ??????紊??????翫????筝??2?鴻??????申?????????鐚?- - -4.????違?????遺? -=================== - - (apps/sampleapp/index.cgi ????) - - -5. Affelio API -=================== - - Affelio API?????? - ------------------- - - ??ap = new AffelioApp(ConfigDir => Cwd::getcwd(), - cgi => $cgi ); - - IN: ConfigDir ???????宴??激??潟??泣????腟九???? - cgi CGI?吾???? - - OUT: $ap AffelioApp?吾???? - - - Affelio???HTML?潟?????阪????API - ---------------------------------- - - ??str = AffelioApp::get_HTML_header($HTMLtitle); - - IN: $HTMLtitle HTML????ゃ???- - OUT: $str HTML?????(???????? - - - ??str = AffelioApp::get_HTML_footer(); - - OUT: $str HTML?????(????翠??? - - - ?上????????壕?????????????????API - ----------------------------------------- - ??val = AffelioApp::get_visitor_info($info_name); - - IN: $info_name : "nickname" visitor's nickname - "afid" visitor's Affelio_ID (URL) - "type" visitor's type - "self", "f1", "f2", or "pb" - OUT: $val: value - - - ????違??潟?????с??吾?????帥?篆???私?絖??????若????莨?- ---------------------------------------------------------- - - (get) - ??val = AffelioApp::get_session_param($param_name); - - (set) - ??ffelioApp::set_session_param($param_name, $val); - - - Affelio?泣?????≪?????宴???????API - -------------------------------------- - - ??val = AffelioApp::get_site_info($info_name); - - IN: $info_name : "web_root" Affelio??oot URL - - OUT: $val: value - - - ????≪?????若??с??ゃ??鴻??潟?????????????????API - --------------------------------------------------------- - - ??val = AffelioApp::get_app_info($info_name); - - IN: $info_name : "install_title" install title - - OUT: $val: value - - - - Affelio?泣??????????????????????????API - ------------------------------------------------ - - ??val = AffelioApp::get_owner_info($info_name); - - IN: $info_name : "nickname" owner's nickname - "afid" owner's Affelio_ID (URL) - - OUT: $val: value - - - ?上????????壕?????≪?????ц┗???????≪??祉?????鴻?API - ----------------------------------------------------------- - - ??ret = AffelioApp::check_access($action_type); - - IN: $action_type: AF_app.cfg???action_types?????昭??? - ?≪??激??潟?"write", "read" ?????- - ?障????????с?"DF_access"????堺???? - ?≪?????若??с??吾??≪??祉?罔????潟???- AF_app.cfg???腓冴???????Affelio?眼? - ?????????篆???????- - OUT: $ret: 1 or 0 - - -EOF From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:48 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:48 +0900 Subject: [Affelio-cvs 651] CVS update: affelio_farm/admin/skelton/affelio/extlib/CGI Message-ID: <20051024192048.BC3C82AC03A@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session.pm Tue Oct 25 04:20:48 2005 @@ -1,1263 +0,0 @@ -package CGI::Session; - -# $Id: Session.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - - -use strict; -#use diagnostics; -use Carp; -use AutoLoader 'AUTOLOAD'; - -use vars qw($VERSION $REVISION $errstr $IP_MATCH $NAME $API_3 $FROZEN); - -($REVISION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; -$VERSION = '3.95'; -$NAME = 'CGISESSID'; - -# import() - we do not import anything into the callers namespace, however, -# we enable the user to specify hooks at compile time -sub import { - my $class = shift; - @_ or return; - for ( my $i=0; $i < @_; $i++ ) { - $IP_MATCH = ( $_[$i] eq '-ip_match' ) and next; - $API_3 = ( $_[$i] eq '-api3' ) and next; - $FROZEN = ( $_[$i] eq '-frozen' ) and next; - } -} - - -# Session _STATUS flags -sub SYNCED () { 0 } -sub MODIFIED () { 1 } -sub DELETED () { 2 } - - -# new() - constructor. -# Returns respective driver object -sub new { - my $class = shift; - $class = ref($class) || $class; - - my $self = { - _OPTIONS => [ @_ ], - _DATA => undef, - _STATUS => MODIFIED, - _API3 => { }, - _IS_NEW => 0, # to Chris Dolan's request - }; - - if ( $API_3 || (@_ == 3 ) ) { - return $class->api_3(@_); - } - - bless ($self, $class); - $self->_validate_driver() && $self->_init() or return; - return $self; -} - - - - - - - - - - -sub api_3 { - my $class = shift; - $class = ref($class) || $class; - - my $self = { - _OPTIONS => [ $_[1], $_[2] ], - _DATA => undef, - _STATUS => MODIFIED, - _API_3 => { - DRIVER => 'File', - SERIALIZER => 'Default', - ID => 'MD5', - }, - _IS_NEW => 0, # to Chris Dolan's request - }; - - # supporting DSN namme abbreviations: - require Text::Abbrev; - my $dsn_abbrev = Text::Abbrev::abbrev('driver', 'serializer', 'id'); - - if ( defined $_[0] ) { - my @arg_pairs = split (/;/, $_[0]); - for my $arg ( @arg_pairs ) { - my ($key, $value) = split (/:/, $arg) or next; - $key = $dsn_abbrev->{$key}; - $self->{_API_3}->{ uc($key) } = $value || $self->{_API_3}->{uc($key)}; - } - } - - my $driver = "CGI::Session::$self->{_API_3}->{DRIVER}"; - eval "require $driver" or die $@; - - my $serializer = "CGI::Session::Serialize::$self->{_API_3}->{SERIALIZER}"; - eval "require $serializer" or die $@; - - my $id = "CGI::Session::ID::$self->{_API_3}->{ID}"; - eval "require $id" or die $@; - - - # Now re-defining ISA according to what we have above - { - no strict 'refs'; - @{$driver . "::ISA"} = ( $class, $serializer, $id ); - } - - bless ($self, $driver); - $self->_validate_driver() && $self->_init() or return; - return $self; -} - - - -# DESTROY() - destructor. -# Flushes the memory, and calls driver's teardown() -sub DESTROY { - my $self = shift; - - $self->flush() or croak "could not flush: " . $self->error(); - $self->can('teardown') && $self->teardown(); -} - - -# options() - used by drivers only. Returns the driver -# specific options. To be used in the future releases of the -# library, may be -sub driver_options { - my $self = shift; - - return $self->{_OPTIONS}->[1]; -} - -# _validate_driver() - checks driver's validity. -# Return value doesn't matter. If the driver doesn't seem -# to be valid, it croaks -sub _validate_driver { - my $self = shift; - - my @required = qw(store retrieve remove generate_id); - - for my $method ( @required ) { - unless ( $self->can($method) ) { - my $class = ref($self); - confess "$class doesn't seem to be a valid CGI::Session driver. " . - "At least one method ('$method') is missing"; - } - } - return 1; -} - - - - -# _init() - object initialializer. -# Decides between _init_old_session() and _init_new_session() -sub _init { - my $self = shift; - - my $claimed_id = undef; - my $arg = $self->{_OPTIONS}->[0]; - if ( defined ($arg) && ref($arg) ) { - if ( $arg->isa('CGI') ) { - $claimed_id = $arg->cookie($NAME) || $arg->param($NAME) || undef; - $self->{_SESSION_OBJ} = $arg; - } elsif ( ref($arg) eq 'CODE' ) { - $claimed_id = $arg->() || undef; - - } - } else { - $claimed_id = $arg; - } - - if ( defined $claimed_id ) { - my $rv = $self->_init_old_session($claimed_id); - - unless ( $rv ) { - return $self->_init_new_session(); - } - return 1; - } - return $self->_init_new_session(); -} - - - - -# _init_old_session() - tries to retieve the old session. -# If suceeds, checks if the session is expirable. If so, deletes it -# and returns undef so that _init() creates a new session. -# Otherwise, checks if there're any parameters to be expired, and -# calls clear() if any. Aftewards, updates atime of the session, and -# returns true -sub _init_old_session { - my ($self, $claimed_id) = @_; - - my $options = $self->{_OPTIONS} || []; - my $data = $self->retrieve($claimed_id, $options); - - # Session was initialized successfully - if ( defined $data ) { - - $self->{_DATA} = $data; - - # Check if the IP of the initial session owner should - # match with the current user's IP - if ( $IP_MATCH ) { - unless ( $self->_ip_matches() ) { - $self->delete(); - $self->flush(); - return undef; - } - } - - # Check if the session's expiration ticker is up - if ( $self->_is_expired() ) { - $self->delete(); - $self->flush(); - return undef; - } - - # Expring single parameters, if any - $self->_expire_params(); - - # Updating last access time for the session - $self->{_DATA}->{_SESSION_ATIME} = time(); - - # Marking the session as modified - $self->{_STATUS} = MODIFIED; - - return 1; - } - return undef; -} - - - - - -sub _ip_matches { - return ( $_[0]->{_DATA}->{_SESSION_REMOTE_ADDR} eq $ENV{REMOTE_ADDR} ); -} - - - - - -# _is_expired() - returns true if the session is to be expired. -# Called from _init_old_session() method. -sub _is_expired { - my $self = shift; - - unless ( $self->expire() ) { - return undef; - } - - return ( time() >= ($self->expire() + $self->atime() ) ); -} - - - - - -# _expire_params() - expires individual params. Called from within -# _init_old_session() method on a sucessfully retrieved session -sub _expire_params { - my $self = shift; - - # Expiring - my $exp_list = $self->{_DATA}->{_SESSION_EXPIRE_LIST} || {}; - my @trash_can = (); - while ( my ($param, $etime) = each %{$exp_list} ) { - if ( time() >= ($self->atime() + $etime) ) { - push @trash_can, $param; - } - } - - if ( @trash_can ) { - $self->clear(\@trash_can); - } -} - - - - - -# _init_new_session() - initializes a new session -sub _init_new_session { - my $self = shift; - - my $currtime = time(); - $self->{_DATA} = { - _SESSION_ID => $self->generate_id($self->{_OPTIONS}), - _SESSION_CTIME => $currtime, - _SESSION_ATIME => $currtime, - _SESSION_ETIME => undef, - _SESSION_REMOTE_ADDR => $ENV{REMOTE_ADDR} || undef, - _SESSION_EXPIRE_LIST => { }, - }; - - # to Chris Dolan's request: - # I'm not sure if this information should be serialized (placed under _DATA), - # but I don't see any desperate need for it. So let it be part of the object - $self->{_IS_NEW} = 1; - - $self->{_STATUS} = MODIFIED; - - return 1; -} - - - - -# id() - accessor method. Returns effective id -# for the current session. CGI::Session deals with -# two kinds of ids; effective and claimed. Claimed id -# is the one passed to the constructor - new() as the first -# argument. It doesn't mean that id() method returns that -# particular id, since that ID might be either expired, -# or even invalid, or just data associated with that id -# might not be available for some reason. In this case, -# claimed id and effective id are not the same. -sub id { - my $self = shift; - - return $self->{_DATA}->{_SESSION_ID}; -} - - - -# param() - accessor method. Reads and writes -# session parameters ( $self->{_DATA} ). Decides -# between _get_param() and _set_param() accordingly. -sub param { - my $self = shift; - - - unless ( defined $_[0] ) { - return keys %{ $self->{_DATA} }; - } - - if ( @_ == 1 ) { - return $self->_get_param(@_); - } - - # If it has more than one arguments, let's try to figure out - # what the caller is trying to do, since our tricks are endless ;-) - my $arg = { - -name => undef, - -value => undef, - @_, - }; - - if ( defined($arg->{'-name'}) && defined($arg->{'-value'}) ) { - return $self->_set_param($arg->{'-name'}, $arg->{'-value'}); - - } - - if ( defined $arg->{'-name'} ) { - return $self->_get_param( $arg->{'-name'} ); - } - - if ( @_ == 2 ) { - return $self->_set_param(@_); - } - - unless ( @_ % 2 ) { - my $n = 0; - my %args = @_; - while ( my ($key, $value) = each %args ) { - $self->_set_param($key, $value) && ++$n; - } - return $n; - } - - confess "param(): something smells fishy here. RTFM!"; -} - - - -# _set_param() - sets session parameter to the '_DATA' table -sub _set_param { - my ($self, $key, $value) = @_; - - if ( $self->{_STATUS} == DELETED ) { - return; - } - - # session parameters starting with '_session_' are - # private to the class - if ( $key =~ m/^_SESSION_/ ) { - return undef; - } - - $self->{_DATA}->{$key} = $value; - $self->{_STATUS} = MODIFIED; - - return $value; -} - - - - -# _get_param() - gets a single parameter from the -# '_DATA' table -sub _get_param { - my ($self, $key) = @_; - - if ( $self->{_STATUS} == DELETED ) { - return; - } - - return $self->{_DATA}->{$key}; -} - - -# flush() - flushes the memory into the disk if necessary. -# Usually called from within DESTROY() or close() -sub flush { - my $self = shift; - - my $status = $self->{_STATUS}; - - if ( $status == MODIFIED ) { - $self->store($self->id, $self->{_OPTIONS}, $self->{_DATA}) or return; - } elsif ( $status == DELETED ) { - $self->remove($self->id, $self->{_OPTIONS}) or return; - } - $self->{_STATUS} = SYNCED; - return 1; -} - - - - - -# Autoload methods go after =cut, and are processed by the autosplit program. - -1; - -__END__; - - -# $Id: Session.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -=pod - -=head1 NAME - -CGI::Session - persistent session data in CGI applications - -=head1 SYNOPSIS - - # Object initialization: - use CGI::Session; - - my $session = new CGI::Session("driver:File", undef, {Directory=>'/tmp'}); - - # getting the effective session id: - my $CGISESSID = $session->id(); - - # storing data in the session - $session->param('f_name', 'Sherzod'); - # or - $session->param(-name=>'l_name', -value=>'Ruzmetov'); - - # retrieving data - my $f_name = $session->param('f_name'); - # or - my $l_name = $session->param(-name=>'l_name'); - - # clearing a certain session parameter - $session->clear(["_IS_LOGGED_IN"]); - - # expire '_IS_LOGGED_IN' flag after 10 idle minutes: - $session->expire(_IS_LOGGED_IN => '+10m') - - # expire the session itself after 1 idle hour - $session->expire('+1h'); - - # delete the session for good - $session->delete(); - -=head1 DESCRIPTION - -CGI-Session is a Perl5 library that provides an easy, reliable and modular -session management system across HTTP requests. Persistency is a key feature for -such applications as shopping carts, login/authentication routines, and -application that need to carry data accross HTTP requests. CGI::Session -does that and many more - -=head1 TO LEARN MORE - -Current manual is optimized to be used as a quick reference. To learn more both about the logic behind session management and CGI::Session programming style, consider the following: - -=over 4 - -=item * - -L - extended CGI::Session manual. Also includes library architecture and driver specifications. - -=item * - -L - practical solutions for real life problems - -=item * - -We also provide mailing lists for CGI::Session users. To subscribe to the list or browse the archives visit https://lists.sourceforge.net/lists/listinfo/cgi-session-user - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=head1 METHODS - -Following is the overview of all the available methods accessible via -CGI::Session object. - -=over 4 - -=item C - -Requires three arguments. First is the Data Source Name, second should be -the session id to be initialized or an object which provides either of 'param()' -or 'cookie()' mehods. If Data Source Name is undef, it will fall back -to default values, which are "driver:File;serializer:Default;id:MD5". - -If session id is missing, it will force the library to generate a new session -id, which will be accessible through C method. - -Examples: - - $session = new CGI::Session(undef, undef, {Directory=>'/tmp'}); - $session = new CGI::Session("driver:File;serializer:Storable", undef, {Directory=>'/tmp'}) - $session = new CGI::Session("driver:MySQL;id:Incr", undef, {Handle=>$dbh}); - -Following data source variables are supported: - -=over 4 - -=item * - -C - CGI::Session driver. Available drivers are "File", "DB_File" and -"MySQL". Default is "File". - -=item * - -C - serializer to be used to encode the data structure before saving -in the disk. Available serializers are "Storable", "FreezeThaw" and "Default". -Default is "Default", which uses standard L - -=item * - -C - ID generator to use when new session is to be created. Available ID generators -are "MD5" and "Incr". Default is "MD5". - -=back - -Note: you can also use unambiguous abbreviations of the DSN parameters. Examples: - - new CGI::Session("dr:File;ser:Storable", undef, {Diretory=>'/tmp'}); - - -=item C - -Returns effective ID for a session. Since effective ID and claimed ID -can differ, valid session id should always be retrieved using this -method. - -=item C - -=item C$name)> - -this method used in either of the above syntax returns a session -parameter set to C<$name> or undef on failure. - -=item C - -=item C$name, -value=E$value)> - -method used in either of the above syntax assigns a new value to $name -parameter, which can later be retrieved with previously introduced -param() syntax. - -=item C - -returns all the session parameters as a reference to a hash - - -=item C - -=item C - -Saves CGI parameters to session object. In otherwords, it's calling -C for every single CGI parameter. The first -argument should be either CGI object or any object which can provide -param() method. If second argument is present and is a reference to an array, only those CGI parameters found in the array will -be stored in the session - -=item C - -=item C - -loads session parameters to CGI object. The first argument is required -to be either CGI.pm object, or any other object which can provide -param() method. If second argument is present and is a reference to an -array, only the parameters found in that array will be loaded to CGI -object. - -=item C - -=item C - -experimental feature. Synchronizes CGI and session objects. In other words, it's the same as calling respective syntaxes of save_param() and load_param(). - -=item C - -=item C - -clears parameters from the session object. If passed an argument as an -arrayref, clears only those parameters found in the list. - -=item C - -synchronizes data in the buffer with its copy in disk. Normally it will -be called for you just before the program terminates, session object -goes out of scope or close() is called. - -=item C - -closes the session temporarily until new() is called on the same session -next time. In other words, it's a call to flush() and DESTROY(), but -a lot slower. Normally you never have to call close(). - -=item C - -returns the last access time of the session in the form of seconds from -epoch. This time is used internally while auto-expiring sessions and/or session parameters. - -=item C - -returns the time when the session was first created. - -=item C - -=item C - -=item C - -Sets expiration date relative to atime(). If used with no arguments, returns the expiration date if it was ever set. If no expiration was ever set, returns undef. - -Second form sets an expiration time. This value is checked when previously stored session is asked to be retrieved, and if its expiration date has passed will be expunged from the disk immediately and new session is created accordingly. Passing 0 would cancel expiration date. - -By using the third syntax you can also set an expiration date for a -particular session parameter, say "~logged-in". This would cause the -library call clear() on the parameter when its time is up. - -All the time values should be given in the form of seconds. Following -time aliases are also supported for your convenience: - - +===========+===============+ - | alias | meaning | - +===========+===============+ - | s | Second | - | m | Minute | - | h | Hour | - | w | Week | - | M | Month | - | y | Year | - +-----------+---------------+ - -Examples: - - $session->expires("+1y"); # expires in one year - $session->expires(0); # cancel expiration - $session->expires("~logged-in", "+10m");# expires ~logged-in flag in 10 mins - -Note: all the expiration times are relative to session's last access time, not to its creation time. To expire a session immediately, call C. To expire a specific session parameter immediately, call C on that parameter. - -=item C - -returns the remote address of the user who created the session for the -first time. Returns undef if variable REMOTE_ADDR wasn't present in the -environment when the session was created - -=item C - -deletes the session from the disk. In other words, it calls for -immediate expiration after which the session will not be accessible - -=item C - -returns the last error message from the library. It's the same as the -value of $CGI::Session::errstr. Example: - - $session->flush() or die $session->error(); - -=item C - -=item C - -creates a dump of the session object. Argument, if passed, will be -interpreted as the name of the file object should be dumped in. Used -mostly for debugging. - -=item C - -header() is simply a replacement for L's header() method. Without this method, you usually need to create a CGI::Cookie object and send it as part of the HTTP header: - - $cookie = new CGI::Cookie(-name=>'CGISESSID', -value=>$session->id); - print $cgi->header(-cookie=>$cookie); - -You can minimize the above into: - - $session->header() - -It will retrieve the name of the session cookie from $CGI::Session::NAME variable, which can also be accessed via CGI::Session->name() method. If you want to use a different name for your session cookie, do something like following before creating session object: - - CGI::Session->name("MY_SID"); - $session = new CGI::Session(undef, $cgi, \%attrs); - -Now, $session->header() uses "MY_SID" as a name for the session cookie. - -=back - -=head1 DATA TABLE - -Session data is stored in the form of hash table, in key value pairs. -All the parameter names you assign through param() method become keys -in the table, and whatever value you assign become a value associated with -that key. Every key/value pair is also called a record. - -All the data you save through param() method are called public records. -There are several read-only private records as well. Normally, you don't have to know anything about them to make the best use of the library. But knowing wouldn't hurt either. Here are the list of the private records and some description of what they hold: - -=over 4 - -=item _SESSION_ID - -Session id of that data. Accessible through id() method. - -=item _SESSION_CTIME - -Session creation time. Accessible through ctime() method. - -=item _SESSION_ATIME - -Session last access time. Accessible through atime() method. - -=item _SESSION_ETIME - -Session's expiration time, if any. Accessible through expire() method. - -=item _SESSION_REMOTE_ADDR - -IP address of the user who create that session. Accessible through remote_addr() -method - -=item _SESSION_EXPIRE_LIST - -Another internal hash table that holds the expiration information for each -expirable public record, if any. This table is updated with the two-argument-syntax of expires() method. - -=back - -These private methods are essential for the proper operation of the library -while working with session data. For this purpose, CGI::Session doesn't allow -overriding any of these methods through the use of param() method. In addition, -it doesn't allow any parameter names that start with string B<_SESSION_> either -to prevent future collisions. - -So the following attempt will have no effect on the session data whatsoever - - $session->param(_SESSION_XYZ => 'xyz'); - -Although private methods are not writable, the library allows reading them -using param() method: - - my $sid = $session->param(_SESSION_ID); - -The above is the same as: - - my $sid = $session->id(); - -But we discourage people from accessing private records using param() method. -In the future we are planning to store private records in their own namespace -to avoid name collisions and remove restrictions on session parameter names. - -=head1 DISTRIBUTION - -CGI::Session consists of several modular components such as L, L and L. This section lists what is available. - -=head2 DRIVERS - -Following drivers are included in the standard distribution: - -=over 4 - -=item * - -L - default driver for storing session data in plain files. Full name: B - -=item * - -L - for storing session data in BerkelyDB. Requires: L. Full name: B - -=item * - -L - for storing session data in MySQL tables. Requires L and L. Full name: B - -=back - -=head2 SERIALIZERS - -=over 4 - -=item * - -L - default data serializer. Uses standard L. Full name: B. - -=item * - -L - serializes data using L. Requires L. Full name: B. - -=item * - -L - serializes data using L. Requires L. Full name: B - -=back - -=head2 ID GENERATORS - -Following ID generators are available: - -=over 4 - -=item * - -L - generates 32 character long hexidecimal string. -Requires L. Full name: B. - -=item * - -L - generates auto-incrementing ids. Full name: B - -=back - - -=head1 COPYRIGHT - -Copyright (C) 2001-2002 Sherzod Ruzmetov . All rights reserved. - -This library is free software. You can modify and or distribute it under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov . Feedbacks, suggestions are welcome. - -=head1 SEE ALSO - -=over 4 - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - -# dump() - dumps the session object using Data::Dumper. -# during development it defines global dump(). -sub dump { - my ($self, $file, $indent) = @_; - - require Data::Dumper; - local $Data::Dumper::Indent = $indent || 2; - - my $d = new Data::Dumper([$self], [ref $self]); - - if ( defined $file ) { - unless ( open(FH, '<' . $file) ) { - unless(open(FH, '>' . $file)) { - $self->error("Couldn't open $file: $!"); - return undef; - } - print FH $d->Dump(); - unless ( CORE::close(FH) ) { - $self->error("Couldn't dump into $file: $!"); - return undef; - } - } - } - return $d->Dump(); -} - - - -sub version { return $VERSION } - - -# delete() - sets the '_STATUS' session flag to DELETED, -# which flush() uses to decide to call remove() method on driver. -sub delete { - my $self = shift; - - # If it was already deleted, make a confession! - if ( $self->{_STATUS} == DELETED ) { - confess "delete attempt on deleted session"; - } - - $self->{_STATUS} = DELETED; -} - - - - - -# clear() - clears a list of parameters off the session's '_DATA' table -sub clear { - my $self = shift; - $class = ref($self); - - my @params = (); - - # if there was at least one argument, we take it as a list - # of params to delete - if ( @_ ) { - @params = ref($_[0]) ? @{ $_[0] } : ($_[0]); - } else { - @params = $self->param(); - } - - my $n = 0; - for ( @params ) { - /^_SESSION_/ and next; - # If this particular parameter has an expiration ticker, - # remove it. - if ( $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$_} ) { - delete ( $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$_} ); - } - delete ($self->{_DATA}->{$_}) && ++$n; - } - - # Set the session '_STATUS' flag to MODIFIED - $self->{_STATUS} = MODIFIED; - - return $n; -} - - -# save_param() - copies a list of third party object parameters -# into CGI::Session object's '_DATA' table -sub save_param { - my ($self, $cgi, $list) = @_; - - unless ( ref($cgi) ) { - confess "save_param(): first argument should be an object"; - - } - unless ( $cgi->can('param') ) { - confess "save_param(): Cannot call method param() on the object"; - } - - my @params = (); - if ( defined $list ) { - unless ( ref($list) eq 'ARRAY' ) { - confess "save_param(): second argument must be an arrayref"; - } - - @params = @{ $list }; - - } else { - @params = $cgi->param(); - - } - - my $n = 0; - for ( @params ) { - # It's imporatnt to note that CGI.pm's param() returns array - # if a parameter has more values associated with it (checkboxes - # and crolling lists). So we should access its parameters in - # array context not to miss anything - my @values = $cgi->param($_); - - if ( defined $values[1] ) { - $self->_set_param($_ => \@values); - - } else { - $self->_set_param($_ => $values[0] ); - - } - - ++$n; - } - - return $n; -} - - -# load_param() - loads a list of third party object parameters -# such as CGI, into CGI::Session's '_DATA' table -sub load_param { - my ($self, $cgi, $list) = @_; - - unless ( ref($cgi) ) { - confess "save_param(): first argument must be an object"; - - } - unless ( $cgi->can('param') ) { - my $class = ref($cgi); - confess "save_param(): Cannot call method param() on the object $class"; - } - - my @params = (); - if ( defined $list ) { - unless ( ref($list) eq 'ARRAY' ) { - confess "save_param(): second argument must be an arrayref"; - } - @params = @{ $list }; - - } else { - @params = $self->param(); - - } - - my $n = 0; - for ( @params ) { - $cgi->param(-name=>$_, -value=>$self->_get_param($_)); - } - return $n; -} - - - - -# another, but a less efficient alternative to undefining -# the object -sub close { - my $self = shift; - - $self->DESTROY(); -} - - - -# error() returns/sets error message -sub error { - my ($self, $msg) = @_; - - if ( defined $msg ) { - $errstr = $msg; - } - - return $errstr; -} - - -# errstr() - alias to error() -sub errstr { - my $self = shift; - - return $self->error(@_); -} - - - -# atime() - rerturns session last access time -sub atime { - my $self = shift; - - if ( @_ ) { - confess "_SESSION_ATIME - read-only value"; - } - - return $self->{_DATA}->{_SESSION_ATIME}; -} - - -# ctime() - returns session creation time -sub ctime { - my $self = shift; - - if ( @_ ) { - confess "_SESSION_ATIME - read-only value"; - } - - return $self->{_DATA}->{_SESSION_CTIME}; -} - - -# expire() - sets/returns session/parameter expiration ticker -sub expire { - my $self = shift; - - unless ( @_ ) { - return $self->{_DATA}->{_SESSION_ETIME}; - } - - if ( @_ == 1 ) { - return $self->{_DATA}->{_SESSION_ETIME} = _time_alias( $_[0] ); - } - - # If we came this far, we'll simply assume user is trying - # to set an expiration date for a single session parameter. - my ($param, $etime) = @_; - - # Let's check if that particular session parameter exists - # in the '_DATA' table. Otherwise, return now! - defined ($self->{_DATA}->{$param} ) || return; - - if ( $etime eq '-1' ) { - delete $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$param}; - $self->{_STATUS} = MODIFIED; - return; - } - - $self->{_DATA}->{_SESSION_EXPIRE_LIST}->{$param} = _time_alias( $etime ); -} - - -# expires() - alias to expire(). For backward compatibility -sub expires { - return expire(@_); -} - - -# parses such strings as '+1M', '+3w', accepted by expire() -sub _time_alias { - my ($str) = @_; - - # If $str consists of just digits, return them as they are - if ( $str =~ m/^\d+$/ ) { - return $str; - } - - my %time_map = ( - s => 1, - m => 60, - h => 3600, - d => 86400, - w => 604800, - M => 2592000, - y => 31536000 - ); - - my ($koef, $d) = $str =~ m/^([+-]?\d+)(\w)$/; - - if ( defined($koef) && defined($d) ) { - return $koef * $time_map{$d}; - } -} - - -# remote_addr() - returns ip address of the session -sub remote_addr { - my $self = shift; - - return $self->{_DATA}->{_SESSION_REMOTE_ADDR}; -} - - -# param_hashref() - returns parameters as a reference to a hash -sub param_hashref { - my $self = shift; - - return $self->{_DATA}; -} - - -# name() - returns the cookie name associated with the session id -sub name { - my ($class, $name) = @_; - - if ( defined $name ) { - $CGI::Session::NAME = $name; - } - - return $CGI::Session::NAME; -} - - -# header() - replacement for CGI::header() method -sub header { - my $self = shift; - - my $cgi = $self->{_SESSION_OBJ}; - unless ( defined $cgi ) { - require CGI; - $self->{_SESSION_OBJ} = CGI->new(); - return $self->header(); - } - - my $cookie = $cgi->cookie($self->name(), $self->id() ); - - return $cgi->header( - -type => 'text/html', - -cookie => $cookie, - @_ - ); -} - - -# sync_param() - synchronizes CGI and Session parameters. -sub sync_param { - my ($self, $cgi, $list) = @_; - - unless ( ref($cgi) ) { - confess("$cgi doesn't look like an object"); - } - - unless ( $cgi->UNIVERSAL::can('param') ) { - confess(ref($cgi) . " doesn't support param() method"); - } - - # we first need to save all the available CGI parameters to the - # object - $self->save_param($cgi, $list); - - # we now need to load all the parameters back to the CGI object - return $self->load_param($cgi, $list); -} - - -# to Chris Dolan's request -sub is_new { - my $self = shift; - - return $self->{_IS_NEW}; -} - -# $Id: Session.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:43 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:43 +0900 Subject: [Affelio-cvs 620] CVS update: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case Message-ID: <20051024192043.5BED42AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Lower.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Lower.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Lower.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Lower.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Lower.pm Tue Oct 25 04:20:43 2005 @@ -1,93 +0,0 @@ - -package Hash::Case::Lower; -use base 'Hash::Case'; - -$VERSION = 1.003; - -use strict; -use Carp; - -=head1 NAME - -Hash::Case::Lower - hash with enforced lower cased keys - -=head1 CLASS HIERARCHY - - Hash::Case::Lower - is a Hash::Case - is a Tie::StdHash - is a Tie::Hash - -=head1 SYNOPSIS - - use Hash::Case::Lower; - tie my(%lchash), 'Hash::Case::Lower'; - $lchash{StraNGeKeY} = 3; - print keys %lchash; # strangekey - -=head1 DESCRIPTION - -Hash::Case::Lower extends Hash::Case, which lets you play various trics -with hash keys. See L for the other implementations. - -=head1 METHODS - -=over 4 - -=cut - -#------------------------------------------- - -=item tie HASH, 'Hash::Case::Lower', [VALUES,] OPTIONS - -Define HASH to have only lower cased keys. The hash is -initialized with the VALUES, specified as ref-array or -ref-hash. Currently, there are no OPTIONS defined. - -=cut - -sub init($) -{ my ($self, $args) = @_; - - $self->SUPER::native_init($args); - - croak "No options possible for ".__PACKAGE__ - if keys %$args; - - $self; -} - -#------------------------------------------- - -sub FETCH($) { $_[0]->{lc $_[1]} } -sub STORE($$) { $_[0]->{lc $_[1]} = $_[2] } -sub EXISTS($) { exists $_[0]->{lc $_[1]} } -sub DELETE($) { delete $_[0]->{lc $_[1]} } - -#------------------------------------------- - -=back - -=head1 SEE ALSO - -L -L -L - -=head1 AUTHOR - -Mark Overmeer (F). -All rights reserved. This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 VERSION - -This code is beta, version 1.003 - -Copyright (c) 2002-2003 Mark Overmeer. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -1; Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Preserve.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Preserve.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Preserve.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Preserve.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Preserve.pm Tue Oct 25 04:20:43 2005 @@ -1,150 +0,0 @@ - - -package Hash::Case::Preserve; -use base 'Hash::Case'; - -$VERSION = 1.003; - -use strict; -use Carp; - -=head1 NAME - -Hash::Case::Preserve - hash with enforced lower cased keys - -=head1 CLASS HIERARCHY - - Hash::Case::Preserve - is a Hash::Case - is a Tie::StdHash - is a Tie::Hash - -=head1 SYNOPSIS - - use Hash::Case::Preserve; - tie my(%cphash), 'Hash::Case::Preserve'; - $cphash{StraNGeKeY} = 3; - print keys %cphash; # StraNGeKeY - print $cphash{strangekey}; # 3 - print $cphash{STRANGEKEY}; # 3 - -=head1 DESCRIPTION - -Hash::Case::Preserve extends Hash::Case, which lets you play various trics -with hash keys. See L for the other implementations. - -=head1 METHODS - -=over 4 - -=cut - -#------------------------------------------- - -=item tie HASH, 'Hash::Case::Preserve', [VALUES,] OPTIONS - -Define HASH to be case insensitive, but case preserving. -The hash is initialized with the VALUES, specified as ref-array or -ref-hash. - -OPTIONS is a list of key/value pairs, which specify how the hash -must handle preservation. Current options: - -=over 4 - -=item * keep =E 'FIRST' | 'LAST' - -Which casing is the prefered casing? The FIRST appearance or the LAST. -Only stores will affect the casing, deletes will undo the definition. -Defaults to LAST, which is slightly faster. - -=cut - -sub init($) -{ my ($self, $args) = @_; - - $self->{HCP_data} = {}; - $self->{HCP_keys} = {}; - - my $keep = $args->{keep} || 'LAST'; - if($keep eq 'LAST') { $self->{HCP_update} = 1 } - elsif($keep eq 'FIRST') { $self->{HCP_update} = 0 } - else - { croak "Use 'FIRST' or 'LAST' with the option keep.\n"; - } - - $self->SUPER::native_init($args); -} - -#------------------------------------------- - -# Maintain two hashes within this object: one to store the values, and -# one to preserve the casing. The main object also stores the options. -# The data is kept under lower cased keys. - -sub FETCH($) { $_[0]->{HCP_data}{lc $_[1]} } - -sub STORE($$) -{ my ($self, $key, $value) = @_; - my $lckey = lc $key; - - $self->{HCP_keys}{$lckey} = $key - if $self->{HCP_update} || !exists $self->{HCP_keys}{$lckey}; - - $self->{HCP_data}{$lckey} = $value; -} - -sub FIRSTKEY -{ my $self = shift; - my $a = scalar keys %{$self->{HCP_keys}}; - $self->NEXTKEY; -} - -sub NEXTKEY($) -{ my $self = shift; - if(my ($k, $v) = each %{$self->{HCP_keys}}) - { return wantarray ? ($v, $self->{HCP_data}{$k}) : $v; - } - else { return () } -} - -sub EXISTS($) { exists $_[0]->{HCP_data}{lc $_[1]} } - -sub DELETE($) -{ my $lckey = lc $_[1]; - delete $_[0]->{HCP_keys}{$lckey}; - delete $_[0]->{HCP_data}{$lckey}; -} - -sub CLEAR() -{ %{$_[0]->{HCP_data}} = (); - %{$_[0]->{HCP_keys}} = (); -} - -#------------------------------------------- - -=back - -=head1 SEE ALSO - -L -L -L - -=head1 AUTHOR - -Mark Overmeer (F). -All rights reserved. This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 VERSION - -This code is beta, version 1.003 - -Copyright (c) 2002-2003 Mark Overmeer. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -1; Index: affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Upper.pm diff -u affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Upper.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Upper.pm:removed --- affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Upper.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/apps/Mixi/extlib/Hash/Case/Upper.pm Tue Oct 25 04:20:43 2005 @@ -1,93 +0,0 @@ - -package Hash::Case::Upper; -use base 'Hash::Case'; - -$VERSION = 1.003; - -use Carp; -use strict; - -=head1 NAME - -Hash::Case::Upper - native hash with enforced lower cased keys - -=head1 CLASS HIERARCHY - - Hash::Case::Upper - is a Hash::Case - is a Tie::StdHash - is a Tie::Hash - -=head1 SYNOPSIS - - use Hash::Case::Upper; - tie my(%uchash), 'Hash::Case::Upper'; - $uchash{StraNGeKeY} = 3; - print keys %uchash; # STRANGEKEY - -=head1 DESCRIPTION - -Hash::Case::Upper extends Hash::Case, which lets you play various trics -with hash keys. See L for the other implementations. - -=head1 METHODS - -=over 4 - -=cut - -#------------------------------------------- - -=item tie HASH, 'Hash::Case::Upper', [VALUES,] OPTIONS - -Define HASH to have only upper cased keys. The hash is -initialized with the VALUES, specified as ref-array or -ref-hash. Currently, there are no OPTIONS defined. - -=cut - -sub init($) -{ my ($self, $args) = @_; - - $self->SUPER::native_init($args); - - croak "No options available for ".__PACKAGE__ - if keys %$args; - - $self; -} - -#------------------------------------------- - -sub FETCH($) { $_[0]->{uc $_[1]} } -sub STORE($$) { $_[0]->{uc $_[1]} = $_[2] } -sub EXISTS($) { exists $_[0]->{uc $_[1]} } -sub DELETE($) { delete $_[0]->{uc $_[1]} } - -#------------------------------------------- - -=back - -=head1 SEE ALSO - -L -L -L - -=head1 AUTHOR - -Mark Overmeer (F). -All rights reserved. This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -=head1 VERSION - -This code is beta, version 1.003 - -Copyright (c) 2002-2003 Mark Overmeer. All rights reserved. -This program is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:48 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:48 +0900 Subject: [Affelio-cvs 652] CVS update: affelio_farm/admin/skelton/affelio/extlib/CGI/Session Message-ID: <20051024192048.F24532AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/BluePrint.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/BluePrint.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/BluePrint.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/BluePrint.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/BluePrint.pm Tue Oct 25 04:20:48 2005 @@ -1,124 +0,0 @@ -package CGI::Session::BluePrint; - -# $Id: BluePrint.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use base qw( - CGI::Session - CGI::Session::ID::MD5 - CGI::Session::Serialize::Default -); - - -# Load neccessary libraries below - -use vars qw($VERSION); - -$VERSION = '0.1'; - -sub store { - my ($self, $sid, $options, $data) = @_; - - my $storable_data = $self->freeze($data); - - #now you need to store the $storable_data into the disk - -} - - -sub retrieve { - my ($self, $sid, $options) = @_; - - # you will need to retrieve the stored data, and - # deserialize it using $self->thaw() method -} - - - -sub remove { - my ($self, $sid, $options) = @_; - - # you simply need to remove the data associated - # with the id - - -} - - - -sub teardown { - my ($self, $sid, $options) = @_; - - # this is called just before session object is destroyed -} - - - - -# $Id: BluePrint.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -1; - -=pod - -=head1 NAME - -CGI::Session::BluePrint - Default CGI::Session driver BluePrint - -=head1 SYNOPSIS - - use CGI::Session::BluePrint - $session = new CGI::Session("driver:BluePrint", undef, {...}); - -For more examples, consult L manual - -=head1 DESCRIPTION - -CGI::Session::BluePrint is a CGI::Session driver. -To write your own drivers for B refere L manual. - -=head1 COPYRIGHT - -Copyright (C) 2002 Your Name. All rights reserved. - -This library is free software and can be modified and distributed under the same -terms as Perl itself. - -=head1 AUTHOR - -Your name - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - - -# $Id: BluePrint.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/CookBook.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/CookBook.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/CookBook.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/CookBook.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/CookBook.pm Tue Oct 25 04:20:48 2005 @@ -1,650 +0,0 @@ -# $Id: CookBook.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package CGI::Session::CookBook; - -use vars ('$VERSION'); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - -1; - -__END__; - -=pod - -=head1 NAME - -CookBook - tutorial on session management in cgi applications - -=head1 NOTE - -This document is under construction. - -=head1 DESCRIPTION - -C is a tutorial that accompanies B -distribution. It shows the usage of the library in web applications and -demonstrates practical solutions for certain problems. We do not recommend you -to read this tutorial unless you're familiar with L -and it's syntax. - -=head1 CONVENTIONS - -To avoid unnecessary redundancy, in all the examples that follow we assume -the following session and cgi objects: - - use CGI::Session; - use CGI; - - my $cgi = new CGI; - my $session = new CGI::Session(undef, $cgi, {Directory=>'/tmp'}); - -Although we are using default B in our examples, you feel free to -use any configuration you please. - -After initializing the session, we should "mark" the user with that ID. -We use HTTP Cookies to do it: - - $cookie = $cgi->cookie(CGISESSID => $session->id ); - print $cgi->header(-cookie=>$cookie); - -The first line is creating a cookie using B's C -method. The second line is sending the cookie to the user's browser -using B's C method. - -After the above confessions, we can move to some examples with a less -guilty conscious. - -=head1 STORING THE USER'S NAME - -=head2 PROBLEM - -We have a form in our site that asks for user's name and email address. -We want to store the data so that we can greet the user when he/she -visits the site next time ( possibly after several days or even weeks ). - -=head2 SOLUTION - -Although quite simple and straight forward it seems, variations of this -example are used in more robust session managing tricks. - -Assuming the name of the form input fields are called "first_name" and -"email" respectively, we can first retrieve this information from the -cgi parameter. Using B this can be achieved in the following -way: - - $first_name = $cgi->param("first_name"); - $email = $cgi->param("email"); - -After having the above two values from the form handy, we can now save -them in the session like: - - $session->param(first_name, $first_name); - $session->param(email, $email); - -If the above 4-line solution seems long for you (it does to me), you can -achieve it with a single line of code: - - $session->save_param($cgi, ["first_name", "email"]); - -The above syntax will get "first_name" and "email" parameters from the -B and saves them to the B object.Now some other -time or even in some other place we can simply say - - $name = $session->param("first_name"); - print "$name, I know it's you. Confess!"; - -and it does surprise him ( if not scare :) ) - -=head1 REMEMBER THE REFERER - -=head2 PROBLEM - -You run an outrourcing service, and people get refered to your program -from other sites. After finishing the process, which might take several -click-throughs, you need to provide them with a link which takes them to -a site where they came from. In other words, after 10 clicks through -your pages you need to recall the referered link, which takes the user -to your site. - -=head2 SOLUTION - -This solution is similar to the previous one, but instead of getting the -data from the submitted form, you get it from HTTP_REFERER environmental -variable, which holds the link to the refered page. But you should be -cautious, because the click on your own page to the same application -generates a referal as well, in this case with your own link. So you -need to watchout for that by saving the link only if it doesn't already -exist. This approach is suitable for the application which ALWAYS get -accessed by clicking links and posting forms, but NOT by typing in the -url. Good examples would be voting polls, shopping carts among many -others. - - $ENV{HTTP_REFERER} or die "Illegal use"; - - unless ( $session->param("referer") ) { - $session->param("referer", $ENV{HTTP_REFERER}); - } - -In the above code, we simply save the referer in the session under the -"referer" parameter. Note, that we first check if it was previously -saved, in which case there would be no need to override it. It also -means, if the referer was not saved previously, it's most likely the -first visit to the page, and the HTTP_REFERER holds the link to the link -we're interested in, not our own. - -When we need to present the link back to the refered site, we just do: - - $href = $session->param("referer"); - print qq~go back~; - -=head1 BROWSING HISTORY - -=head2 PROBLEM - -You have an online store with about a dozen categories and thousands of -items in each category. When a visitor is surfing the site, you want to -display the last 10-20 visited pages/items on the left menu of the site -( for examples of this refer to Amazon.com ). This will make the site -more usable and a lot friendlier - -=head2 SOLUTION - -The solution might vary on the way you implement the application. Here -we'll show an example of the user's browsing history, where it shows -just visited links and the pages' titles. For obvious reasons we build -the array of the link=>title relationship. If you have a dynamicly -generated content, you might have a slicker way of doing it. Despite the -fact your implementation might be different, this example shows how to -store a complex data structure in the session parameter. It's a blast! - - %pages = ( - "Home" => "http://www.ultracgis.com", - "About us" => "http://www.ultracgis.com/about", - "Contact" => "http://www.ultracgis.com/contact", - "Products" => "http://www.ultracgis.com/products", - "Services" => "http://www.ultracgis.com/services", - "Portfolio" => "http://www.ultracgis.com/pfolio", - # ... - ); - - # Get a url of the page loaded - $link = $ENV{REQUEST_URI} or die "Errr. What the hack?!"; - - # get the previously saved arrayref from the session parameter - # named "HISTORY" - $history = $session->param("HISTORY") || []; - - # push()ing a hashref to the arrayref - push (@{$history}, {title => $pages{ $link }, - link => $link }); - - # storing the modified history back in the session - $session->param( "HISTORY", $history ); - - -What we want you to notice is the $history, which is a reference to an -array, elements of which consist of references to anonymous hashes. This -example illustrates that one can safely store complex data structures, -including objects, in the session and they can be re-created for you the -way they were once stored. - -Displaying the browsing history should be even more straight-forward: - - # we first get the history information from the session - $history = $session->param("HISTORY") || []; - - print qq~
Your recently viewed pages
~; - - for $page ( @{ $history } ) { - print qq~$page->{title}
~; - } - -If you use B, to access the above history in your -templates simply C the $session object with that of -B: - - $template = new HTML::Template(filename=>"some.tmpl", -associate=>$session ); - -Now in your "some.tmpl" template you can access the above history like -so: - - - - - - - - - - - -
last visited pages
- -
- - -and this will print the list in nicely formated table. For more -information on associating an object with the B refer to -L - -=head1 SHOPPING CART - -=head2 PROBLEM - -You have a site that lists the available products off the database. You -need an application that would enable users' to "collect" items for -checkout, in other words, to put into a virtual shopping cart. When they -are done, they can proceed to checkout. - -=head2 SOLUTION - -Again, the exact implementation of the site will depend on the -implementation of this solution. This example is pretty much similar to -the way we implemented the browing history in the previous example. But -instead of saving the links of the pages, we simply save the ProductID -as the arrayref in the session parameter called, say, "CART". In the -folloiwng example we tried to represent the imaginary database in the -form of a hash. - -Each item in the listing will have a url to the shopping cart. The url -will be in the following format: - - http://ultracgis.com/cart.cgi?cmd=add;itemID=1001 - -C CGI parameter is a run mode for the application, in this -particular example it's "add", which tells the application that an item -is about to be added. C tells the application which item should -be added. You might as well go with the item title, instead of numbers, -but most of the time in dynamicly generated sites you prefer itemIDs -over their titles, since titles tend to be not consistent (it's from -experience): - - # Imaginary database in the form of a hash - %products = ( - 1001 => [ "usr/bin/perl t-shirt", 14.99], - 1002 => [ "just perl t-shirt", 14.99], - 1003 => [ "shebang hat", 15.99], - 1004 => [ "linux mug", 19.99], - # on and on it goes.... - ); - - # getting the run mode for the state. If doesn't exist, - # defaults to "display", which shows the cart's content - $cmd = $cgi->param("cmd") || "display"; - - if ( $cmd eq "display" ) { - print display_cart($cgi, $session); - - } elsif ( $cmd eq "add" ) { - print add_item($cgi, $session, \%products,); - - } elsif ( $cmd eq "remove") { - print remove_item($cgi, $session); - - } elsif ( $cmd eq "clear" ) { - print clear_cart($cgi, $session); - - } else { - print display_cart($cgi, $session); - - } - - -The above is the skeleton of the application. Now we start writing the -functions (subroutines) associated with each run-mode. We'll start with -C: - - sub add_item { - my ($cgi, $session, $products) = @_; - - # getting the itemID to be put into the cart - my $itemID = $cgi->param("itemID") or die "No item specified"; - - # getting the current cart's contents: - my $cart = $session->param("CART") || []; - - # adding the selected item - push @{ $cart }, { - itemID => $itemID, - name => $products->{$itemID}->[0], - price => $products->{$itemID}->[1], - }; - - # now store the updated cart back into the session - $session->param( "CART", $cart ); - - # show the contents of the cart - return display_cart($cgi, $session); - } - - -As you see, things are quite straight-forward this time as well. We're -accepting three arguments, getting the itemID from the C CGI -parameter, retrieving contents of the current cart from the "CART" -session parameter, updating the contents with the information we know -about the item with the C, and storing the modifed $cart back to -"CART" session parameter. When done, we simply display the cart. If -anything doesn't make sence to you, STOP! Read it over! - -Here are the contents for C, which simply gets the -shoping cart's contents from the session parameter and generates a list: - - sub display_cart { - my ($cgi, $session) = @_; - - # getting the cart's contents - my $cart = $session->param("CART") || []; - my $total_price = 0; - my $RV = q~~; - - if ( $cart ) { - for my $product ( @{$cart} ) { - $total_price += $product->{price}; - $RV = qq~ - - - - ~; - } - - } else { - $RV = qq~ - - - ~; - } - - $RV = qq~ - - - -
TitlePrice
$product->{name}$product->{price}
There are no items in your cart -yet
Total Price:$total_price>
~; - - return $RV; - } - - -A more professional approach would be to take the HTML outside the -program code by using B, in which case the above -C will look like: - - sub display_cart { - my ($cgi, $session) = @_; - - my $template = new HTML::Template(filename=>"cart.tmpl", - associate=>$session, - die_on_bad_params=>0); - return $template->output(); - - } - -And respective portion of the html template would be something like: - - - - - - - - - - - - - - - - -
TitlePrice
Total Price:
- - -A slight problem in the above template: TOTAL_PRICE doesn't exist. To -fix this problem we need to introduce a slight modification to our -C, where we also save the precalculated total price in the -"total_price" session parameter. Try it yourself. - -If you've been following the examples, you shouldn't discover anything -in the above code either. Let's move to C. That's what -the link for removing an item from the shopping cart will look like: - - http://ultracgis.com/cart.cgi?cmd=remove;itemID=1001 - - sub remove_item { - my ($cgi, $session) = @_; - - # getting the itemID from the CGI parameter - my $itemID = $cgi->param("itemID") or return undef; - - # getting the cart data from the session - my $cart = $session->param("CART") or return undef; - - my $idx = 0; - for my $product ( @{$cart} ) { - $product->{itemID} == $itemID or next; - splice( @{$cart}, $idx++, 1); - } - - $session->param("CART", $cart); - - return display_cart($cgi, $session); - } - -C will get even shorter - - sub clear_cart { - my ($cgi, $session) = @_; - $session->clear(["CART"]); - } - -=head1 MEMBERS AREA - -=head2 PROBLEM - -You want to create an area in the part of your site/application where -only restricted users should have access to. - -=head2 SOLUTION - -I have encountered literally dozens of different implementations of this -by other programmers, none of them perfect. Key properties of such an -application are reliability, security and no doubt, user-friendliness. -Consider this receipt not just as a CGI::Session implementation, but -also a receipt on handling login/authentication routines transparently. -Your users will love you for it. - -So first, let's build the logic, only then we'll start coding. Before -going any further, we need to agree upon a username/password fields that -we'll be using for our login form. Let's choose "lg_name" and -"lg_password" respectively. Now, in our application, we'll always be -watching out for those two fields at the very start of the program to -detect if the user submitted a login form or not. Some people tend to -setup a dedicated run-mode like "_cmd=login" which will be handled -seperately, but later you'll see why this is not a good idea. - -If those two parameters are present in our CGI object, we will go ahead -and try to load the user's profile from the database and set a special -session flag "~logged-in" to a true value. If those parameters are -present, but if the login/password pairs do not match with the ones in -the database, we leave "~logged-in" untouched, but increment another -flag "~login-trials" to one. So here is an init() function (for -initializer) which should be called at the top of the program: - - sub init { - my ($session, $cgi) = @_; # receive two args - - if ( $session->param("~logged-in") ) { - return 1; # if logged in, don't bother going further - } - - my $lg_name = $cgi->param("lg_name") or return; - my $lg_psswd=$cgi->param("lg_password") or return; - - # if we came this far, user did submit the login form - # so let's try to load his/her profile if name/psswds match - if ( my $profile = _load_profile($lg_name, $lg_psswd) ) { - $session->param("~profile", $profile); - $session->param("~logged-in", 1); - $session->clear(["~login-trials"]); - return 1; - - } - - # if we came this far, the login/psswds do not match - # the entries in the database - my $trials = $session->param("~login-trials") || 0; - return $session->param("~login-trials", ++$trials); - } - - -Syntax for _load_profile() totally depends on where your user profiles -are stored. I normally store them in MySQL tables, but suppose you're -storing them in flat files in the following format: - - username password email - -Your _load_profile() would look like: - - sub _load_profile { - my ($lg_name, $lg_psswd) = @_; - - local $/ = "\n"; - unless (sysopen(PROFILE, "profiles.txt", O_RDONLY) ) { - die "Couldn't open profiles.txt: $!"); - } - while ( ) { - /^(\n|#)/ and next; - chomp; - my ($n, $p, $e) = split "\s+"; - if ( ($n eq $lg_name) && ($p eq $lg_psswd) ) { - my $p_mask = "x" . length($p); - return {username=>$n, password=>$p_mask, email=>$e}; - - } - } - close(PROFILE); - - return undef; - } - - -Now regardless of what run mode user is in, you just call the above -C method somewhere in the beginning of your program, and if the -user is logged in properly, you're guaranteed that "~logged-in" session -flag would be set to true and the user's profile information will be -available to you all the time from the "~profile" session parameter: - - init($cgi, $session); - - if ( $session->param("~login-trials") >= 3 ) { - print error("You failed 3 times in a row.\n" . - "Your session is blocked. Please contact us with ". - "the details of your action"); - exit(0); - - } - - unless ( $session->param("~logged-in") ) { - print login_page($cgi, $session); - exit(0); - - } - -In the above example we're using exit() to stop the further processing. -If you require mod_perl compatibility, you will want some other, more -graceful way. - -To access the user's profile data without accessing the database again, -you simply do: - - my $profile = $session->param("~profile"); - print "Hello $profile->{username}, I know it's you. Confess!"; - -and the user will be terrified :-). - -But here is a trick. Suppose, a user clicked on the link with the -following query_string: "profile.cgi?_cmd=edit", but he/she is not -logged in. If you're performing the above init() function, the user will -see a login_page(). What happens after they submit the form with proper -username/password? Ideally you would want the user to be taken directly -to "?_cmd=edit" page, since that's the link they clicked before being -prompted to login, rather than some other say "?_cmd=view" page. To -deal with this very important usabilit feature, you need to include a -hiidden field in your login form similar to: - - - -Since I prefer using HTML::Template, that's what I can find in my login -form most of the time: - - - -The above _cmd slot will be filled in properly by just associating $cgi -object with HTML::Template. - -Implementing a "sign out" functionality is even more straight forward. -Since the application is only checking for "~logged-in" session flag, we -simply clear the flag when a user click on say "?_cmd=logout" link: - - if ( $cmd eq "logout" ) { - $session->clear(["~logged-in"]); - - } - -You can choose to clear() "~profile" as well, but wouldn't you want to -have an ability to greet the user with his/her username or fill out his -username in the login form next time? This might be a question of -beliefs. But we believe it's the question of usability. You may also -choose to delete() the session... agh, let's not argue what is better -and what is not. As long as you're happy, that's what counts :-). Enjoy! - -=head1 SUGGESTIONS AND CORRECTIONS - -We tried to put together some simple examples of CGI::Session usage. -There're litterally hundreds of different exciting tricks one can -perform with proper session management. If you have a problem, and -believe CGI::Session is a right tool but don't know how to implement it, -or, if you want to see some other examples of your choice in this Cook -Book, just drop us an email, and we'll be happy to work on them as soon -as this evil time permits us. - -Send your questions, requests and corrections to CGI::Session mailing -list, Cgi-session @ ultracgis.com. - -=head1 AUTHOR - - Sherzod Ruzmetov - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/DB_File.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/DB_File.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/DB_File.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/DB_File.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/DB_File.pm Tue Oct 25 04:20:48 2005 @@ -1,168 +0,0 @@ -package CGI::Session::DB_File; - -# $Id: DB_File.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use base qw( - CGI::Session - CGI::Session::ID::MD5 - CGI::Session::Serialize::Default -); - -use DB_File; -use File::Spec; -use Fcntl (':DEFAULT', ':flock'); - -# Load neccessary libraries below - -use vars qw($VERSION $FILE_NAME); -$FILE_NAME = 'cgisess.db'; - -$VERSION = '0.1'; - -sub store { - my ($self, $sid, $options, $data) = @_; - - my $storable_data = $self->freeze($data); - - my $args = $options->[1]; - my $file = File::Spec->catfile($args->{Directory}, $args->{FileName} || $FILE_NAME); - - tie my %db, "DB_File", $file, O_RDWR|O_CREAT, 0644 or die $!; - $db{$sid} = $storable_data; - untie(%db) or die $!; - - return 1; - -} - - -sub retrieve { - my ($self, $sid, $options) = @_; - - # you will need to retrieve the stored data, and - # deserialize it using $self->thaw() method - - my $args = $options->[1]; - my $file = File::Spec->catfile($args->{Directory}, $args->{FileName} || $FILE_NAME); - - tie my %db, "DB_File", $file, O_RDWR|O_CREAT, 0644 or die $!; - my $data = $self->thaw($db{$sid}); - untie(%db); - - return $data; -} - - - -sub remove { - my ($self, $sid, $options) = @_; - - # you simply need to remove the data associated - # with the id - - my $args = $options->[1]; - my $file = File::Spec->catfile($args->{Directory}, $args->{FileName} || $FILE_NAME); - tie my %db, "DB_File", $file, O_RDWR|O_CREAT, 0644 or die $!; - delete $db{$sid}; - untie(%db) or die $!; - - return 1; - - -} - - - -sub teardown { - my ($self, $sid, $options) = @_; - - # this is called just before session object is destroyed -} - - - - -# $Id: DB_File.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -1; - -=pod - -=head1 NAME - -CGI::Session::DB_File - DB_File driver for CGI::Session - -=head1 SYNOPSIS - - use CGI::Session; - $session = new CGI::Session("driver:DB_File", undef, {Directory=>'/tmp'}); - -For more details, refer to L manual - -=head1 DESCRIPTION - -CGI::Session::DB_File is a CGI::Session driver to store session data in BerkeleyDB. -Filename to store the session data is by default 'cgisess.db'. If you want different -name, you can either specify it with the "FileName" option as below: - - $s = new CGI::Session::DB_File(undef, {Directory=>'/tmp', FileName=>'sessions.db'}); - -or by setting the value of the $CGI::Session::DB_File::NAME variable before creating -the session object: - - $CGI::Session::DB_File::NAME = 'sessions.db'; - $s = new CGI::Session("driver:DB_File", undef, {Directory=>'/tmp'}); - -The only driver option required, as in the above examples, is "Directory", which tells the -driver where the session file and lock files should be created. - -"FileName" option is also available, but not required. - -=head1 COPYRIGHT - -Copyright (C) 2001-2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software and can be modified and distributed under the same -terms as Perl itself. - -Bug reports should be directed to sherzodr @ cpan.org, or posted to Cgi-session @ ultracgis.com -mailing list. - -=head1 AUTHOR - -CGI::Session::DB_File is written and maintained by Sherzod Ruzmetov - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - -# $Id: DB_File.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Example.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Example.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Example.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Example.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Example.pm Tue Oct 25 04:20:48 2005 @@ -1,203 +0,0 @@ -package CGI::Session::Example; - -# $Id: Example.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -#use diagnostics; -use File::Spec; -use base 'CGI::Application'; - - -# look into CGI::Application for the details of setup() method -sub setup { - my $self = shift; - - $self->mode_param(\&parsePathInfo); - $self->run_modes( - start => 'default', - default => 'default', - 'dump-session' => \&dump_session, - 'params' => \&display_params, - ); - - # setting up default HTTP header. See the details of query() and - # header_props() methods in CGI::Application manpage - my $cgi = $self->query(); - my $session = $self->session(); - my $sid_cookie = $cgi->cookie($session->name(), $session->id()); - $self->header_props(-type=>'text/html', -cookie=>$sid_cookie); -} - - - - - -# this method simply returns CGI::Session object. -sub session { - my $self = shift; - - if ( defined $self->param("_SESSION") ) { - return $self->param("_SESSION"); - } - require CGI::Session; - my $dsn = $self->param("_SESSION_DSN") || undef; - my $options = $self->param("_SESSION_OPTIONS") || {Directory=>File::Spec->tmpdir }; - my $session = CGI::Session->new($dsn, $self->query, $options); - unless ( defined $session ) { - die CGI::Session->error(); - } - $self->param(_SESSION => $session); - return $self->session(); -} - -# parses PATH_INFO and retrieves a portion which defines a run-mode -# to be executed to display the current page. Refer to CGI::Application -# manpage for details of run-modes and mode_param() method -sub parsePathInfo { - my $self = shift; - - unless ( defined $ENV{PATH_INFO} ) { - return; - } - my ($cmd) = $ENV{PATH_INFO} =~ m!/cmd/-/([^?]+)!; - return $cmd; -} - - -# see CGI::Application manpage -sub teardown { - my $self = shift; - - my $session = $self->param("_SESSION"); - if ( defined $session ) { - $session->close(); - } -} - - - - - -# overriding CGI::Application's load_tmpl() method. It doesn't -# return an HTML object, but the contents of the HTML template -sub load_tmpl { - my ($self, $filename, $args) = @_; - - # defining a default param set for the templates - $args ||= {}; - my $cgi = $self->query(); - my $session = $self->session(); - # making all the %ENV variables available for all the templates - map { $args->{$_} = $ENV{$_} } keys %ENV; - # making session id available for all the templates - $args->{ $session->name() } = $session->id; - # making library's version available for all the templates - $args->{ VERSION } = $session->version(); - - # loading the template - require HTML::Template; - my $t = new HTML::Template(filename => $filename, - associate => [$session, $cgi], - vanguard_compatibility_mode => 1); - $t->param(%$args); - return $t->output(); -} - - - -sub urlf { - my ($self, $cmd) = @_; - - my $sid = $self->session()->id; - my $name = $self->session()->name; - - return sprintf("$ENV{SCRIPT_NAME}/cmd/-/%s?%s=%s", $cmd, $name, $sid); -} - - - -sub page { - my ($self, $body) = @_; - - my %params = ( - body => $body, - url_default => $self->urlf('default'), - url_dump => $self->urlf('dump-session'), - url_params => $self->urlf('params'), - ); - return $self->load_tmpl('page.html', \%params); -} - - - - -# Application methods -sub default { - my $self = shift; - - my $session = $self->session(); - - my $body = $self->load_tmpl('welcome.html'); - - return $self->page($body); -} - - -sub dump_session { - my $self = shift; - - my $dmp = $self->session()->dump(undef, 1); - return $self->page(sprintf "
%s
", $dmp ); -} - - -sub delete_session { - my $self = shift; - - $self->session()->delete(); - $self->header_type('redirect'); - $self->header_props(-uri=>$ENV{HTTP_REFERER}); -} - - -sub display_params { - my $self = shift; - - my $session = $self->session(); - my @list = (); - for my $name ( $session->param() ) { - $name =~ /^_SESSION_/ and next; - my $value = $session->param($_); - push @list, {name => $name, value=>$value}; - } - my %params = ( - list => \@list, - ); - my $body = $self->load_tmpl('display-params.html', \%params); - return $self->page($body); -} - - - - - - - - - - -1; - -__END__ -# Below is stub documentation for your module. You'd better edit it! - -=head1 NAME - -CGI::Session::Example - Example on using CGI::Session - -=head1 DESCRIPTION - -STILL NOT COMPLETED. CHECK BACK FOR THE NEXT RELEASE OF CGI::Session. - - - Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/File.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/File.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/File.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/File.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/File.pm Tue Oct 25 04:20:48 2005 @@ -1,190 +0,0 @@ -package CGI::Session::File; - -# $Id: File.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use File::Spec; -use Fcntl (':DEFAULT', ':flock'); -use base qw( - CGI::Session - CGI::Session::ID::MD5 - CGI::Session::Serialize::Default -); - -use vars qw($FileName $VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; -$FileName = 'cgisess_%s'; - -sub store { - my ($self, $sid, $options, $data) = @_; - - $self->File_init($sid, $options); - unless ( sysopen (FH, $self->{_file_path}, O_RDWR|O_CREAT|O_TRUNC, 0644) ) { - $self->error("Couldn't store $sid into $self->{_file_path}: $!"); - return undef; - } - unless (flock(FH, LOCK_EX) ) { - $self->error("Couldn't get LOCK_EX: $!"); - return undef; - } - print FH $self->freeze($data); - unless ( close(FH) ) { - $self->error("Couldn't close $self->{_file_path}: $!"); - return undef; - } - return 1; -} - - -sub retrieve { - my ($self, $sid, $options) = @_; - - $self->File_init($sid, $options); - - # If the session data does not exist, return. - unless ( -e $self->{_file_path} ) { - return undef; - } - - unless ( sysopen(FH, $self->{_file_path}, O_RDONLY) ) { - $self->error("Couldn't open $self->{_file_path}: $!"); - return undef; - } - unless (flock(FH, LOCK_SH) ) { - $self->error("Couldn't lock the file: $!"); - return undef; - } - my $data = undef; - $data .= $_ while ; - - close(FH); - return $self->thaw($data); -} - - - -sub remove { - my ($self, $sid, $options) = @_; - - $self->File_init($sid, $options); - unless ( unlink ( $self->{_file_path} ) ) { - $self->error("Couldn't unlink $self->{_file_path}: $!"); - return undef; - } - return 1; -} - - - -sub teardown { - my ($self, $sid, $options) = @_; - - return 1; -} - - - - -sub File_init { - my ($self, $sid, $options) = @_; - - my $dir = $options->[1]->{Directory}; - my $path = File::Spec->catfile($dir, sprintf("$FileName", $sid)); - $self->{_file_path} = $path; -} - - - - - - -# $Id: File.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -1; - -=pod - -=head1 NAME - -CGI::Session::File - Default CGI::Session driver - -=head1 REVISION - -This manual refers to $Revision: 1.1.1.1 $ - -=head1 SYNOPSIS - - use CGI::Session; - $session = new CGI::Session("driver:File", undef, {Directory=>'/tmp'}); - -For more examples, consult L manual - -=head1 DESCRIPTION - -CGI::Session::File is a default CGI::Session driver. Stores the session data -in plain files. For the list of available methods, consult L manual. - -Each session is stored in a seperate file. File name is by default formatted as "cgisess_%s", -where '%s' is replaced with the effective session id. To change file name formatting, -update $CGI::Session::File::NAME variable. Examples: - - $CGI::Session::File::FileName = 'cgisess_%s.dat'; # with .dat extention - $CGI::Session::File::FileName = '%s.session'; - $CGI::Session::File::FileName = '%CGI-Session-%s.dat'; # old style - -The only driver option required is 'Directory', which denotes the location -session files are stored in. - -Example: - - $session = new CGI::Session("driver:File", undef, {Directory=>'some/directory'}); - -=head1 COPYRIGHT - -Copyright (C) 2001-2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software and can be modified and distributed under the same -terms as Perl itself. - -Bug reports should be directed to sherzodr @ cpan.org, or posted to Cgi-session @ ultracgis.com -mailing list. - -=head1 AUTHOR - -CGI::Session::File is written and maintained by Sherzod Ruzmetov - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - - -# $Id: File.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/MySQL.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/MySQL.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/MySQL.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/MySQL.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/MySQL.pm Tue Oct 25 04:20:48 2005 @@ -1,239 +0,0 @@ -package CGI::Session::MySQL; - -# $Id: MySQL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -# Inheriting necessary functionalities from the -# following libraries. Do not change it unless you know -# what you are doing -use base qw( - CGI::Session - CGI::Session::ID::MD5 - CGI::Session::Serialize::Default -); - - -# driver specific libraries should go below - -use vars qw($VERSION $TABLE_NAME); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - -$TABLE_NAME = 'sessions'; - -######################## -# Driver methods follow -######################## - - -# stores the serialized data. Returns 1 for sucess, undef otherwise -sub store { - my ($self, $sid, $options, $data) = @_; - - my $dbh = $self->MySQL_dbh($options); - my $lck_status = $dbh->selectrow_array(qq|SELECT GET_LOCK("$sid", 10)|); - unless ( $lck_status == 1 ) { - $self->error("Couldn't acquire lock on id '$sid'. Lock status: $lck_status"); - return undef; - } - - $dbh->do(qq|REPLACE INTO $TABLE_NAME (id, a_session) VALUES(?,?)|, - undef, $sid, $self->freeze($data)); - - return $dbh->selectrow_array(qq|SELECT RELEASE_LOCK("$sid")|); -} - - - -# retrieves the serialized data and deserializes it -sub retrieve { - my ($self, $sid, $options) = @_; - - # after you get the data, deserialize it using - # $self->thaw(), and return it - my $dbh = $self->MySQL_dbh($options); - my $lck_status = $dbh->selectrow_array(qq|SELECT GET_LOCK("$sid", 10)|); - unless ( $lck_status == 1 ) { - $self->error("Couldn't acquire lock on is '$sid'. Lock status: $lck_status"); - return undef; - } - - my $data = $dbh->selectrow_array(qq|SELECT a_session FROM $TABLE_NAME WHERE id=?|, undef, $sid); - $lck_status = $dbh->selectrow_array(qq|SELECT RELEASE_LOCK("$sid")|); - unless ( $lck_status == 1 ) { - $self->error("Couldn't release lock of '$sid'. Lock status: $lck_status"); - return undef; - } - - return $self->thaw($data); -} - - -# removes the given data and all the disk space associated with it -sub remove { - my ($self, $sid, $options) = @_; - - my $dbh = $self->MySQL_dbh($options); - my $lck_status = $dbh->selectrow_array(qq|SELECT GET_LOCK("$sid", 10)|); - unless ( $lck_status == 1 ) { - $self->error("Couldn't acquire lock on id '$sid'. Lock status; $lck_status"); - return undef; - } - - $dbh->do(qq|DELETE FROM $TABLE_NAME WHERE id=?|, undef, $sid); - $lck_status = $dbh->selectrow_array(qq|SELECT RELEASE_LOCK("$sid")|); - unless ( $lck_status == 1 ) { - $self->error("Couldn't release lock of '$sid'. Lock status: $lck_status"); - return undef; - } - - return 1; -} - - - - -# called right before the object is destroyed to do cleanup -sub teardown { - my ($self, $sid, $options) = @_; - - my $dbh = $self->MySQL_dbh($options); - - # Call commit if it isn't meant to be autocommited! - unless ( $dbh->{AutoCommit} ) { - $dbh->commit(); - } - - if ( $self->{MySQL_disconnect} ) { - $dbh->disconnect(); - } - - return 1; -} - - - - - - -sub MySQL_dbh { - my ($self, $options) = @_; - - my $args = $options->[1] || {}; - - if ( defined $self->{MySQL_dbh} ) { - return $self->{MySQL_dbh}; - - } - - require DBI; - - $self->{MySQL_dbh} = $args->{Handle} || DBI->connect( - $args->{DataSource}, - $args->{User} || undef, - $args->{Password} || undef, - { RaiseError=>1, PrintError=>1, AutoCommit=>1 } ); - - # If we're the one established the connection, - # we should be the one who closes it - $args->{Handle} or $self->{MySQL_disconnect} = 1; - return $self->{MySQL_dbh}; - -} - - - - -# $Id: MySQL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -1; -=pod - -=head1 NAME - -CGI::Session::MySQL - MySQL driver for CGI::Session - -=head1 SYNOPSIS - - use CGI::Session; - $session = new CGI::Session("driver:MySQL", undef, {Handle=>$dbh}); - -For more examples, consult L manual - -=head1 DESCRIPTION - -CGI::Session::MySQL is a CGI::Session driver to store session data in MySQL table. -To write your own drivers for B refere L manual. - - -=head1 STORAGE - -To store session data in MySQL database, you first need to create a suitable table for it -with the following command: - - CREATE TABLE sessions ( - id CHAR(32) NOT NULL UNIQUE, - a_session TEXT NOT NULL - ); - - -You can also add any number of additional columns to the table, but the above "id" -and "a_session" are required. - -If you want to store the session data in other table than "sessions", before creating -the session object you need to set the special variable B<$CGI::Session::MySQL::TABLE_NAME> -to the name of the table: - - use CGI::Session; - - $CGI::Session::MySQL::TABLE_NAME = 'my_sessions'; - $session = new CGI::Session("driver:MySQL", undef, {Handle=>$dbh}); - -=head1 COPYRIGHT - -Copyright (C) 2001, 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software and can be modified and distributed under the same -terms as Perl itself. - - -=head1 AUTHOR - -Sherzod Ruzmetov . All the bug reports should be sent to the author -to sherzodr @ cpan.org> - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - - - -# $Id: MySQL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/PostgreSQL.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/PostgreSQL.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/PostgreSQL.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/PostgreSQL.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/PostgreSQL.pm Tue Oct 25 04:20:48 2005 @@ -1,296 +0,0 @@ -# CGI::Session::PostgreSQL - PostgreSQL driver for CGI::Session -# -# Copyright (C) 2001-2002 Sherzod Ruzmetov, sherzodr @ cpan.org -# -# Copyright (C) 2002 Cosimo Streppone, cosimo @ cpan.org -# This module is based on CGI::Session::MySql module -# by Sherzod Ruzmetov, original author of CGI::Session modules -# and CGI::Session::MySQL driver. -# -# 2002/12/08 cosimo @ cpan.org -# Initial release -# 2003/03/01 cosimo @ cpan.org -# Added `FOR UPDATE' sql clauses to enable database row lock management -# -# $Id: PostgreSQL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package CGI::Session::PostgreSQL; - -use strict; -# Inheriting necessary functionalities from the -# following libraries. Do not change it unless you know -# what you are doing -use base qw( - CGI::Session - CGI::Session::ID::MD5 - CGI::Session::Serialize::Default -); - - -# driver specific libraries should go below - -use vars qw($VERSION $TABLE_NAME); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; -$TABLE_NAME = 'sessions'; - -######################## -# Driver methods follow -######################## - - -# stores the serialized data. Returns 1 for sucess, undef otherwise -sub store { - - my ($self, $sid, $options, $data) = @_; - my $dbh = $self->PostgreSQL_dbh($options); - my $db_data; - - eval { - - ($db_data) = $dbh->selectrow_array( - ' SELECT a_session FROM '.$TABLE_NAME. - ' WHERE id = '.$dbh->quote($sid).' FOR UPDATE' - ); - - }; - - if( $@ ) { - $self->error("Couldn't acquire data on id '$sid'"); - return undef; - } - - eval { - - if( $db_data ) { - -#warn('do update sid='.$sid.' data='.$self->freeze($data)); - - $dbh->do( - ' UPDATE '.$TABLE_NAME. - ' SET a_session='.$dbh->quote($self->freeze($data)). - ' WHERE id='.$dbh->quote($sid) - ); - - } else { - -#warn('do insert sid='.$sid.' data='.$self->freeze($data)); - - $dbh->do( - 'INSERT INTO '.$TABLE_NAME.' (id,a_session) '. - 'VALUES ('.$dbh->quote($sid).', '.$dbh->quote($self->freeze($data)).')' - ); - - } - - }; - - if( $@ ) { - $self->error("Error in session update on id '$sid'. $@"); - warn("Error in session update on id '$sid'. $@"); - return undef; - } - - return 1; -} - - - -# retrieves the serialized data and deserializes it -sub retrieve { - my ($self, $sid, $options) = @_; - - # after you get the data, deserialize it using - # $self->thaw(), and return it - my $dbh = $self->PostgreSQL_dbh($options); - my $data; - eval { - $data = $dbh->selectrow_array( - ' SELECT a_session FROM '.$TABLE_NAME. - ' WHERE id = '.$dbh->quote($sid) - ); - }; - if( $@ ) { - $self->error("Couldn't acquire data on id '$sid'"); - return undef; - } - return $self->thaw($data); -} - - -# removes the given data and all the disk space associated with it -sub remove { - my ($self, $sid, $options) = @_; - - my $dbh = $self->PostgreSQL_dbh($options); - my $data; - eval { - $data = $dbh->selectrow_array( - ' SELECT a_session FROM '.$TABLE_NAME. - ' WHERE id = '.$dbh->quote($sid).' FOR UPDATE' - ); - }; - if( $@ ) { - $self->error("Couldn't acquire data on id '$sid'"); - return undef; - } - - eval { - $dbh->do( - 'DELETE FROM '.$TABLE_NAME.' WHERE id = '.$dbh->quote($sid) - ); - }; - if( $@ ) { - $self->error("Couldn't release lock of '$sid'"); - return undef; - } - - return 1; - -} - - - - -# Called right before the object is destroyed to do cleanup -sub teardown { - my ($self, $sid, $options) = @_; - - my $dbh = $self->PostgreSQL_dbh($options); - - # Call commit if it isn't meant to be autocommited! - unless ( $dbh->{AutoCommit} ) { - $dbh->commit(); - } - - if ( $self->{PostgreSQL_disconnect} ) { - $dbh->disconnect(); - } - - return 1; -} - - -sub PostgreSQL_dbh { - my ($self, $options) = @_; - - my $args = $options->[1] || {}; - - if ( defined $self->{PostgreSQL_dbh} ) { - return $self->{PostgreSQL_dbh}; - - } - - if ( defined $args->{TableName} ) { - $TABLE_NAME = $args->{TableName}; - } - - require DBI; - - $self->{PostgreSQL_dbh} = $args->{Handle} || DBI->connect( - $args->{DataSource}, - $args->{User} || undef, - $args->{Password} || undef, - { RaiseError=>1, PrintError=>1, AutoCommit=>1 } ); - - # If we're the one established the connection, - # we should be the one who closes it - $args->{Handle} or $self->{PostgreSQL_disconnect} = 1; - - return $self->{PostgreSQL_dbh}; - -} - - - - -# $Id: PostgreSQL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -1; - -=pod - -=head1 NAME - -CGI::Session::PostgreSQL - PostgreSQL driver for CGI::Session - -=head1 SYNOPSIS - - use CGI::Session; - $session = new CGI::Session("driver:PostgreSQL", undef, {Handle=>$dbh}); - -For more examples, consult L manual - -=head1 DESCRIPTION - -CGI::Session::PostgreSQL is a CGI::Session driver to store session data in a PostgreSQL table. -To write your own drivers for B refere L manual. - -=head1 STORAGE - -To store session data in PostgreSQL database, you first need -to create a suitable table for it with the following command: - - CREATE TABLE sessions ( - id CHAR(32) NOT NULL, - a_session TEXT NOT NULL - ); - - -You can also add any number of additional columns to the table, -but the above "id" and "a_session" are required. -If you want to store the session data in other table than "sessions", -you will also need to specify B attribute as the -first argument to new(): - - use CGI::Session; - - $session = new CGI::Session("driver:PostgreSQL", undef, - {Handle=>$dbh, TableName=>'my_sessions'}); - -Every write access to session records is done through PostgreSQL own row locking mechanism, -enabled by `FOR UPDATE' clauses in SELECTs or implicitly enabled in UPDATEs and DELETEs. - -=head1 COPYRIGHT - -Copyright (C) 2002 Cosimo Streppone. All rights reserved. - -This library is free software and can be modified and distributed -under the same terms as Perl itself. - -=head1 AUTHOR - -Cosimo Streppone , heavily based on the CGI::Session::MySQL -driver by Sherzod Ruzmetov, original author of CGI::Session. - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Tutorial.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Tutorial.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Tutorial.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Tutorial.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Tutorial.pm Tue Oct 25 04:20:48 2005 @@ -1,506 +0,0 @@ -# $Id: Tutorial.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package CGI::Session::Tutorial; - -use vars ('$VERSION'); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/ - -1; - -__END__; - -=pod - -=head1 NAME - -Tutorial - extended CGI::Session manual - -=head1 STATE MAINTANANCE OVERVIEW - -Since HTTP is a stateless protocol, each subsequent click to a web site is treated as new by the web server. The server does not relate the visits with previous one, thus all the state information from the previous requests are lost. This makes creating such applications as shopping carts, login/authentication routines, secure restricted services in the web impossible. So people had to do something against this despair situation HTTP was putting us in. - -For our rescue come such technologies as HTTP Cookies and QUERY_STRINGs that help us save the users' session for a certain period. Since cookies and query_strings alone cannot take us too far B, several other libraries/technologies have been developed to extend their capabilities and promise a more reliable and a more persistent system. CGI::Session is one of them. - -Before we discuss this library, let's look at some alternative solutions. - -=head2 COOOKIE - -Cookie is a piece of text-information that a web server is entitled to place in the user's hard disk, assuming a user agent (i.e.. Web Browser) is compatible with the specification. After the cookie being placed, user agents are required to send these cookies back to the server as part of the HTTP request. This way the server application ( CGI ) will have a way of relating previous requests by the same user agent, thus overcoming statelessness of HTTP. - -Although cookies seem to be promising solutions for the statelessness of HTTP, they do carry certain limitations, such as limited number of cookies per domain and per user agent and limited size on each cookie. User Agents are required to store at least 300 cookies at a time, 20 cookies per domain and allow 4096 bytes of storage for each cookie. They also rise several Privacy and Security concerns, the lists of which can be found on the sections 6-B<"Privacy" and 7-"Security Considerations"> of B respectively. - -=head2 QUERY STRING - -Query string is a string appended to URL following a question mark (?) such as: - - http://my.dot.com/login.cgi?user=sherzodr&password=topSecret - -As you probably guessed already, it can also help you to pass state information from a click to another, but how secure is it do you think? Considering these URLs tend to get cached by most of the user agents and also logged in the servers access log, to which everyone can have access to, it is not secure. - -=head2 HIDDEN FIELDS - -Hidden field is another alternative to using query strings and they come in two flavors: hidden fields used in POST methods and the ones in GET. The ones used in GET methods will turn into a true query string once submitted, so all the disadvantages of QUERY_STRINGs do apply. Although POST requests do not have limitations of its sister-GET, the pages that hold them do the cached by web browser, and are available within the source code of the page (obviously). They also become unwieldily to manage when one has oodles of state information to keep track of ( for instance, a shopping cart or an advanced search engine). - -Query strings and hidden fields are also lost easily by closing the browser, or by clicking the browser's "Back" button. - -=head2 SERVER SIDE SESSION MANAGEMENT - -This technique is built upon the aforementioned technologies plus a server-side storage device, which saves the state data for a particular session. Each session has a unique id associated with the data in the server. This id is also associated with the user agent in either the form of a cookie, a query_string parameter, a hidden field or all at the same time. - -Advantages: - -=over 4 - -=item * - -We no longer need to depend on the User Agent constraints in cookie amounts and sizes - -=item * - -Sensitive data like user's username, email address, preferences and such no longer need to be traveling across the network at each request (which is the case with query strings, cookies and hidden_fields). Only thing that travels across the network is the unique id generated for the session ("ID-1234", for instance), which should make no sense to bad guys whatsoever. - -=item * - -User will not have sensitive data stored in his computer in an unsecured plain text format (which is a cookie file). - -=item * - -It's possible to handle very big and even complex (in-memory) data structures transparently. - -=back - -That's what CGI::Session is all about - implementing server side session management. Now is a very good time to get the feet wet. - -=head1 PROGRAMMING STYLE - -Server side session management system might be seeming awfully convoluted if you have never dealt with it. Fortunately, with CGI::Session this cumbersome task can be achieved in much elegent way, all the complexity being handled by the library transparently. This section of the manual can be treated as an introductory tutorial to both logic behind session management, and to CGI::Session programming style. - -=head1 WHAT YOU NEED TO KNOW FIRST - -Before you start using the library, you will need to decide where and how you want the session data to be stored in disk. In other words, you will need to tell what driver to use. You can choose either of "File", "DB_File" and "MySQL" drivers, which are shipped with the distribution by default. Examples in this document will be using "File" driver exclusively to make sure the examples are accessible in all machines with the least requirements. To do this, we create the session object like so: - - use CGI::Session; - $session = new CGI::Session("driver:File", $cgi, {Directory=>'/tmp'}); - -The first argument is called Data Source Name (DSN in short). If it's undef, the library will use the default driver, which is "File". So instead of being explicit about the driver as in the above example, we could simply say: - - $session = new CGI::Session(undef, $cgi, {Directory=>'/tmp'}); - -and we're guaranteed it will fall back to default settings. - -The second argument is session id to be initialized. If it's undef, it will force CGI::Session to create a new session. Instead of passing a session id, you can also pass a CGI.pm object, or any other object that can implement either of cookie() or param() methods. In this case, the library will try to retrieve the session id from either B cookie or B CGI parameter (query string) - -The third argument should be in the form of hashref. This will be used by specific CGI::Session driver only. For the list of all the available attributes, consult respective CGI::Session driver. If you want to write a code -which is expected to run in various operating systems, and want to reference that particular system's -temporary folder, use tmpdir() method documented in File::Spec: - - $session = new CGI::Session(undef, $cgi, {Directory=>File::Spec->tmpdir}); - -Following drivers are available: - -=over 4 - -=item * - -L - default driver for storing session data in plain files. Full name: B - -=item * - -L - for storing session data in BerkelyDB. Requires: L. Full name: B - -=item * - -L - for storing session data in MySQL tables. Requires L and L. Full name: B - -=back - -Note: You can also write your own driver for the library. Consult respective -section of this manual for details. - -=head1 CREATING NEW SESSION - -To generate a brand new session for a user, just pass an undefined value as the second argument to the constructor - new(): - - $session = new CGI::Session("driver:File", undef, {Directory=>"/tmp"}); - -Directory refers to a place where the session files and their locks will be stored in the form of separate files. When you generate the session object, as we did above, you will have: - -=over 4 - -=item 1 - -Session ID generated for you and - -=item 2 - -Storage file associated with the id in the directory you specified. - -=back - -From now on, in case you want to access the newly generated session id just do: - - $sid = $session->id(); - -It returns a string something similar to B which you can now send as a cookie or use as a query string or in your forms' hidden fields. Using standard L library we can send the session id as a cookie to the user's browser like so: - - $cookie = $cgi->cookie(CGISESSID => $session->id); - print $cgi->header( -cookie=>$cookie ); - -If anything in the above example doesn't make sense, please consult L for the details. - -=head2 INITIALIZING EXISTING SESSIONS - -When a user clicks another link or re-visits the site after a short while should we be creating a new session again? Absolutely not. This would defeat the whole purpose of state maintenance. Since we already send the id as a cookie, all we need is to pass that id as the seconds argument while creating a session object: - - $sid = $cgi->cookie("CGISESSID") || undef; - $session = new CGI::Session(undef, $sid, {Directory=>'/tmp'}); - -The above syntax will first try to initialize an existing session data, if it fails ( if the session doesn't exist ) creates a new session: just what we want. But what if the user doesn't support cookies? In that case we would need to append the session id to all the urls as a query string, and look for them in addition to cookie: - - $sid = $cgi->cookie('CGISESSID') || $cgi->param('CGISESSID') || undef; - $session = new CGI::Session(undef, $sid, {Directory=>'/tmp'}); - -Assuming you have CGI object handy, you can minimize the above two lines into one: - - $session = new CGI::Session(undef, $cgi, {Directory=>"/tmp"}); - -If you pass an object, instead of a string as the second argument, as we did above, CGI::Session will try to retrieve the session id from either the cookie or query string and initialize the session accordingly. Name of the cookie and query string parameters are assumed to be B by default. To change this setting, you will need to invoke C class method on either CGI::Session or its object: - - CGI::Session->name("MY_SID"); - # or - $session->name("MY_SID"); - - $session = new CGI::Session(undef, $cgi, {Directory=>'/tmp'}); - -=head2 STORING DATA IN THE SESSION - -To store a single variable in the object use C method: - - $session->param("my_name", $name); - -You can use C method to store complex data such as arrays, hashes, objects and so forth. While storing arrays and hashes, make sure to pass them as a reference: - - @my_array = ("apple", "grapes", "melon", "casaba"); - $session->param("fruits", \@my_array); - -You can store objects as well: - - $session->param("cgi", $cgi); # stores CGI.pm object - -Sometimes you wish there was a way of storing all the CGI parameters in the session object. You would start dreaming of this feature after having to save dozens of query parameters from each form element to your session object. Consider the following syntax: - - $session->save_param($cgi, ["keyword", "category", "author", "orderby"]); - -save_param() makes sure that all the above CGI parameters get saved in the session object. It's the same as saying: - - $session->param("keyword", $cgi->param("keyword")); - $session->param("category", $cgi->param("category")); - # etc... for all the form elements - -In case you want to save all the CGI parameters. Just omit the second argument to C: - - $session->save_param($cgi); - -The above syntax saves all the available/accessible CGI parameters - -=head2 ACCESSING STORED DATA - -There's no point of storing data if you cannot access it. You can access stored session data by using the same C method you once used to store them: - - $name = $session->param("my_name"); - -Above form of param() retrieves session parameter previously stored as "my_name". To retrieve previously stored @my_array: - - $my_array = $session->param("fruits"); - -It will return a reference to the array, and can be dereferenced as @{$my_array}. - -Very frequently, you may find yourself having to create a pre-filled and pre-selected forms, like radio buttons, checkboxes and drop down menus according to the user's preferences or previous action. With text and textareas it's not a big deal: you can simply retrieve a single parameter from the session and hardcode the value into the text field. But how would you do it when you have a group of radio buttons, checkboxes and scrolling lists? For this purpose, CGI::Session provides load_param() method, which loads given session parameters to a CGI object (assuming they have been previously saved with save_param() method or alternative): - - $session->load_param($cgi, ["fruits"]); - -Now you can use CGI.pm to generate those preselected checkboxes: - - print $cgi->checkbox_group(fruits=>['apple', 'banana', 'appricot']); - -If you're making use of HTML::Template to separate the code from the skins, you can as well associate CGI::Session object with HTML::Template and access all the parameters from within HTML files. We love this trick! - - $template = new HTML::Template(filename=>"some.tmpl", associate=>$session); - print $template->output(); - -Assuming the session object stored "first_name" and "email" parameters while being associated with HTML::Template, you can access those values from within your "some.tmpl" file now: - - Hello ! - -For more tricks with HTML::Template, please refer to the library's manual (L) and L. - -=head2 CLOSING THE SESSION - -Normally you don't have to close the session explicitly. It gets closed when your program terminates or session object goes out of scope. However in some few instances you might want to close the session explicitly by calling CGI::Session's C method or undefining the object. What is closing all about - you'd ask. While session is active, updates to session object doesn't get stored in the disk right away. It stores them in the memory until you either choose to flush the buffer by calling C method or destroy the session object by either terminating the program or calling close() method explicitly. - -In some circumstances you might want to close the session but at the same time don't want to terminate the process for a while. Might be the case with GUI and in daemon applications. In this case close() is what you want. Note: we prefer simpl undefing the session rather than calling close() method. close() is less efficient): - - undef($session); - -If you want to keep the session object but for any reason want to synchronize the data in the buffer with the one in the disk, C method is what you need. - -Note: close() calls flush() as well. So there's no need to call flush() before calling close() - -=head2 CLEARING SESSION DATA - -You store session data, you access session data and at some point you will want to clear certain session data, if not all. For this purpose CGI::Session provides C method which optionally takes one argument as an arrayref indicating which session parameters should be deleted from the session object: - - $session->clear(["~logged-in", "email"]); - -Above line deletes "~logged-in" and "email" session parameters from the session. And next time you say: - - $email = $session->param("email"); - -it returns undef. If you omit the argument to C, be warned that all the session parameters you ever stored in the session object will get deleted. Note that it does not delete the session itself. Session stays open and accessible. It's just the parameters you stored in it gets deleted - -=head2 DELETING A SESSION - -If there's a start there's an end. If session could be created, it should be possible to delete it from the disk for good: - - $session->delete(); - -The above call to C deletes the session from the disk for good. Do not confuse it with C, which only clears certain session parameters but keeps the session open. - -=head2 EXPIRATION - -CGI::Session also provides limited means to expire session data. Expiring session is the same as deleting it via delete(), but deletion takes place automaticly. To expire a session, you need to tell the library how long the session would be valid after the last access time. When that time is met, CGI::Session refuses to retrieve the session. It deletes the session and returns a brand new one. To assign expiration ticker for a session, use the expire() method: - - $session->expire(3600); # expire after 3600 seconds - $session->expire('+1h'); # expire after 1 hour - $session->expire('+15m'); # expire after 15 minutes - $session->expire('+1M'); # expire after a month and so on. - -But sometimes, it makes perfect sense to expire a certain session parameter, instead of the whole session. The author usually does this in his login/authentication enabled sites, where after the user logs in successfully, sets a "_logged_in" flag to true, and assigns an expiration ticker on that flag to something like 30 minutes. It means, after 30 idle minutes CGI::Session will clear() "_logged_in" flag, indicating the user should log in over again. I aggree, the same effect can be achieved by simply expiring() the session itself, but in thise we would loose other session parameters, such as user's shopping cart, session-preferences and the like. - -This feature can also be used to simulate layered security/authentication, such as, you can keep the user's access to his/her personal profile information for as long as 10 idle hours after successful login, but expire his/her access to his credit card information after 10 idle minutes. To achieve this effect, we will use expire() method again, but with a slightly different syntax: - - $session->expire(_profile_access, '+10h'); - $session->expire(_cc_access, '+10m'); - -With the above syntax, the person will still have access to his personal information even after 5 idle hours. But when he tries to access or update his/her credit card information, he may be displayed a "login again, please" screen. - -This concludes our discussion of CGI::Session programming style for now (at least till the new releases of the library ). The rest of the manual covers some L<"SECUIRITY"> issues and L<"DRIVER SPECIFICATIONS"> for those want to implement their own drivers or understand the library architecture. - -=head1 SECURITY - -"How secure is using CGI::Session?", "Can others hack down people's sessions using another browser if they can get the session id of the user?", "Are the session ids guessable?" are the questions I find myself answering over and over again. - -=head2 STORAGE - -Security of the library does in many aspects depend on the implementation. After making use of this library, you no longer have to send all the information to the user's cookie except for the session id. But, you still have to store the data in the server side. So another set of questions arise, can an evil person have access to session data in your server, even if they do, can they make sense out of the data in the session file, and even if they can, can they reuse the information against a person who created that session. As you see, the answer depends on yourself who is implementing it. - -First rule of thumb, do not save the users' passwords or other sensitive data in the session. If you can persuade yourself that this is necessary, make sure that evil eyes don't have access to session files in your server. If you're using RDBMS driver such as MySQL, the database will be protected with a username/password pair. But if it will be storing in the file system in the form of plain files, make sure no one except you can have access to those files. - -Default configuration of the driver makes use of Data::Dumper class to serialize data to make it possible to save it in the disk. Data::Dumper's result is a human readable data structure, which if opened, can be interpreted against you. If you configure your session object to use either Storable or FreezeThaw as a serializer, this would make more difficult for bad guys to make sense out of session data. But don't use this as the only precaution for security. Since evil fingers can type a quick program using Storable or FreezeThaw which deciphers that session file very easily. - -Also, do not allow sick minds to update the contents of session files. Of course CGI::Session makes sure it doesn't happen, but your cautiousness does no harm either. - -Do not keep sessions open with sensitive information for very long period. This will increase the possibility that some bad guy may have someone's valid session id at a given time (acquired somehow). - -ALWAYS USE "-ip-match" SWITCH!!! - -Read on for the details of "-ip-match". - -=head2 SESSION IDs - -Session ids are not easily guessable (unless you're using Incr Id generator)! Default configuration of CGI::Session uses Digest::MD5 which takes process id, time in seconds since epoch and a random number, generates a 32 character long digest out of it. Although this string cannot be guessable by others, if they find it out somehow, can they use this identifier against the other person? - -Consider the scenario, where you just give someone either via email or an instant messaging a link to your online-account profile, where you're currently logged in. The URL you give to that person contains a session id as part of a query string. If the site was initializing the session solely using query string parameter, after clicking on that link that person now appears to that site as you, and might have access to all of your private data instantly. How scary and how unwise implementation. And what a poor kid who didn't know that pasting URLs with session ids could be an accident waiting to happen. - -Even if you're solely using cookies as the session id transporters, it's not that difficult to plant a cookie in the cookie file with the same id and trick the web browser to send that particular session id to the server. So key for security is to check if the person who's asking us to retrieve a session data is indeed the person who initially created the session data. CGI::Session helps you to watch out for such cases by enabling "-ip_match" switch while "use"ing the library: - - use CGI::Session qw/-ip-match/; - -or alternatively, setting $CGI::Session::IP_MATCH to a true value, say to 1. This makes sure that before initializing a previously stored session, it checks if the ip address stored in the session matches the ip address of the user asking for that session. In which case the library returns the session, otherwise it dies with a proper error message. - -=head1 DRIVER SPECIFICATIONS - -This section is for driver authors who want to implement their own storing mechanism for the library. Those who enjoy sub-classing stuff should find this section useful as well. Here we discuss the architecture of CGI::Session and its drivers. - -=head2 LIBRARY OVERVIEW - -Library provides all the base methods listed in the L section. The only methods CGI::Session doesn't bother providing are the ones that need to deal with writing the session data in the disk, retrieving the data from the disk, and deleting the data. These are the methods specific to the driver, so that's where they should belong. - -In other words, driver is just another Perl library which uses CGI::Session as a base class, and provides several additional methods that deal with disk access. - -=head2 SERIALIZATION - -Before getting to driver specs, let's talk about how the data should be stored. When flush() is called, or the program terminates, CGI::Session asks a driver to store the data somewhere in the disk, and passes the data in the form of a hash reference. Then it's the driver's obligation to serialize the data so that it can be stored in the disk. - -Although you are free to implement your own serializing engine for your driver, CGI::Session distribution comes with several libraries you can inherit from and call freeze() method on the object to serialize the data and store it. Those libraries are: - -=over 4 - -=item L - -=item L - -=item L - -=back - -Example: - - # $data is a hashref that needs to be stored - my $storable_data = $self->freeze($data) - -$storable_data can now be saved in the disk safely. - -When the driver is asked to retrieve the data from the disk, that serialized data should be accordingly de-serialized. The aforementioned serializers also provides thaw() method, which takes serialized data as the first argument and returns Perl data structure, as it was before saved. Example: - - my $hashref = $self->thaw($stored_data); - -=head2 DRIVER METHODS - -Driver is just another Perl library, which uses CGI::Session as a base class and is required to provide the following methods: - -=over 4 - -=item C - -retrieve() is called by CGI::Session with the above 3 arguments when it's asked to retrieve the session data from the disk. $self is the session object, $sid is the session id, and $options is the list of the arguments passed to new() in the form of a hashref. Method should return un-serialized session data, or undef indicating the failure. If an error occurs, instead of calling die() or croak(), we suggest setting the error message to error() and returning undef: - - unless ( sysopen(FH, $options->{FileName}, O_RDONLY) ) { - $self->error("Couldn't read from $options->{FileName}: $!"); - return undef; - } - -If the driver detects that it's been asked for a non-existing session, it should not generate any error message, but simply return undef. This will signal CGI::Session to create a new session id. - -=item C - -store() is called by CGI::Session when session data needs to be stored. Data to be stored is passed as the third argument to the method, and is a reference to a hash. Should return any true value indicating success, undef otherwise. Error message should be passed to error(). - -=item C - -remove() called when CGI::Session is asked to remove the session data from the disk via delete() method. Should return true indicating success, undef otherwise, setting the error message to error() - -=item C - -called when session object is about to get destroyed, either explicitly via close() or implicitly when the program terminates - -=back - -=head2 GENERATING ID - -CGI::Session also requires the driver to provide a generate_id() method, which returns an id for a new session. Again, you are welcome to re-invent your own wheel, but note, that CGI::Session distribution comes with couple of id generating libraries that provide you with generate_id(). You should simply inherit from them. Following ID generators are available: - -=over 4 - -=item L - -=item L - -=back - -Refer to their respective manuals for more details. - -In case you want to have your own style of ids, you can define a generate_id() method explicitly without inheriting from the above libraries. Or write your own B library, that simply defines "generate_id()" method, which returns a session id, then give the name to the constructor as part of the DSN: - - $session = new CGI::Session("id:YourID", undef, {Neccessary=>Attributes}); - -=head2 BLUEPRINT - -Your CGI::Session distribution comes with a Session/Blueprint.pm file -which can be used as a starting point for your driver: - - package CGI::Session::BluePrint; - - use strict; - use base qw( - CGI::Session - CGI::Session::ID::MD5 - CGI::Session::Serialize::Default - ); - - # Load neccessary libraries below - - use vars qw($VERSION); - - $VERSION = '0.1'; - - sub store { - my ($self, $sid, $options, $data) = @_; - - my $storable_data = $self->freeze($data); - - #now you need to store the $storable_data into the disk - } - - sub retrieve { - my ($self, $sid, $options) = @_; - - # you will need to retrieve the stored data, and - # deserialize it using $self->thaw() method - } - - sub remove { - my ($self, $sid, $options) = @_; - - # you simply need to remove the data associated - # with the id - } - - - - sub teardown { - my ($self, $sid, $options) = @_; - - # this is called just before session object is destroyed - } - - 1; - - __END__; - - -After filling in the above blanks, you can do: - - $session = new CGI::Session("driver:MyDriver", $sid, {Option=>"Value"}); - -and follow CGI::Session manual. - - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. You can modify and distribute it under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov . Suggestions, feedbacks and patches are welcome. - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:49 +0900 Subject: [Affelio-cvs 653] CVS update: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID Message-ID: <20051024192049.315792AC030@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/Incr.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/Incr.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/Incr.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/Incr.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/Incr.pm Tue Oct 25 04:20:49 2005 @@ -1,137 +0,0 @@ -package CGI::Session::ID::Incr; - -# $Id: Incr.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use File::Spec; -use Carp "croak"; -use Fcntl (':DEFAULT', ':flock'); - -use vars qw($VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - -sub generate_id { - my ($self, $options) = @_; - - my $IDFile = $options->[1]->{IDFile} or croak "Don't know where to store the id"; - my $IDIncr = $options->[1]->{IDIncr} || 1; - my $IDInit = $options->[1]->{IDInit} || 0; - - unless (sysopen(FH, $IDFile, O_RDWR|O_CREAT, 0644) ) { - $self->error("Couldn't open IDFile=>$IDFile: $!"); - return undef; - } - unless (flock(FH, LOCK_EX) ) { - $self->error("Couldn't lock IDFile=>$IDFile: $!"); - return undef; - } - my $ID = || $IDInit; - unless ( seek(FH, 0, 0) ) { - $self->error("Couldn't seek IDFile=>$IDFile: $!"); - return undef; - } - unless ( truncate(FH, 0) ) { - $self->error("Couldn't trunated IDFile=>$IDFile: $!"); - return undef; - } - $ID += $IDIncr; - print FH $ID; - unless ( close(FH) ) { - $self->error("Couldn't close IDFile=>$IDFile: $!"); - return undef; - } - - return $ID; -} - - -1; - -=pod - -=head1 NAME - -CGI::Session::ID::Incr - CGI::Session ID driver - -=head1 SYNOPSIS - - use CGI::Session qw/-api3/; - - $session = new CGI::Session("id:Incr", undef, - { Directory => '/tmp', - IDFile => '/tmp/cgisession.id', - IDInit => 1000, - IDIncr => 2 }); - -=head1 DESCRIPTION - -CGI::Session::ID::Incr is to generate auto incrementing Session IDs. Compare it with CGI::Session::ID::MD5, where session ids are truely random 32 character long strings. - -CGI::Session::ID::Incr expects the following arguments passed to CGI::Session->new() as the third argument - -=over 4 - -=item "IDFile" - -Location where auto incremened IDs are stored. This attribute is required. - -=item "IDInit" - -Initial value of the ID if it's the first ID to be generated. For example, if you want the ID numbers to start with 1000 as opposed to 0, that's where you should set your value. Default is 0. - -=item "IDIncr" - -How many digits each number should increment by. For example, if you want the first generated id to start with 1000, and each subsequent id to increment by 10, set 'IDIncr' to '10'. Default is 1. - -=back - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. You can modify and distribute it under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov - -Feedbacks, suggestions and patches are welcome. - -=head1 SEE ALSO - -=over 4 - -=item * - -L - MD5 ID generator - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - - -=cut - Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/MD5.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/MD5.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/MD5.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/MD5.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/MD5.pm Tue Oct 25 04:20:49 2005 @@ -1,90 +0,0 @@ -package CGI::Session::ID::MD5; - -# $Id: MD5.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Digest::MD5; -use vars qw($VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - -sub generate_id { - my $self = shift; - - my $md5 = new Digest::MD5(); - $md5->add($$ , time() , rand(9999) ); - - return $md5->hexdigest(); -} - - -1; - -=pod - -=head1 NAME - -CGI::Session::ID::MD5 - default CGI::Session ID driver - -=head1 SYNOPSIS - - use CGI::Session qw/-api3/; - - $session = new CGI::Session("id:MD5", undef, - { Directory => '/tmp', - IDFile => '/tmp/cgisession.id', - IDInit => 1000, - IDIncr => 2 }); - -=head1 DESCRIPTION - -CGI::Session::ID::MD5 is to generate MD5 encoded hexidecimal random ids. -The library does not require any arguments. - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. You can modify and distribute it under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov - -Feedbacks, suggestions and patches are welcome. - -=head1 SEE ALSO - -=over 4 - -=item * - -L - Auto Incremental ID generator - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/SHA1.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/SHA1.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/SHA1.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/SHA1.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/ID/SHA1.pm Tue Oct 25 04:20:49 2005 @@ -1,86 +0,0 @@ -package CGI::Session::ID::SHA1; - -# $Id: SHA1.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -use strict; -use Digest::SHA1; -use vars qw($VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - -sub generate_id { - my $self = shift; - - my $sha1 = new Digest::SHA1(); - $sha1->add($$ , time() , rand(9999) ); - - return $sha1->hexdigest(); -} - - -1; - -=pod - -=head1 NAME - -CGI::Session::ID::SHA1 - SHA1 session id generator - -=head1 SYNOPSIS - - use CGI::Session; - - $session = new CGI::Session("id:SHA1", undef); - -=head1 DESCRIPTION - -CGI::Session::ID::SHA1 is to generate SHA1 encoded hexidecimal random ids -using Digest::SHA1. The method does not require any arguments. - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. You can modify and distribute it under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov - -Feedbacks, suggestions and patches are welcome. - -=head1 SEE ALSO - -=over 4 - -=item * - -L - Auto Incremental ID generator - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:49 +0900 Subject: [Affelio-cvs 654] CVS update: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize Message-ID: <20051024192049.531D32AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Default.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Default.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Default.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Default.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Default.pm Tue Oct 25 04:20:49 2005 @@ -1,123 +0,0 @@ -package CGI::Session::Serialize::Default; - -# $Id: Default.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -use strict; -use Safe; -use Data::Dumper; - -use vars qw($VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - - -sub freeze { - my ($self, $data) = @_; - - local $Data::Dumper::Indent = 0; - local $Data::Dumper::Purity = 0; - local $Data::Dumper::Useqq = 1; - local $Data::Dumper::Deepcopy = 0; - - my $d = new Data::Dumper([$data], ["D"]); - return $d->Dump(); -} - - - -sub thaw { - my ($self, $string) = @_; - - # To make -T happy - my ($safe_string) = $string =~ m/^(.*)$/; - - my $D = undef; - my $cpt = new Safe(); - $D = $cpt->reval ($safe_string ); - if ( $@ ) { - die $@; - } - - return $D; -} - - -1; - -=pod - -=head1 NAME - -CGI::Session::Serialize::Default - default serializer for CGI::Session - -=head1 DESCRIPTION - -This library is used by CGI::Session driver to serialize session data before storing -it in disk. - -=head1 METHODS - -=over 4 - -=item freeze() - -receives two arguments. First is the CGI::Session driver object, the second is the data to be -stored passed as a reference to a hash. Should return true to indicate success, undef otherwise, -passing the error message with as much details as possible to $self->error() - -=item thaw() - -receives two arguments. First being CGI::Session driver object, the second is the string -to be deserialized. Should return deserialized data structure to indicate successs. undef otherwise, -passing the error message with as much details as possible to $self->error(). - -=back - -=head1 WARNING - -If you want to be able to store objects, consider using L or -L instead. - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. It can be distributed under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov - -All bug reports should be directed to Sherzod Ruzmetov . - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/FreezeThaw.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/FreezeThaw.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/FreezeThaw.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/FreezeThaw.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/FreezeThaw.pm Tue Oct 25 04:20:49 2005 @@ -1,101 +0,0 @@ -package CGI::Session::Serialize::FreezeThaw; - -# $Id: FreezeThaw.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -use strict; -use FreezeThaw; - -use vars qw($VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - - -sub freeze { - my ($self, $data) = @_; - - return FreezeThaw::freeze($data); -} - - - -sub thaw { - my ($self, $string) = @_; - - return (FreezeThaw::thaw($string))[0]; -} - - -1; - -=pod - -=head1 NAME - -CGI::Session::Serialize::FreezeThaw - serializer for CGI::Session - -=head1 DESCRIPTION - -This library is used by CGI::Session driver to serialize session data before storing -it in disk. Uses FreezeThaw. - -=head1 METHODS - -=over 4 - -=item freeze() - -receives two arguments. First is the CGI::Session driver object, the second is the data to be -stored passed as a reference to a hash. Should return true to indicate success, undef otherwise, -passing the error message with as much details as possible to $self->error() - -=item thaw() - -receives two arguments. First being CGI::Session driver object, the second is the string -to be deserialized. Should return deserialized data structure to indicate successs. undef otherwise, -passing the error message with as much details as possible to $self->error(). - -=back - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. It can be distributed under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov - -All bug reports should be directed to Sherzod Ruzmetov . - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - Index: affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Storable.pm diff -u affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Storable.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Storable.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Storable.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/CGI/Session/Serialize/Storable.pm Tue Oct 25 04:20:49 2005 @@ -1,101 +0,0 @@ -package CGI::Session::Serialize::Storable; - -# $Id: Storable.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -use strict; -use Storable; -use vars qw($VERSION); - -($VERSION) = '$Revision: 1.1.1.1 $' =~ m/Revision:\s*(\S+)/; - - -sub freeze { - my ($self, $data) = @_; - - return Storable::freeze($data); -} - - -sub thaw { - my ($self, $string) = @_; - - return Storable::thaw($string); -} - -# $Id: Storable.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -1; - -=pod - -=head1 NAME - -CGI::Session::Serialize::Storable - serializer for CGI::Session - -=head1 DESCRIPTION - -This library is used by CGI::Session driver to serialize session data before storing -it in disk. Uses Storable - -=head1 METHODS - -=over 4 - -=item freeze() - -receives two arguments. First is the CGI::Session driver object, the second is the data to be -stored passed as a reference to a hash. Should return true to indicate success, undef otherwise, -passing the error message with as much details as possible to $self->error() - -=item thaw() - -receives two arguments. First being CGI::Session driver object, the second is the string -to be deserialized. Should return deserialized data structure to indicate successs. undef otherwise, -passing the error message with as much details as possible to $self->error(). - -=back - -=head1 COPYRIGHT - -Copyright (C) 2002 Sherzod Ruzmetov. All rights reserved. - -This library is free software. It can be distributed under the same terms as Perl itself. - -=head1 AUTHOR - -Sherzod Ruzmetov - -All bug reports should be directed to Sherzod Ruzmetov . - -=head1 SEE ALSO - -=over 4 - -=item * - -L - CGI::Session manual - -=item * - -L - extended CGI::Session manual - -=item * - -L - practical solutions for real life problems - -=item * - -B - "HTTP State Management Mechanism" found at ftp://ftp.isi.edu/in-notes/rfc2965.txt - -=item * - -L - standard CGI library - -=item * - -L - another fine alternative to CGI::Session - -=back - -=cut - -# $Id: Storable.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:49 +0900 Subject: [Affelio-cvs 655] CVS update: affelio_farm/admin/skelton/affelio/extlib/Config Message-ID: <20051024192049.765092AC039@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Config/IniFiles.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Config/IniFiles.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Config/IniFiles.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Config/IniFiles.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Config/IniFiles.pm Tue Oct 25 04:20:49 2005 @@ -1,2388 +0,0 @@ -package Config::IniFiles; -$Config::IniFiles::VERSION = (qw($Revision: 1.1.1.1 $))[1]; -require 5.004; -use strict; -use Carp; -use Symbol 'gensym','qualify_to_ref'; # For the 'any data type' hack - - @ Config::IniFiles::errors = ( ); - -# $Header: /cvsroot/affelio/affelio_farm/admin/skelton/affelio/extlib/Config/Attic/IniFiles.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -=head1 NAME - -Config::IniFiles - A module for reading .ini-style configuration files. - -=head1 SYNOPSIS - - use Config::IniFiles; - my $cfg = new Config::IniFiles( -file => "/path/configfile.ini" ); - print "The value is " . $cfg->val( 'Section', 'Parameter' ) . "." - if $cfg->val( 'Section', 'Parameter' ); - -=head1 DESCRIPTION - -Config::IniFiles provides a way to have readable configuration files outside -your Perl script. Configurations can be imported (inherited, stacked,...), -sections can be grouped, and settings can be accessed from a tied hash. - -=head1 FILE FORMAT - -INI files consist of a number of sections, each preceded with the -section name in square brackets. The first non-blank character of -the line indicating a section must be a left bracket and the last -non-blank character of a line indicating a section must be a right -bracket. The characters making up the section name can be any -symbols at all. However section names must be unique. - -Parameters are specified in each section as Name=Value. Any spaces -around the equals sign will be ignored, and the value extends to the -end of the line. Parameter names are localized to the namespace of -the section, but must be unique within a section. - - [section] - Parameter=Value - -Both the hash mark (#) and the semicolon (;) are comment characters. -by default (this can be changed by configuration) -Lines that begin with either of these characters will be ignored. Any -amount of whitespace may precede the comment character. - -Multi-line or multi-valued parameters may also be defined ala UNIX -"here document" syntax: - - Parameter=< method: - - $cfg = Config::IniFiles->new( -file => "/path/configfile.ini" ); - $cfg = new Config::IniFiles -file => "/path/configfile.ini"; - -Optional named parameters may be specified after the configuration -file name. See the I in the B section, below. - -Values from the config file are fetched with the val method: - - $value = $cfg->val('Section', 'Parameter'); - -If you want a multi-line/value field returned as an array, just -specify an array as the receiver: - - @values = $cfg->val('Section', 'Parameter'); - -=head1 METHODS - -=head2 new ( [-option=>value ...] ) - -Returns a new configuration object (or "undef" if the configuration -file has an error). One Config::IniFiles object is required per configuration -file. The following named parameters are available: - -=over 10 - -=item I<-file> filename - -Specifies a file to load the parameters from. This 'file' may actually be -any of the following things: - - 1) a simple filehandle, such as STDIN - 2) a filehandle glob, such as *CONFIG - 3) a reference to a glob, such as \*CONFIG - 4) an IO::File object - 5) the pathname of a file - -If this option is not specified, (i.e. you are creating a config file from scratch) -you must specify a target file using SetFileName in order to save the parameters. - -=item I<-default> section - -Specifies a section to be used for default values. For example, if you -look up the "permissions" parameter in the "users" section, but there -is none, Config::IniFiles will look to your default section for a "permissions" -value before returning undef. - -=item I<-reloadwarn> 0|1 - -Set -reloadwarn => 1 to enable a warning message (output to STDERR) -whenever the config file is reloaded. The reload message is of the -form: - - PID reloading config file at YYYY.MM.DD HH:MM:SS - -Default behavior is to not warn (i.e. -reloadwarn => 0). - -=item I<-nocase> 0|1 - -Set -nocase => 1 to handle the config file in a case-insensitive -manner (case in values is preserved, however). By default, config -files are case-sensitive (i.e., a section named 'Test' is not the same -as a section named 'test'). Note that there is an added overhead for -turning off case sensitivity. - -=item I<-allowcontinue> 0|1 - -Set -allowcontinue => 1 to enable continuation lines in the config file. -i.e. if a line ends with a backslash C<\>, then the following line is -appended to the parameter value, dropping the backslash and the newline -character(s). - -Default behavior is to keep a trailing backslash C<\> as a parameter -value. Note that continuation cannot be mixed with the "here" value -syntax. - -=item I<-import> object - -This allows you to import or inherit existing setting from another -Config::IniFiles object. When importing settings from another object, -sections with the same name will be merged and parameters that are -defined in both the imported object and the I<-file> will take the -value of given in the I<-file>. - -If a I<-default> section is also given on this call, and it does not -coincide with the default of the imported object, the new default -section will be used instead. If no I<-default> section is given, -then the default of the imported object will be used. - -=item I<-commentchar> 'char' - -The default comment character is C<#>. You may change this by specifying -this option to an arbitrary character, except alphanumeric characters -and square brackets and the "equal" sign. - -=item I<-allowedcommentchars> 'chars' - -Allowed default comment characters are C<#> and C<;>. By specifying this -option you may enlarge or narrow this range to a set of characters -(concatenating them to a string). Note that the character specified by -B<-commentchar> (see above) is always part of the allowed comment -characters. Note: The given string is evaluated as a character class -(i.e.: like C). - -=back - -=cut - -sub new { - my $class = shift; - my %parms = @_; - - my $errs = 0; - my @groups = ( ); - - my $self = {}; - # Set config file to default value, which is nothing - $self->{cf} = undef; - if( ref($parms{-import}) && ($parms{-import}->isa('Config::IniFiles')) ) { - # Import from the import object by COPYing, so we - # don't clobber the old object - %{$self} = %{$parms{-import}}; - } else { - $self->{firstload} = 1; - $self->{default} = ''; - $self->{imported} = []; - if( defined $parms{-import} ) { - carp "Invalid -import value \"$parms{-import}\" was ignored."; - delete $parms{-import}; - } # end if - } # end if - - # Copy the original parameters so we - # can use them when we build new sections - %{$self->{startup_settings}} = %parms; - - # Parse options - my($k, $v); - local $_; - $self->{nocase} = 0; - - # Handle known parameters first in this order, - # because each() could return parameters in any order - if (defined ($v = delete $parms{'-import'})) { - # Store the imported object's file parameter for reload - if( $self->{cf} ) { - push( @{$self->{imported}}, $self->{cf} ); - } else { - push( @{$self->{imported}}, "" ); - } # end if - } - if (defined ($v = delete $parms{'-file'})) { - # Should we be pedantic and check that the file exists? - # .. no, because now it could be a handle, IO:: object or something else - $self->{cf} = $v; - } - if (defined ($v = delete $parms{'-default'})) { - $self->{default} = $v; - } - if (defined ($v = delete $parms{'-nocase'})) { - $self->{nocase} = $v ? 1 : 0; - } - if (defined ($v = delete $parms{'-reloadwarn'})) { - $self->{reloadwarn} = $v ? 1 : 0; - } - if (defined ($v = delete $parms{'-allowcontinue'})) { - $self->{allowcontinue} = $v ? 1 : 0; - } - if (defined ($v = delete $parms{'-commentchar'})) { - if(!defined $v || length($v) != 1) { - carp "Comment character must be unique."; - $errs++; - } - elsif($v =~ /[\[\]=\w]/) { - # must not be square bracket, equal sign or alphanumeric - carp "Illegal comment character."; - $errs++; - } - else { - $self->{comment_char} = $v; - } - } - if (defined ($v = delete $parms{'-allowedcommentchars'})) { - # must not be square bracket, equal sign or alphanumeric - if(!defined $v || $v =~ /[\[\]=\w]/) { - carp "Illegal value for -allowedcommentchars."; - $errs++; - } - else { - $self->{comment_char} = $v; - } - } - $self->{comment_char} = '#' unless exists $self->{comment_char}; - $self->{allowed_comment_char} = ';' unless exists $self->{allowed_comment_char}; - # make sure that comment character is always allowed - $self->{allowed_comment_char} .= $self->{comment_char}; - - # Any other parameters are unkown - while (($k, $v) = each %parms) { - carp "Unknown named parameter $k=>$v"; - $errs++; - } - - return undef if $errs; - - bless $self, $class; - - # No config file specified, so everything's okay so far. - if (not defined $self->{cf}) { - return $self; - } - - if ($self->ReadConfig) { - return $self; - } else { - return undef; - } -} - -=head2 val ($section, $parameter [, $default] ) - -Returns the value of the specified parameter (C<$parameter>) in section -C<$section>, returns undef (or C<$default> if specified) if no section or -no parameter for the given section section exists. - - -If you want a multi-line/value field returned as an array, just -specify an array as the receiver: - - @values = $cfg->val('Section', 'Parameter'); - -A multi-line/value field that is returned in a scalar context will be -joined using $/ (input record separator, default is \n) if defined, -otherwise the values will be joined using \n. - -=cut - -sub val { - my ($self, $sect, $parm, $def) = @_; - - # Always return undef on bad parameters - return undef if not defined $sect; - return undef if not defined $parm; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - } - - my $val = defined($self->{v}{$sect}{$parm}) ? - $self->{v}{$sect}{$parm} : - $self->{v}{$self->{default}}{$parm}; - - # If the value is undef, make it $def instead (which could just be undef) - $val = $def unless defined $val; - - # Return the value in the desired context - if (wantarray and ref($val) eq "ARRAY") { - return @$val; - } elsif (ref($val) eq "ARRAY") { - if (defined ($/)) { - return join "$/", @$val; - } else { - return join "\n", @$val; - } - } else { - return $val; - } -} - -=head2 setval ($section, $parameter, $value, [ $value2, ... ]) - -Sets the value of parameter C<$parameter> in section C<$section> to -C<$value> (or to a set of values). See below for methods to write -the new configuration back out to a file. - -You may not set a parameter that didn't exist in the original -configuration file. B will return I if this is -attempted. See B below to do this. Otherwise, it returns 1. - -=cut - -sub setval { - my $self = shift; - my $sect = shift; - my $parm = shift; - my @val = @_; - - return undef if not defined $sect; - return undef if not defined $parm; - -# tom @ ytram.com + - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - } -# tom @ ytram.com - - - if (defined($self->{v}{$sect}{$parm})) { - if (@val > 1) { - $self->{v}{$sect}{$parm} = \@val; - $self->{EOT}{$sect}{$parm} = 'EOT'; - } else { - $self->{v}{$sect}{$parm} = shift @val; - } - return 1; - } else { - return undef; - } -} - -=head2 newval($section, $parameter, $value [, $value2, ...]) - -Assignes a new value, C<$value> (or set of values) to the -parameter C<$parameter> in section C<$section> in the configuration -file. - -=cut - -sub newval { - my $self = shift; - my $sect = shift; - my $parm = shift; - my @val = @_; - - return undef if not defined $sect; - return undef if not defined $parm; - -# tom @ ytram.com + - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - } -# tom @ ytram.com - - $self->AddSection($sect); - - push(@{$self->{parms}{$sect}}, $parm) - unless (grep {/^\Q$parm\E$/} @{$self->{parms}{$sect}} ); - - if (@val > 1) { - $self->{v}{$sect}{$parm} = \@val; - $self->{EOT}{$sect}{$parm} = 'EOT' unless defined - $self->{EOT}{$sect}{$parm}; - } else { - $self->{v}{$sect}{$parm} = shift @val; - } - return 1 -} - -=head2 delval($section, $parameter) - -Deletes the specified parameter from the configuration file - -=cut - -sub delval { - my $self = shift; - my $sect = shift; - my $parm = shift; - - return undef if not defined $sect; - return undef if not defined $parm; - -# tom @ ytram.com + - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - } -# tom @ ytram.com - - - @{$self->{parms}{$sect}} = grep !/^\Q$parm\E$/, @{$self->{parms}{$sect}}; - delete $self->{v}{$sect}{$parm}; - return 1 -} - -=head2 ReadConfig - -Forces the configuration file to be re-read. Returns undef if the -file can not be opened, no filename was defined (with the C<-file> -option) when the object was constructed, or an error occurred while -reading. - -If an error occurs while parsing the INI file the @Config::IniFiles::errors -array will contain messages that might help you figure out where the -problem is in the file. - -=cut - -sub ReadConfig { - my $self = shift; - - my($lineno, $sect); - my($group, $groupmem); - my($parm, $val); - my @cmts; - my %loaded_params = (); # A has to remember which params are loaded vs. imported - @Config::IniFiles::errors = ( ); - - # Initialize (and clear out) storage hashes - # unless we imported them from another file [JW] - if( @{$self->{imported}} ) { - # - # Run up the import tree to the top, then reload coming - # back down, maintaining the imported file names and our - # file name. - # This is only needed on a re-load though - unless( $self->{firstload} ) { - my $cf = $self->{cf}; - $self->{cf} = pop @{$self->{imported}}; - $self->ReadConfig; - push @{$self->{imported}}, $self->{cf}; - $self->{cf} = $cf; - } # end unless - } else { - $self->{sects} = []; # Sections - $self->{group} = {}; # Subsection lists - $self->{v} = {}; # Parameter values - $self->{sCMT} = {}; # Comments above section - } # end if - - return undef if ( - (not exists $self->{cf}) or - (not defined $self->{cf}) or - ($self->{cf} eq '') - ); - - my $nocase = $self->{nocase}; - - # If this is a reload and we want warnings then send one to the STDERR log - unless( $self->{firstload} || !$self->{reloadwarn} ) { - my ($ss, $mm, $hh, $DD, $MM, $YY) = (localtime(time))[0..5]; - printf STDERR - "PID %d reloading config file %s at %d.%02d.%02d %02d:%02d:%02d\n", - $$, $self->{cf}, $YY+1900, $MM+1, $DD, $hh, $mm, $ss; - } - - # Turn off. Future loads are reloads - $self->{firstload} = 0; - - # Get a filehandle, allowing almost any type of 'file' parameter - my $fh = $self->_make_filehandle( $self->{cf} ); - if (!$fh) { - carp "Failed to open $self->{cf}: $!"; - return undef; - } - - # Get mod time of file so we can retain it (if not from STDIN) - my @stats = stat $fh; - $self->{file_mode} = sprintf("%04o", $stats[2]) if defined $stats[2]; - - # Get the entire file into memory (let's hope it's small!) - local $_; - my @lines = split /\015\012?|\012|\025|\n/, join( '', <$fh>); - - # Only close if this is a filename, if it's - # an open handle, then just roll back to the start - if( !ref($fh) ) { - close($fh); - } else { - # But we can't roll back STDIN so skip that one - if( $fh != 0 ) { - seek( $fh, 0, 0 ); - } # end if - } # end if - - # If there's a UTF BOM (Byte-Order-Mark) in the first character of the first line - # then remove it before processing (http://www.unicode.org/unicode/faq/utf_bom.html#22) - ($lines[0] =~ s/^鏤?/); -# Disabled the utf8 one for now (JW) because it doesn't work on all perl distros -# e.g. 5.6.1 works with or w/o 'use utf8' 5.6.0 fails w/o it. 5.005_03 -# says "invalid hex value", etc. If anyone has a clue how to make this work -# please let me know! -# ($lines[0] =~ s/^鏤?/) || (eval('use utf8; $lines[0] =~ s/^\x{FEFF}//;')); -# $@ = ''; $! = undef; # Clear any error messages - - - - # The first lines of the file must be blank, comments or start with [ - my $first = ''; - my $allCmt = $self->{allowed_comment_char}; - foreach ( @lines ) { - next if /^\s*$/; # ignore blank lines - next if /^\s*[$allCmt]/; # ignore comments - $first = $_; - last; - } - unless( $first =~ /^\s*\[/ ) { - return undef; - } - - # Store what our line ending char was for output - ($self->{line_ends}) = $lines[0] =~ /([\015\012\025\n]+)/; - while ( @lines ) { - $_ = shift @lines; - - s/(\015\012?|\012|\025|\n)$//; # remove line ending char(s) - $lineno++; - if (/^\s*$/) { # ignore blank lines - next; - } - elsif (/^\s*[$allCmt]/) { # collect comments - push(@cmts, $_); - next; - } - elsif (/^\s*\[\s*(\S|\S.*\S)\s*\]\s*$/) { # New Section - $sect = $1; - if ($self->{nocase}) { - $sect = lc($sect); - } - $self->AddSection($sect); - $self->SetSectionComment($sect, @cmts); - @cmts = (); - } - elsif (($parm, $val) = /^\s*([^=]*?[^=\s])\s*=\s*(.*)$/) { # new parameter - $parm = lc($parm) if $nocase; - $self->{pCMT}{$sect}{$parm} = [@cmts]; - @cmts = ( ); - if ($val =~ /^<<(.*)$/) { # "here" value - my $eotmark = $1; - my $foundeot = 0; - my $startline = $lineno; - my @val = ( ); - while ( @lines ) { - $_ = shift @lines; - s/(\015\012?|\012|\025|\n)$//; # remove line ending char(s) - $lineno++; - if ($_ eq $eotmark) { - $foundeot = 1; - last; - } else { - push(@val, $_); - } - } - if ($foundeot) { - if (exists $self->{v}{$sect}{$parm} && - exists $loaded_params{$sect} && - grep( /^\Q$parm\E$/, @{$loaded_params{$sect}}) ) { - if (ref($self->{v}{$sect}{$parm}) eq "ARRAY") { - # Add to the array - push @{$self->{v}{$sect}{$parm}}, @val; - } else { - # Create array - my $old_value = $self->{v}{$sect}{$parm}; - my @new_value = ($old_value, @val); - $self->{v}{$sect}{$parm} = \@new_value; - } - } else { - $self->{v}{$sect}{$parm} = \@val; - $loaded_params{$sect} = [] unless $loaded_params{$sect}; - push @{$loaded_params{$sect}}, $parm; - } - $self->{EOT}{$sect}{$parm} = $eotmark; - } else { - push(@Config::IniFiles::errors, sprintf('%d: %s', $startline, - qq#no end marker ("$eotmark") found#)); - } - } else { # no here value - - # process continuation lines, if any - while($self->{allowcontinue} && $val =~ s/\\$//) { - $_ = shift @lines; - s/(\015\012?|\012|\025|\n)$//; # remove line ending char(s) - $lineno++; - $val .= $_; - } - - # Now load value - if (exists $self->{v}{$sect}{$parm} && - exists $loaded_params{$sect} && - grep( /^\Q$parm\E$/, @{$loaded_params{$sect}}) ) { - if (ref($self->{v}{$sect}{$parm}) eq "ARRAY") { - # Add to the array - push @{$self->{v}{$sect}{$parm}}, $val; - } else { - # Create array - my $old_value = $self->{v}{$sect}{$parm}; - my @new_value = ($old_value, $val); - $self->{v}{$sect}{$parm} = \@new_value; - } - } else { - $self->{v}{$sect}{$parm} = $val; - $loaded_params{$sect} = [] unless $loaded_params{$sect}; - push @{$loaded_params{$sect}}, $parm; - } - } - push(@{$self->{parms}{$sect}}, $parm) unless grep(/^\Q$parm\E$/, @{$self->{parms}{$sect}}); - } - else { - push(@Config::IniFiles::errors, sprintf("Line \%d in file " . $self->{cf} . " is mal-formed:\n\t\%s", $lineno, $_)); - } - } - - # - # Now convert all the parameter hashes into tied hashes. - # This is in all uses, because it must be part of ReadConfig. - # - my %parms = %{$self->{startup_settings}}; - if( defined $parms{-default} ) { - # If the default section doesn't exists, create it. - unless( defined $self->{v}{$parms{-default}} ) { - $self->{v}{$parms{-default}} = {}; - push(@{$self->{sects}}, $parms{-default}) unless (grep /^\Q$parms{-default}\E$/, @{$self->{sects}}); - $self->{parms}{$parms{-default}} = []; - } # end unless - $parms{-default} = $self->{v}{$parms{-default}}; - } # end if - foreach( keys %{$self->{v}} ) { - $parms{-_current_value} = $self->{v}{$_}; - $parms{-parms} = $self->{parms}{$_}; - $self->{v}{$_} = {}; - # Add a reference to our {parms} hash for each section - tie %{$self->{v}{$_}}, 'Config::IniFiles::_section', %parms - } # end foreach - - @Config::IniFiles::errors ? undef : 1; -} - - -=head2 Sections - -Returns an array containing section names in the configuration file. -If the I option was turned on when the config object was -created, the section names will be returned in lowercase. - -=cut - -sub Sections { - my $self = shift; - return @{$self->{sects}} if ref $self->{sects} eq 'ARRAY'; - return (); -} - -=head2 SectionExists ( $sect_name ) - -Returns 1 if the specified section exists in the INI file, 0 otherwise (undefined if section_name is not defined). - -=cut - -sub SectionExists { - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - return undef() if not defined $sect; - return 1 if (grep {/^\Q$sect\E$/} @{$self->{sects}}); - return 0; -} - -=head2 AddSection ( $sect_name ) - -Ensures that the named section exists in the INI file. If the section already -exists, nothing is done. In this case, the "new" section will possibly contain -data already. - -If you really need to have a new section with no parameters in it, check that -the name that you're adding isn't in the list of sections already. - -=cut - -sub AddSection { - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - return if $self->SectionExists($sect); - push @{$self->{sects}}, $sect; - $self->SetGroupMember($sect); - - # Set up the parameter names and values lists - $self->{parms}{$sect} = [] unless ref $self->{parms}{$sect} eq 'ARRAY'; - if (!defined($self->{v}{$sect})) { - $self->{sCMT}{$sect} = []; - $self->{pCMT}{$sect} = {}; # Comments above parameters - $self->{parms}{$sect} = []; - $self->{v}{$sect} = {}; - } -} - -=head2 DeleteSection ( $sect_name ) - -Completely removes the entire section from the configuration. - -=cut - -sub DeleteSection { - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - # This is done, the fast way, change if delval changes!! - delete $self->{v}{$sect}; - delete $self->{sCMT}{$sect}; - delete $self->{pCMT}{$sect}; - delete $self->{EOT}{$sect}; - delete $self->{parms}{$sect}; - - @{$self->{sects}} = grep !/^\Q$sect\E$/, @{$self->{sects}}; - - if( $sect =~ /^(\S+)\s+\S+/ ) { - my $group = $1; - if( defined($self->{group}{$group}) ) { - @{$self->{group}{$group}} = grep !/^\Q$sect\E$/, @{$self->{group}{$group}}; - } # end if - } # end if - - return 1; -} # end DeleteSection - -=head2 Parameters ($sect_name) - -Returns an array containing the parameters contained in the specified -section. - -=cut - -sub Parameters { - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - return @{$self->{parms}{$sect}} if ref $self->{parms}{$sect} eq 'ARRAY'; - return (); -} - -=head2 Groups - -Returns an array containing the names of available groups. - -Groups are specified in the config file as new sections of the form - - [GroupName MemberName] - -This is useful for building up lists. Note that parameters within a -"member" section are referenced normally (i.e., the section name is -still "Groupname Membername", including the space) - the concept of -Groups is to aid people building more complex configuration files. - -=cut - -sub Groups { - my $self = shift; - return keys %{$self->{group}} if ref $self->{group} eq 'HASH'; - return (); -} - -=head2 SetGroupMember ( $sect ) - -Makes sure that the specified section is a member of the appropriate group. - -Only intended for use in newval. - -=cut - -sub SetGroupMember { - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - return(1) unless $sect =~ /^(\S+)\s+\S+/; - - my $group = $1; - if (not exists($self->{group}{$group})) { - $self->{group}{$group} = []; - } - if (not grep {/^\Q$sect\E$/} @{$self->{group}{$group}}) { - push @{$self->{group}{$group}}, $sect; - } -} - -=head2 RemoveGroupMember ( $sect ) - -Makes sure that the specified section is no longer a member of the -appropriate group. Only intended for use in DeleteSection. - -=cut - -sub RemoveGroupMember { - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - return(1) unless $sect =~ /^(\S+)\s+\S+/; - - my $group = $1; - return unless exists $self->{group}{$group}; - @{$self->{group}{$group}} = grep {!/^\Q$sect\E$/} @{$self->{group}{$group}}; -} - -=head2 GroupMembers ($group) - -Returns an array containing the members of specified $group. Each element -of the array is a section name. For example, given the sections - - [Group Element 1] - ... - - [Group Element 2] - ... - -GroupMembers would return ("Group Element 1", "Group Element 2"). - -=cut - -sub GroupMembers { - my $self = shift; - my $group = shift; - - return undef if not defined $group; - - if ($self->{nocase}) { - $group = lc($group); - } - - return @{$self->{group}{$group}} if ref $self->{group}{$group} eq 'ARRAY'; - return (); -} - -=head2 SetWriteMode ($mode) - -Sets the mode (permissions) to use when writing the INI file. - -$mode must be a string representation of the octal mode. - -=cut - -sub SetWriteMode -{ - my $self = shift; - my $mode = shift; - return undef if not defined ($mode); - return undef if not ($mode =~ m/[0-7]{3,3}/); - $self->{file_mode} = $mode; - return $mode; -} - -=head2 GetWriteMode ($mode) - -Gets the current mode (permissions) to use when writing the INI file. - -$mode is a string representation of the octal mode. - -=cut - -sub GetWriteMode -{ - my $self = shift; - return undef if not exists $self->{file_mode}; - return $self->{file_mode}; -} - -=head2 WriteConfig ($filename) - -Writes out a new copy of the configuration file. A temporary file -(ending in '-new') is written out and then renamed to the specified -filename. Also see B below. - -Returns true on success, C on failure. - -=cut - -sub WriteConfig { - my $self = shift; - my $file = shift; - - return undef unless defined $file; - - # If we are using a filename, then do mode checks and write to a - # temporary file to avoid a race condition - if( !ref($file) ) { - if (-e $file) { - if (not (-w $file)) - { - #carp "File $file is not writable. Refusing to write config"; - return undef; - } - my $mode = (stat $file)[2]; - $self->{file_mode} = sprintf "%04o", ($mode & 0777); - #carp "Using mode $self->{file_mode} for file $file"; - } elsif (defined($self->{file_mode}) and not (oct($self->{file_mode}) & 0222)) { - #carp "Store mode $self->{file_mode} prohibits writing config"; - } - - my $new_file = $file . "-new"; - local(*F); - open(F, "> $new_file") || do { - carp "Unable to write temp config file $new_file: $!"; - return undef; - }; - my $oldfh = select(F); - $self->OutputConfig; - close(F); - select($oldfh); - rename( $new_file, $file ) || do { - carp "Unable to rename temp config file ($new_file) to $file: $!"; - return undef; - }; - if (exists $self->{file_mode}) { - chmod oct($self->{file_mode}), $file; - } - - } # Otherwise, reset to the start of the file and write, unless we are using STDIN - else { - # Get a filehandle, allowing almost any type of 'file' parameter - ## NB: If this were a filename, this would fail because _make_file - ## opens a read-only handle, but we have already checked that case - ## so re-using the logic is ok [JW/WADG] - my $fh = $self->_make_filehandle( $file ); - if (!$fh) { - carp "Could not find a filehandle for the input stream ($file): $!"; - return undef; - } - - - # Only roll back if it's not STDIN (if it is, Carp) - if( $fh == 0 ) { - carp "Cannot write configuration file to STDIN."; - } else { - seek( $fh, 0, 0 ); - my $oldfh = select($fh); - $self->OutputConfig; - seek( $fh, 0, 0 ); - select($oldfh); - } # end if - - } # end if (filehandle/name) - - return 1; - -} - -=head2 RewriteConfig - -Same as WriteConfig, but specifies that the original configuration -file should be rewritten. - -=cut - -sub RewriteConfig { - my $self = shift; - - return undef if ( - (not exists $self->{cf}) or - (not defined $self->{cf}) or - ($self->{cf} eq '') - ); - - # Return whatever WriteConfig returns :) - $self->WriteConfig($self->{cf}); -} - -=head2 GetFileName - -Returns the filename associated with this INI file. - -If no filename has been specified, returns undef. - -=cut - -sub GetFileName -{ - my $self = shift; - my $filename; - if (exists $self->{cf}) { - $filename = $self->{cf}; - } else { - undef $filename; - } - return $filename; -} - -=head2 SetFileName ($filename) - -If you created the Config::IniFiles object without initialising from -a file, or if you just want to change the name of the file to use for -ReadConfig/RewriteConfig from now on, use this method. - -Returns $filename if that was a valid name, undef otherwise. - -=cut - -sub SetFileName { - my $self = shift; - my $newfile = shift; - - return undef if not defined $newfile; - - if ($newfile ne "") { - $self->{cf} = $newfile; - return $self->{cf}; - } - return undef; -} - -# OutputConfig -# -# Writes OutputConfig to STDOUT. Use select() to redirect STDOUT to -# the output target before calling this function - -sub OutputConfig { - my $self = shift; - - my($sect, $parm, @cmts); - my $ors = $self->{line_ends} || $\ || "\n"; # $\ is normally unset, but use input by default - my $notfirst = 0; - local $_; - foreach $sect (@{$self->{sects}}) { - next unless defined $self->{v}{$sect}; - print $ors if $notfirst; - $notfirst = 1; - if ((ref($self->{sCMT}{$sect}) eq 'ARRAY') && - (@cmts = @{$self->{sCMT}{$sect}})) { - foreach (@cmts) { - print "$_$ors"; - } - } - print "[$sect]$ors"; - next unless ref $self->{v}{$sect} eq 'HASH'; - - foreach $parm (@{$self->{parms}{$sect}}) { - if ((ref($self->{pCMT}{$sect}{$parm}) eq 'ARRAY') && - (@cmts = @{$self->{pCMT}{$sect}{$parm}})) { - foreach (@cmts) { - print "$_$ors"; - } - } - - my $val = $self->{v}{$sect}{$parm}; - next if ! defined ($val); # No parameter exists !! - if (ref($val) eq 'ARRAY') { - my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT'; - print "$parm= <<$eotmark$ors"; - foreach (@{$val}) { - print "$_$ors"; - } - print "$eotmark$ors"; - } elsif( $val =~ /[$ors]/ ) { - # The FETCH of a tied hash is never called in - # an array context, so generate a EOT multiline - # entry if the entry looks to be multiline - my @val = split /[$ors]/, $val; - if( @val > 1 ) { - my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT'; - print "$parm= <<$eotmark$ors"; - print map "$_$ors", @val; - print "$eotmark$ors"; - } else { - print "$parm=$val[0]$ors"; - } # end if - } else { - print "$parm=$val$ors"; - } - } - } - return 1; -} - -=head2 SetSectionComment($section, @comment) - -Sets the comment for section $section to the lines contained in @comment. - -Each comment line will be prepended with the comment charcter (default -is C<#>) if it doesn't already have a comment character (ie: if the -line does not start with whitespace followed by an allowed comment -character, default is C<#> and C<;>). - -To clear a section comment, use DeleteSectionComment ($section) - -=cut - -sub SetSectionComment -{ - my $self = shift; - my $sect = shift; - my @comment = @_; - - return undef if not defined $sect; - return undef unless @comment; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - $self->{sCMT}{$sect} = []; - # At this point it's possible to have a comment for a section that - # doesn't exist. This comment will not get written to the INI file. - - push @{$self->{sCMT}{$sect}}, $self->_markup_comments(@comment); - return scalar @comment; -} - - - -# this helper makes sure that each line is preceded with the correct comment -# character -sub _markup_comments -{ - my $self = shift; - my @comment = @_; - - my $allCmt = $self->{allowed_comment_char}; - my $cmtChr = $self->{comment_char}; - foreach (@comment) { - m/^\s*[$allCmt]/ or ($_ = "$cmtChr $_"); - } - @comment; -} - - - -=head2 GetSectionComment ($section) - -Returns a list of lines, being the comment attached to section $section. In -scalar context, returns a string containing the lines of the comment separated -by newlines. - -The lines are presented as-is, with whatever comment character was originally -used on that line. - -=cut - -sub GetSectionComment -{ - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - if (exists $self->{sCMT}{$sect}) { - return @{$self->{sCMT}{$sect}}; - } else { - return undef; - } -} - -=head2 DeleteSectionComment ($section) - -Removes the comment for the specified section. - -=cut - -sub DeleteSectionComment -{ - my $self = shift; - my $sect = shift; - - return undef if not defined $sect; - - if ($self->{nocase}) { - $sect = lc($sect); - } - - delete $self->{sCMT}{$sect}; -} - -=head2 SetParameterComment ($section, $parameter, @comment) - -Sets the comment attached to a particular parameter. - -Any line of @comment that does not have a comment character will be -prepended with one. See L above - -=cut - -sub SetParameterComment -{ - my $self = shift; - my $sect = shift; - my $parm = shift; - my @comment = @_; - - defined($sect) || return undef; - defined($parm) || return undef; - @comment || return undef; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - } - - if (not exists $self->{pCMT}{$sect}) { - $self->{pCMT}{$sect} = {}; - } - - $self->{pCMT}{$sect}{$parm} = []; - # Note that at this point, it's possible to have a comment for a parameter, - # without that parameter actually existing in the INI file. - push @{$self->{pCMT}{$sect}{$parm}}, $self->_markup_comments(@comment); - return scalar @comment; -} - -=head2 GetParameterComment ($section, $parameter) - -Gets the comment attached to a parameter. - -=cut - -sub GetParameterComment -{ - my $self = shift; - my $sect = shift; - my $parm = shift; - - defined($sect) || return undef; - defined($parm) || return undef; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - }; - - exists($self->{pCMT}{$sect}) || return undef; - exists($self->{pCMT}{$sect}{$parm}) || return undef; - - my @comment = @{$self->{pCMT}{$sect}{$parm}}; - return (wantarray)?@comment:join " ", @comment; -} - -=head2 DeleteParameterComment ($section, $parmeter) - -Deletes the comment attached to a parameter. - -=cut - -sub DeleteParameterComment -{ - my $self = shift; - my $sect = shift; - my $parm = shift; - - defined($sect) || return undef; - defined($parm) || return undef; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - }; - - # If the parameter doesn't exist, our goal has already been achieved - exists($self->{pCMT}{$sect}) || return 1; - exists($self->{pCMT}{$sect}{$parm}) || return 1; - - delete $self->{pCMT}{$sect}{$parm}; - return 1; -} - -=head2 GetParameterEOT ($section, $parameter) - -Accessor method for the EOT text (in fact, style) of the specified parameter. If any text is used as an EOT mark, this will be returned. If the parameter was not recorded using HERE style multiple lines, GetParameterEOT returns undef. - -=cut - -sub GetParameterEOT -{ - my $self = shift; - my $sect = shift; - my $parm = shift; - - defined($sect) || return undef; - defined($parm) || return undef; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - }; - - if (not exists $self->{EOT}{$sect}) { - $self->{EOT}{$sect} = {}; - } - - if (not exists $self->{EOT}{$sect}{$parm}) { - return undef; - } - return $self->{EOT}{$sect}{$parm}; -} - -=head2 SetParameterEOT ($section, $EOT) - -Accessor method for the EOT text for the specified parameter. Sets the HERE style marker text to the value $EOT. Once the EOT text is set, that parameter will be saved in HERE style. - -To un-set the EOT text, use DeleteParameterEOT ($section, $parameter). - -=cut - -sub SetParameterEOT -{ - my $self = shift; - my $sect = shift; - my $parm = shift; - my $EOT = shift; - - defined($sect) || return undef; - defined($parm) || return undef; - defined($EOT) || return undef; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - }; - - if (not exists $self->{EOT}{$sect}) { - $self->{EOT}{$sect} = {}; - } - - $self->{EOT}{$sect}{$parm} = $EOT; -} - -=head2 DeleteParameterEOT ($section, $parmeter) - -Removes the EOT marker for the given section and parameter. -When writing a configuration file, if no EOT marker is defined -then "EOT" is used. - -=cut - -sub DeleteParameterEOT -{ - my $self = shift; - my $sect = shift; - my $parm = shift; - - defined($sect) || return undef; - defined($parm) || return undef; - - if ($self->{nocase}) { - $sect = lc($sect); - $parm = lc($parm); - } - - delete $self->{EOT}{$sect}{$parm}; -} - - -=head2 Delete - -Deletes the entire configuration file in memory. - -=cut - -sub Delete { - my $self = shift; - - # Again, done the fast way, if the data structure changes, change this! - $self->{sects} = []; - $self->{parms} = {}; - $self->{group} = {}; - $self->{v} = {}; - $self->{sCMT} = {}; - $self->{pCMT} = {}; - $self->{EOT} = {}; - - return 1; -} # end Delete - - - -=head1 USAGE -- Tied Hash - -=head2 tie %ini, 'Config::IniFiles', (-file=>$filename, [-option=>value ...] ) - -Using C, you can tie a hash to a B object. This creates a new -object which you can access through your hash, so you use this instead of the -B method. This actually creates a hash of hashes to access the values in -the INI file. The options you provide through C are the same as given for -the B method, above. - -Here's an example: - - use Config::IniFiles; - - my %ini - tie %ini, 'Config::IniFiles', ( -file => "/path/configfile.ini" ); - - print "We have $ini{Section}{Parameter}." if $ini{Section}{Parameter}; - -Accessing and using the hash works just like accessing a regular hash and -many of the object methods are made available through the hash interface. - -For those methods that do not coincide with the hash paradigm, you can use -the Perl C function to get at the underlying object tied to the hash -and call methods on that object. For example, to write the hash out to a new -ini file, you would do something like this: - - tied( %ini )->WriteConfig( "/newpath/newconfig.ini" ) || - die "Could not write settings to new file."; - -=head2 $val = $ini{$section}{$parameter} - -Returns the value of $parameter in $section. - -Because of limitations in Perl's tie implementation, -multiline values accessed through a hash will I be returned -as a single value with each line joined by the default line -separator ($\). To break them apart you can simple do this: - - @lines = split( "$\", $ini{section}{multi_line_parameter} ); - -=head2 $ini{$section}{$parameter} = $value; - -Sets the value of C<$parameter> in C<$section> to C<$value>. - -To set a multiline or multiv-alue parameter just assign an -array reference to the hash entry, like this: - - $ini{$section}{$parameter} = [$value1, $value2, ...]; - -If the parameter did not exist in the original file, it will -be created. However, Perl does not seem to extend autovivification -to tied hashes. That means that if you try to say - - $ini{new_section}{new_paramters} = $val; - -and the section 'new_section' does not exist, then Perl won't -properly create it. In order to work around this you will need -to create a hash reference in that section and then assign the -parameter value. Something like this should do nicely: - - $ini{new_section} = {}; - $ini{new_section}{new_paramters} = $val; - -=head2 %hash = %{$ini{$section}} - -Using the tie interface, you can copy whole sections of the -ini file into another hash. Note that this makes a copy of -the entire section. The new hash in no longer tied to the -ini file, In particular, this means -default and -nocase -settings will not apply to C<%hash>. - - -=head2 $ini{$section} = {}; %{$ini{$section}} = %parameters; - -Through the hash interface, you have the ability to replace -the entire section with a new set of parameters. This call -will fail, however, if the argument passed in NOT a hash -reference. You must use both lines, as shown above so that -Perl recognizes the section as a hash reference context -before COPYing over the values from your C<%parameters> hash. - -=head2 delete $ini{$section}{$parameter} - -When tied to a hash, you can use the Perl C function -to completely remove a parameter from a section. - -=head2 delete $ini{$section} - -The tied interface also allows you to delete an entire -section from the ini file using the Perl C function. - -=head2 %ini = (); - -If you really want to delete B the items in the ini file, this -will do it. Of course, the changes won't be written to the actual -file unless you call B on the object tied to the hash. - -=head2 Parameter names - -=over 4 - -=item my @keys = keys %{$ini{$section}} - -=item while (($k, $v) = each %{$ini{$section}}) {...} - -=item if( exists %{$ini{$section}}, $parameter ) {...} - -=back - -When tied to a hash, you use the Perl C and C -functions to iteratively list the parameters (C) or -parameters and their values (C) in a given section. - -You can also use the Perl C function to see if a -parameter is defined in a given section. - -Note that none of these will return parameter names that -are part if the default section (if set), although accessing -an unknown parameter in the specified section will return a -value from the default section if there is one. - - -=head2 Section names - -=over 4 - -=item foreach( keys %ini ) {...} - -=item while (($k, $v) = each %ini) {...} - -=item if( exists %ini, $section ) {...} - -=back - -When tied to a hash, you use the Perl C and C -functions to iteratively list the sections in the ini file. - -You can also use the Perl C function to see if a -section is defined in the file. - -=cut - -############################################################ -# -# TIEHASH Methods -# -# Description: -# These methods allow you to tie a hash to the -# Config::IniFiles object. Note that, when tied, the -# user wants to look at thinks like $ini{sec}{parm}, but the -# TIEHASH only provides one level of hash interace, so the -# root object gets asked for a $ini{sec}, which this -# implements. To further tie the {parm} hash, the internal -# class Config::IniFiles::_section, is provided, below. -# -############################################################ -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# ---------------------------------------------------------- -sub TIEHASH { - my $class = shift; - my %parms = @_; - - # Get a new object - my $self = $class->new( %parms ); - - return $self; -} # end TIEHASH - - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# ---------------------------------------------------------- -sub FETCH { - my $self = shift; - my( $key ) = @_; - - $key = lc($key) if( $self->{nocase} ); - - return $self->{v}{$key}; -} # end FETCH - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000Jun14 Fixed bug where wrong ref was saved JW -# 2000Oct09 Fixed possible but in %parms with defaults JW -# 2001Apr04 Fixed -nocase problem in storing JW -# ---------------------------------------------------------- -sub STORE { - my $self = shift; - my( $key, $ref ) = @_; - - return undef unless ref($ref) eq 'HASH'; - - $key = lc($key) if( $self->{nocase} ); - - # Create a new hash and tie it to a _sections object with the ref's data - $self->{v}{$key} = {}; - - # Store the section name in the list - push(@{$self->{sects}}, $key) unless (grep {/^\Q$key\E$/} @{$self->{sects}}); - - my %parms = %{$self->{startup_settings}}; - $self->{parms}{$key} = []; - $parms{-parms} = $self->{parms}{$key}; - $parms{-_current_value} = $ref; - delete $parms{default}; - $parms{-default} = $self->{v}{$parms{-default}} if defined $parms{-default} && defined $self->{v}{$parms{-default}}; - tie %{$self->{v}{$key}}, 'Config::IniFiles::_section', %parms; -} # end STORE - - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# 2000Dec17 Now removes comments, groups and EOTs too JW -# 2001Arp04 Fixed -nocase problem JW -# ---------------------------------------------------------- -sub DELETE { - my $self = shift; - my( $key ) = @_; - - $key = lc($key) if( $self->{nocase} ); - - delete $self->{sCMT}{$key}; - delete $self->{pCMT}{$key}; - delete $self->{EOT}{$key}; - delete $self->{parms}{$key}; - - if( $key =~ /(\S+)\s+\S+/ ) { - my $group = $1; - if( defined($self->{group}{$group}) ) { - @{$self->{group}{$group}} = grep !/\Q$key\E/, @{$self->{group}{$group}}; - } # end if - } # end if - - @{$self->{sects}} = grep !/^\Q$key\E$/, @{$self->{sects}}; - return delete( $self->{v}{$key} ); -} # end DELETE - - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# ---------------------------------------------------------- -sub CLEAR { - my $self = shift; - - foreach (keys %{$self->{v}}) { - $self->DELETE( $_ ); - } # end foreach - -} # end CLEAR - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# ---------------------------------------------------------- -sub FIRSTKEY { - my $self = shift; - - my $a = keys %{$self->{v}}; - return each %{$self->{v}}; -} # end FIRSTKEY - - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# ---------------------------------------------------------- -sub NEXTKEY { - my $self = shift; - my( $last ) = @_; - - return each %{$self->{v}}; -} # end NEXTKEY - - -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# 2001Apr04 Fixed -nocase bug and false true bug JW -# ---------------------------------------------------------- -sub EXISTS { - my $self = shift; - my( $key ) = @_; - $key = lc($key) if( $self->{nocase} ); - - return exists $self->{v}{$key}; -} # end EXISTS - - -# ---------------------------------------------------------- -# DESTROY is used by TIEHASH and the Perl garbage collector, -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000May09 Created method JW -# ---------------------------------------------------------- -sub DESTROY { - # my $self = shift; -} # end if - - -# ---------------------------------------------------------- -# Sub: _make_filehandle -# -# Args: $thing -# $thing An input source -# -# Description: Takes an input source of a filehandle, -# filehandle glob, reference to a filehandle glob, IO::File -# object or scalar filename and returns a file handle to -# read from it with. -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 06Dec2001 Added to support input from any source JW -# ---------------------------------------------------------- -sub _make_filehandle { - my $self = shift; - - # - # This code is 'borrowed' from Lincoln D. Stein's GD.pm module - # with modification for this module. Thanks Lincoln! - # - - no strict 'refs'; - my $thing = shift; - return $thing if defined(fileno $thing); -# return $thing if defined($thing) && ref($thing) && defined(fileno $thing); - - # otherwise try qualifying it into caller's package - my $fh = qualify_to_ref($thing,caller(1)); - return $fh if defined(fileno $fh); -# return $fh if defined($thing) && ref($thing) && defined(fileno $fh); - - # otherwise treat it as a file to open - $fh = gensym; - open($fh,$thing) || return; - - return $fh; -} # end _make_filehandle - - - -############################################################ -# -# INTERNAL PACKAGE: Config::IniFiles::_section -# -# Description: -# This package is used to provide a single-level TIEHASH -# interface to the sections in the IniFile. When tied, the -# user wants to look at thinks like $ini{sec}{parm}, but the -# TIEHASH only provides one level of hash interace, so the -# root object gets asked for a $ini{sec} and must return a -# has reference that accurately covers the '{parm}' part. -# -# This package is only used when tied and is inter-woven -# between the sections and their parameters when the TIEHASH -# method is called by Perl. It's a very simple implementation -# of a tied hash object with support for the Config::IniFiles -# -nocase and -default options. -# -############################################################ -# Date Modification Author -# ---------------------------------------------------------- -# 2000.May.09 Created to excapsulate TIEHASH interface JW -############################################################ -package Config::IniFiles::_section; - -use strict; -use Carp; -use vars qw( $VERSION ); - -$Config::IniFiles::_section::VERSION = 2.16; - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::TIEHASH -# -# Args: $class, %parms -# $class The class that this is being tied to. -# %parms Contains named parameters passed from the -# constructor plus thes parameters -# -_current_value holds the values to be inserted in the hash. -# -default should be a hash ref. -# -parms reference to the $self->{parms}{$sect} of the parent -# -# Description: Builds the object that gets tied to the -# sections name. Inserts the existing hash, defined in the -# named parameter '-_current_value' into the tied hash. -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# ---------------------------------------------------------- -sub TIEHASH { - my $proto = shift; - my $class = ref($proto) || $proto; - my %parms = @_; - - # Make a new object - my $self = {}; - - # Put the passed hash into the holder - $self->{v} = $parms{-_current_value}; - - # Get all other the parms, removing leading '-', if any - # Option checking is already handled in the Config::IniFiles contructor - foreach( keys %parms ) { - s/^-//g; - $self->{$_} = $parms{-$_}; - } # end foreach - - return bless( $self, $class ); -} # end TIEHASH - - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::FETCH -# -# Args: $key -# $key The name of the key whose value to get -# -# Description: Returns the value associated with $key. If -# the value is a hash, returns a hashref, just like normal -# Perl hashes. -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2000Jun15 Fixed bugs in -default handler JW -# 2000Dec07 Fixed another bug in -deault handler JW -# 2002Jul04 Returning scalar values (Bug:447532) AS -# ---------------------------------------------------------- -sub FETCH { - my $self = shift; - my $key = shift; - - $key = lc($key) if( $self->{nocase} ); - - my $val = $self->{v}{$key}; - - unless( defined $self->{v}{$key} ) { - $val = $self->{default}{$key} if ref($self->{default}) eq 'HASH'; - } # end unless - - return $val; -} # end FETCH - - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::STORE -# -# Args: $key, @val -# $key The key under which to store the value -# @val The value to store, either an array or a scalar -# -# Description: Sets the value for the specified $key -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2001Apr04 Fixed -nocase bug JW -# ---------------------------------------------------------- -sub STORE { - my $self = shift; - my $key = shift; - my @val = @_; - - $key = lc($key) if( $self->{nocase} ); - - # Add the parameter the the parent's list if it isn't there yet - push(@{$self->{parms}}, $key) unless (grep /^\Q$key\E$/, @{$self->{parms}}); - - if (@val > 1) { - $self->{v}{$key} = @val; - } else { - $self->{v}{$key} = shift @val; - } - - return $self->{v}{$key}; -} # end STORE - - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::DELETE -# -# Args: $key -# $key The key to remove from the hash -# -# Description: Removes the specified key from the hash -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2001Apr04 Fixed -nocase bug JW -# ---------------------------------------------------------- -sub DELETE { - my $self = shift; - my $key = shift; - - $key = lc($key) if( $self->{nocase} ); -# @{$self->{parms}{$sect}} = grep !/^$parm$/, @{$self->{parms}{$sect}}; - return delete $self->{v}{$key}; -} # end DELETE - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::CLEAR -# -# Args: (None) -# -# Description: Empties the entire hash -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# ---------------------------------------------------------- -sub CLEAR { - my $self = shift; - - foreach ( keys %{$self->{v}}) { - $self->DELETE($_); - } # end foreach - - return $self; -} # end CLEAR - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::EXISTS -# -# Args: $key -# $key The key to look for -# -# Description: Returns whether the key exists -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# 2001Apr04 Fixed -nocase bug JW -# ---------------------------------------------------------- -sub EXISTS { - my $self = shift; - my $key = shift; - $key = lc($key) if( $self->{nocase} ); - return exists $self->{v}{$key}; -} # end EXISTS - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::FIRSTKEY -# -# Args: (None) -# -# Description: Returns the first key in the hash -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# ---------------------------------------------------------- -sub FIRSTKEY { - my $self = shift; - - # Reset the each() iterator - my $a = keys %{$self->{v}}; - - return each %{$self->{v}}; -} # end FIRST KEY - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::NEXTKEY -# -# Args: $last -# $last The last key accessed by the interator -# -# Description: Returns the next key in line -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# ---------------------------------------------------------- -sub NEXTKEY { - my $self = shift; - my $last = shift; - - return each %{$self->{v}}; -} # end NEXTKEY - - -# ---------------------------------------------------------- -# Sub: Config::IniFiles::_section::DESTROY -# -# Args: (None) -# -# Description: Called on cleanup -# ---------------------------------------------------------- -# Date Modification Author -# ---------------------------------------------------------- -# ---------------------------------------------------------- -sub DESTROY { - # my $self = shift -} # end DESTROY - -# Eliminate annoying warnings -if ($^W) { - $Config::IniFiles::VERSION = $Config::IniFiles::VERSION; -} - -1; - -=head1 DIAGNOSTICS - -=head2 @Config::IniFiles::errors - -Contains a list of errors encountered while parsing the configuration -file. If the I method returns B, check the value of this -to find out what's wrong. This value is reset each time a config file -is read. - -=head1 BUGS - -=over 3 - -=item * - -The output from [Re]WriteConfig/OutputConfig might not be as pretty as -it can be. Comments are tied to whatever was immediately below them. -And case is not preserved for Section and Parameter names if the -nocase -option was used. - -=item * - -No locking is done by [Re]WriteConfig. When writing servers, take -care that only the parent ever calls this, and consider making your -own backup. - -=back - -=head1 Data Structure - -Note that this is only a reference for the package maintainers - one of the -upcoming revisions to this package will include a total clean up of the -data structure. - - $iniconf->{cf} = "config_file_name" - ->{startup_settings} = \%orginal_object_parameters - ->{firstload} = 0 - ->{nocase} = 0 - ->{reloadwarn} = 0 - ->{sects} = \@sections - ->{sCMT}{$sect} = \@comment_lines - ->{group}{$group} = \@group_members - ->{parms}{$sect} = \@section_parms - ->{EOT}{$sect}{$parm} = "end of text string" - ->{pCMT}{$sect}{$parm} = \@comment_lines - ->{v}{$sect}{$parm} = $value OR \@values - -=head1 AUTHOR and ACKNOWLEDGEMENTS - -The original code was written by Scott Hutton. -Then handled for a time by Rich Bowen (thanks!), -It is now managed by Jeremy Wadsack, -with many contributions from various other people. - -In particular, special thanks go to (in roughly chronological order): - -Bernie Cosell, Alan Young, Alex Satrapa, Mike Blazer, Wilbert van de Pieterman, -Steve Campbell, Robert Konigsberg, Scott Dellinger, R. Bernstein, -Daniel Winkelmann, Pires Claudio, Adrian Phillips, -Marek Rouchal, Luc St Louis, Adam Fischler, Kay R?ke, Matt Wilson, -Raviraj Murdeshwar and Slaven Rezic, Florian Pfaff - -Geez, that's a lot of people. And apologies to the folks who were missed. - -If you want someone to bug about this, that would be: - - Jeremy Wadsack - -If you want more information, or want to participate, go to: - - http://sourceforge.net/projects/config-inifiles/ - -Please send bug reports to config-inifiles-bugs @ lists.sourceforge.net - -Development discussion occurs on the mailing list -config-inifiles-dev @ lists.sourceforge.net, which you can subscribe -to by going to the project web site (link above). - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 Change log - - $Log: IniFiles.pm,v $ - Revision 1.1.1.1 2005/10/24 19:14:40 slash5234 - Affelio Firm Engine - - Revision 1.1.1.1 2005/06/14 03:53:29 slash5234 - Initial version (0.9.4+) - - Revision 1.1 2005/05/01 01:48:15 slash - *** empty log message *** - - Revision 2.38 2003/05/14 01:30:32 wadg - - fixed RewriteConfig and ReadConfig to work with open file handles - - added a test to ensure that blank files throw no warnings - - added a test for error messages from malformed lines - - Revision 2.37 2003/01/31 23:00:35 wadg - Updated t/07misc test 4 to remove warning - - Revision 2.36 2002/12/18 01:43:11 wadg - - Improved error message when an invalid line is encountered in INI file - - Fixed bug 649220; importing a non-file-based object into a file one - no longer destroys the original object - - Revision 2.33 2002/11/12 14:48:16 grail - Addresses feature request - [ 403496 ] A simple change will allow support on more platforms - - Revision 2.32 2002/11/12 14:15:44 grail - Addresses bug - [225971] Respect Read-Only Permissions of File System - - Revision 2.31 2002/10/29 01:45:47 grail - [ 540867 ] Add GetFileName method - - Revision 2.30 2002/10/15 18:51:07 wadg - Patched to stopwarnings about utf8 usage. - - Revision 2.29 2002/08/15 21:33:58 wadg - - Support for UTF Byte-Order-Mark (Raviraj Murdeshwar) - - Made tests portable to Mac (p. kent) - - Made file parsing portable for s390/EBCDIC, etc. (Adam Fischler) - - Fixed import bug with Perl 5.8.0 (Marek Rouchal) - - Fixed precedence bug in WriteConfig (Luc St Louis) - - Fixed broken group detection in SetGroupMember and RemoveGroupMember (Kay R?ke) - - Added line continuation character (/) support (Marek Rouchal) - - Added configurable comment character support (Marek Rouchal) - - Revision 2.28 2002/07/04 03:56:05 grail - Changes for resolving bug 447532 - _section::FETCH should return array ref for multiline values. - - Revision 2.27 2001/12/20 16:03:49 wadg - - Fixed bug introduced in new valid file check where ';' comments in first lines were not considered valid - - Rearranged some tests to put them in the proper files (case and -default) - - Added more comment test to cover more cases - - Fixed first two comments tests which weren't doing anything - - Revision 2.26 2001/12/19 22:20:50 wadg - #481513 Recognize badly formatted files - - Revision 2.25 2001/12/12 20:44:48 wadg - Update to bring CVS version in synch - - Revision 2.24 2001/12/07 10:03:06 wadg - 222444 Ability to load from arbitrary source - - Revision 2.23 2001/12/07 09:35:06 wadg - Forgot to include updates t/test.ini - - Revision 2.22 2001/12/06 16:52:39 wadg - Fixed bugs 482353,233372. Updated doc for new mgr. - - Revision 2.21 2001/08/14 01:49:06 wadg - Bug fix: multiple blank lines counted as one - Patched README change log to include recent updates - - Revision 2.20 2001/06/07 02:49:52 grail - - Added checks for method parameters being defined - - fixed some regexes to make them stricter - - Fixed greps to make them consistent through the code (also a vain - attempt to help my editors do syntax colouring properly) - - Added AddSection method, replaced chunk of ReadConfig with AddSection - - Added case handling stuff to more methods - - Added RemoveGroupMember - - Made variable names more consistent through OO methods - - Restored Unix EOLs - - Revision 2.19 2001/04/04 23:33:40 wadg - Fixed case sensitivity bug - - Revision 2.18 2001/03/30 04:41:08 rbowen - Small documentation change in IniFiles.pm - pod2* was choking on misplaces - =item tags. And I regenerated the README - The main reason for this release is that the MANIFEST in the 2.17 version was - missing one of the new test suite files, and that is included in this - re-release. - - Revision 2.17 2001/03/21 21:05:12 wadg - Documentation edits - - Revision 2.16 2001/03/21 19:59:09 wadg - 410327 -default not in original; 233255 substring parameters - - Revision 2.15 2001/01/30 11:46:48 rbowen - Very minor documentation bug fixed. - - Revision 2.14 2001/01/08 18:02:32 wadg - [Bug #127325] Fixed proken import; changelog; moved - - Revision 2.13 2000/12/18 07:14:41 wadg - [Bugs# 122441,122437] Alien EOLs and OO delete method - - Revision 2.12 2000/12/18 04:59:37 wadg - [Bug #125524] Writing multiline of 2 with tied hash - - Revision 2.11 2000/12/16 12:53:13 grail - [BUG #122455] Problem with File Permissions - - Revision 2.10 2000/12/13 17:40:18 rbowen - Updated version number so that CPAN will stop being angry with us. - - Revision 1.18 2000/12/08 00:45:35 grail - Change as requested by Jeremy Wadsack, for Bug 123146 - - Revision 1.17 2000/12/07 15:32:36 grail - Further patch to duplicate sections bug, and replacement of repeated values handling code. - - Revision 1.14 2000/11/29 11:26:03 grail - Updates for task 22401 (no more reloadsig) and 22402 (Group and GroupMember doco) - - Revision 1.13 2000/11/28 12:41:42 grail - Added test for being able to add sections with wierd names like section|version2 - - Revision 1.11 2000/11/24 21:20:11 rbowen - Resolved SourceForge bug #122445 - a parameter should be split from its value on the first = sign encountered, not on the last one. Added test suite to test this, and put test case in test.ini - - Revision 1.10 2000/11/24 20:40:58 rbowen - Updated MANIFEST to have file list of new files in t/ - Updated IniFiles.pm to have mention of sourceforge addresses, rather than rcbowen.com addresses - Regenerated README from IniFiles.pm - - Revision 1.9 2000/11/23 05:08:08 grail - Fixed documentation for bug 122443 - Check that INI files can be created from scratch. - - Revision 1.1.1.1 2000/11/10 03:04:01 rbowen - Initial checkin of the Config::IniFiles source to SourceForge - - Revision 1.8 2000/10/17 01:52:55 rbowen - Patch from Jeremy. Fixed "defined" warnings. - - Revision 1.7 2000/09/21 11:19:17 rbowen - Mostly documentation changes. I moved the change log into the POD rather - than having it in a separate Changes file. This allows people to see the - changes in the Readme before they download the module. Now I just - need to make sure I remember to regenerate the Readme every time I do - a commit. - - - 1.6 September 19, 2000 by JW, AS - * Applied several patches submitted to me by Jeremy and Alex. - * Changed version number to the CVS version number, so that I won't - have to think about changing it ever again. Big version change - should not be taken as a huge leap forward. - - 0.12 September 13, 2000 by JW/WADG - * Added documentation to clarify autovivification issues when - creating new sections - * Fixed version number (Oops!) - - 0.11 September 13, 2000 by JW/WADG - * Applied patch to Group and GroupMembers functions to return empty - list when no groups are present (submitted by John Bass, Sep 13) - - 0.10 September 13, 2000 by JW/WADG - * Fixed reference in POD to ReWriteFile. changes to RewriteConfig - * Applied patch for failed open bug submitted by Mordechai T. Abzug Aug 18 - * Doc'd behavior of failed open - * Removed planned SIG testing from test.pl as SIGs have been removed - * Applied patch from Thibault Deflers to fix bug in parameter list - when a parameter value is undef - - 0.09 - Hey! Where's the change log for 0.09? - - 0.08 - 2000-07-30 Adrian Phillips - - * test.pl: Fixed some tests which use $\, and made those that try - to check a non existant val check against ! defined. - - * IniFiles.pm: hopefully fixed use of $\ when this is unset - (problems found when running tests with -w). Similar problem with - $/ which can be undefined and trying to return a val which does - not exist. Modified val docs section to indicate a undef return - when this occurs. - - 0.07 - Looks like we missed a change log for 0.07. Bummer. - - 0.06 Sun Jun 25, 2000 by Daniel Winkelmann - * Patch for uninitialized value bug in newval and setval - - 0.05 Sun Jun 18, 2000 by RBOW - * Added something to shut up -w on VERSIONS - * Removed unused variables - - 0.04 Thu Jun 15 - Fri Jun 16, 2000 by JW/WADG - * Added support for -import option on ->new - * Added support for tying a hash - * Edited POD for grammer, clarity and updates - * Updated test.pl file - * Fixed bug in multiline/single line output - * Fixed bug in default handling with tie interface - * Added bugs to test.pl for regression - * Fixed bug in {group} vs. {groups} property (first is valid) - * Fixed return value for empty {sects} or {parms}{$sect} in - Sections and Parameters methods - - 0.03 Thu Jun 15, 2000 by RBOW - * Modifications to permit 'use strict', and to get 'make test' working - again. - - 0.02 Tue Jun 13, 2000 by RBOW - * Fixed bug reported by Bernie Cosell - Sections, Parameters, - and GroupMembers return undef if there are no sections, - parameters, or group members. These functions now return - () if the particular value is undefined. - * Added some contributed documentation, from Alex Satrapa, explaining - how the internal data structure works. - * Set up a project on SourceForge. (Not a change, but worth - noting). - * Added Groups method to return a list of section groups. - - 0.01 Mon Jun 12, 2000 by RBOW - Some general code cleanup, in preparation for changes to - come. Put up Majordomo mailing list and sent invitation to - various people to join it. - -=cut -#[JW for editor]:mode=perl:tabSize=8:indentSize=2:noTabs=true:indentOnEnter=true: - Index: affelio_farm/admin/skelton/affelio/extlib/Config/Tiny.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Config/Tiny.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Config/Tiny.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Config/Tiny.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Config/Tiny.pm Tue Oct 25 04:20:49 2005 @@ -1,245 +0,0 @@ -package Config::Tiny; - -# If you thought Config::Simple was small... - -use 5.004; -use strict; - -use vars qw{$VERSION $errstr}; -BEGIN { - $VERSION = '2.01'; - $errstr = ''; -} - -# Create an empty object -sub new { bless {}, shift } - -# Create an object from a file -sub read { - my $class = ref $_[0] ? ref shift : shift; - - # Check the file - my $file = shift or return $class->_error( 'You did not specify a file name' ); - return $class->_error( "File '$file' does not exist" ) unless -e $file; - return $class->_error( "'$file' is a directory, not a file" ) unless -f _; - return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; - - # Slurp in the file - local $/ = undef; - open CFG, $file or return $class->_error( "Failed to open file '$file': $!" ); - my $contents = ; - close CFG; - - $class->read_string( $contents ); -} - -# Create an object from a string -sub read_string { - my $class = ref $_[0] ? ref shift : shift; - my $self = bless {}, $class; - return undef unless defined $_[0]; - - # Parse the file - my $ns = '_'; - my $counter = 0; - foreach ( split /(?:\015{1,2}\012|\015|\012)/, shift ) { - $counter++; - - # Skip comments and empty lines - next if /^\s*(?:\#|\;|$)/; - - # Handle section headers - if ( /^\s*\[(.+?)\]\s*$/ ) { - # Create the sub-hash if it doesn't exist. - # Without this sections without keys will not - # appear at all in the completed struct. - $self->{$ns = $1} ||= {}; - next; - } - - # Handle properties - if ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) { - $self->{$ns}->{$1} = $2; - next; - } - - return $self->_error( "Syntax error at line $counter: '$_'" ); - } - - $self; -} - -# Save an object to a file -sub write { - my $self = shift; - my $file = shift or return $self->_error( 'No file name provided' ); - - # Write it to the file - open( CFG, '>'. $file ) - or return $self->_error( "Failed to open file '$file' for writing: $!" ); - print CFG $self->write_string; - close CFG; -} - -# Save an object to a string -sub write_string { - my $self = shift; - - my $contents = ''; - foreach my $section ( sort { (($b eq '_') <=> ($a eq '_')) || ($a cmp $b) } keys %$self ) { - my $block = $self->{$section}; - $contents .= "\n" if length $contents; - $contents .= "[$section]\n" unless $section eq '_'; - foreach my $property ( sort keys %$block ) { - $contents .= "$property=$block->{$property}\n"; - } - } - - $contents; -} - -# Error handling -sub errstr { $errstr } -sub _error { $errstr = $_[1]; undef } - -1; - -__END__ - -=pod - -=head1 NAME - -Config::Tiny - Read/Write .ini style files with as little code as possible - -=head1 SYNOPSIS - - # In your configuration file - rootproperty=blah - - [section] - one=twp - three= four - Foo =Bar - empty= - - # In your program - use Config::Tiny; - - # Create a config - my $Config = Config::Tiny->new(); - - # Open the config - $Config = Config::Tiny->read( 'file.conf' ); - - # Reading properties - my $rootproperty = $Config->{_}->{rootproperty}; - my $one = $Config->{section}->{one}; - my $Foo = $Config->{section}->{Foo}; - - # Changing data - $Config->{newsection} = { this => 'that' }; # Add a section - $Config->{section}->{Foo} = 'Not Bar!'; # Change a value - delete $Config->{_}; # Delete a value or section - - # Save a config - $Config->write( 'file.conf' ); - -=head1 DESCRIPTION - -Config::Tiny is a perl class to read and write .ini style configuration files -with as little code as possible, reducing load time and memory overhead. -Memory usage is normally scoffed at in Perl, but in my opinion should be -at least kept in mind. - -This module is primarily for reading human written files, and anything we -write shouldn't need to have documentation/comments. If you need something -with more power, move up to Config::Simple, Config::General or one of the -many other Config:: modules. To rephrase, Config::Tiny does not preserve -your comments, whitespace, or the order of your config file. - -=head1 CONFIGURATION FILE SYNTAX - -Files are the same as windows .ini files, for example. - - [section] - var1=value1 - var2=value2 - -If a property is outside of a section, it will be assigned to the root -section, available at C<$Config-E{_}>. - -Lines starting with '#' or ';' are comments, and blank lines are ignored. - -When writing back to the config file, any comments are discarded. - -=head1 METHODS - -=head2 new - -The constructor C creates and returns an empty Config::Tiny object. - -=head2 read $filename - -The C constructor reads a config file, and returns a new Config::Tiny -object containing the properties in the file. - -Returns the object on success, or C on error. - -=head2 read_string $string; - -The C method takes as argument the contents of a config file as a string -and returns the Config::Tiny object for it. - -=head2 write - -The C generates the file for the properties, and writes it -to disk. - -Returns true on success or C on error. - -=head2 write_string - -Generates the file for the object and returns it as a string. - -=head2 errstr - -When an error occurs, you can retrieve the error message either from the -C<$Config::Tiny::errstr> variable, or using the C method. - -=head1 SUPPORT - -Bugs should be reported via the CPAN bug tracker at - -L - -For other issues, or commercial enhancement or support, contact the author. - -=head1 TO DO - -I'm debating adding a get and set method to get or set a section.key based -value... - -Implementation is left as an exercise for the reader. - -=head1 AUTHOR - -Adam Kennedy (Maintainer), L, cpan @ ali.as - -Thanks to Sherzod Ruzmetov for Config::Simple, -which inspired this module by being not quite "simple" enough for me :) - -=head1 SEE ALSO - -L, L - -=head1 COPYRIGHT - -Copyright 2002 - 2005 Adam Kennedy. All rights reserved. -This program is free software; you can redistribute -it and/or modify it under the same terms as Perl itself. - -The full text of the license can be found in the -LICENSE file included with this module. - -=cut From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:49 +0900 Subject: [Affelio-cvs 656] CVS update: affelio_farm/admin/skelton/affelio/extlib/Crypt Message-ID: <20051024192049.A6D0D2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Crypt/DH.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Crypt/DH.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Crypt/DH.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Crypt/DH.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Crypt/DH.pm Tue Oct 25 04:20:49 2005 @@ -1,243 +0,0 @@ -# $Id: DH.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Crypt::DH; -use strict; - -use Math::BigInt lib => "GMP,Pari"; -our $VERSION = '0.05'; - -sub new { - my $class = shift; - my $dh = bless {}, $class; - - my %param = @_; - for my $w (qw( p g priv_key )) { - next unless exists $param{$w}; - $dh->$w(delete $param{$w}); - } - die "Unknown parameters to constructor: " . join(", ", keys %param) if %param; - - $dh; -} - -BEGIN { - no strict 'refs'; - for my $meth (qw( p g pub_key priv_key )) { - *$meth = sub { - my($key, $value) = @_; - if (ref $value eq 'Math::BigInt') { - $key->{$meth} = $value; - } - elsif (ref $value eq 'Math::Pari') { - $key->{$meth} = Math::BigInt->new(Math::Pari::pari2pv($value)); - } - elsif (defined $value && !(ref $value)) { - $key->{$meth} = Math::BigInt->new($value); - } - elsif (defined $value) { - die "Unknown parameter type to $meth: $value\n"; - } - my $ret = $key->{$meth} || ""; - $ret; - }; - } -} - -sub generate_keys { - my $dh = shift; - - unless (defined $dh->{priv_key}) { - my $i = _bitsize($dh->{p}) - 1; - $dh->{priv_key} = - $Crypt::Random::VERSION ? - Crypt::Random::makerandom_itv(Strength => 0, Uniform => 1, - Lower => 1, Upper => $dh->{p} - 1) : - _makerandom_itv($i, 1, $dh->{p} - 1); - } - - $dh->{pub_key} = $dh->{g}->copy->bmodpow($dh->{priv_key}, $dh->{p}); -} - -sub compute_key { - my $dh = shift; - my $pub_key = shift; - $pub_key->copy->bmodpow($dh->{priv_key}, $dh->{p}); -} -*compute_secret = \&compute_key; - -sub _bitsize { - return length($_[0]->as_bin) - 2; -} - -sub _makerandom_itv { - my ($size, $min_inc, $max_exc) = @_; - - while (1) { - my $r = _makerandom($size); - return $r if $r >= $min_inc && $r < $max_exc; - } -} - -sub _makerandom { - my $size = shift; - - my $bytes = int($size / 8) + ($size % 8 ? 1 : 0); - - my $rand; - if (-e "/dev/urandom") { - my $fh; - open($fh, '/dev/urandom') - or die "Couldn't open /dev/urandom"; - my $got = sysread $fh, $rand, $bytes; - die "Didn't read all bytes from urandom" unless $got == $bytes; - close $fh; - } else { - for (1..$bytes) { - $rand .= chr(int(rand(256))); - } - } - - my $bits = unpack("b*", $rand); - die unless length($bits) >= $size; - - Math::BigInt->new('0b' . substr($bits, 0, $size)); -} - -1; -__END__ - -=head1 NAME - -Crypt::DH - Diffie-Hellman key exchange system - -=head1 SYNOPSIS - - use Crypt::DH; - my $dh = Crypt::DH->new; - $dh->g($g); - $dh->p($p); - - ## Generate public and private keys. - $dh->generate_keys; - - $my_pub_key = $dh->pub_key; - - ## Send $my_pub_key to "other" party, and receive "other" - ## public key in return. - - ## Now compute shared secret from "other" public key. - my $shared_secret = $dh->compute_secret( $other_pub_key ); - -=head1 DESCRIPTION - -I is a Perl implementation of the Diffie-Hellman key -exchange system. Diffie-Hellman is an algorithm by which two -parties can agree on a shared secret key, known only to them. -The secret is negotiated over an insecure network without the -two parties ever passing the actual shared secret, or their -private keys, between them. - -=head1 THE ALGORITHM - -The algorithm generally works as follows: Party A and Party B -choose a property I

and a property I; these properties are -shared by both parties. Each party then computes a random private -key integer I, where the length of I is at -most (number of bits in I

) - 1. Each party then computes a -public key based on I, I, and I

; the exact value -is - - g ^ priv_key mod p - -The parties exchange these public keys. - -The shared secret key is generated based on the exchanged public -key, the private key, and I

. If the public key of Party B is -denoted I, then the shared secret is equal to - - pub_key_B ^ priv_key mod p - -The mathematical principles involved insure that both parties will -generate the same shared secret key. - -More information can be found in PKCS #3 (Diffie-Hellman Key -Agreement Standard): - - http://www.rsasecurity.com/rsalabs/pkcs/pkcs-3/ - -=head1 USAGE - -I implements the core routines needed to use -Diffie-Hellman key exchange. To actually use the algorithm, -you'll need to start with values for I

and I; I

is a -large prime, and I is a base which must be larger than 0 -and less than I

. - -I uses I internally for big-integer -calculations. All accessor methods (I

, I, I, and -I) thus return I objects, as does the -I method. The accessors, however, allow setting with a -scalar decimal string, hex string (^0x), Math::BigInt object, or -Math::Pari object (for backwards compatibility). - -=head2 $dh = Crypt::DH->new([ %param ]). - -Constructs a new I object and returns the object. -I<%param> may include none, some, or all of the keys I

, I, and -I. - -=head2 $dh->p([ $p ]) - -Given an argument I<$p>, sets the I

parameter (large prime) for -this I object. - -Returns the current value of I

. (as a Math::BigInt object) - -=head2 $dh->g([ $g ]) - -Given an argument I<$g>, sets the I parameter (base) for -this I object. - -Returns the current value of I. - -=head2 $dh->generate_keys - -Generates the public and private key portions of the I -object, assuming that you've already filled I

and I with -appropriate values. - -If you've provided a priv_key, it's used, otherwise a random priv_key -is created using either Crypt::Random (if already loaded), or -/dev/urandom, or Perl's rand, in that order. - -=head2 $dh->compute_secret( $public_key ) - -Given the public key I<$public_key> of Party B (the party with which -you're performing key negotiation and exchange), computes the shared -secret key, based on that public key, your own private key, and your -own large prime value (I

). - -The historical method name "compute_key" is aliased to this for -compatibility. - -=head2 $dh->priv_key([ $priv_key ]) - -Returns the private key. Given an argument I<$priv_key>, sets the -I parameter for this I object. - -=head2 $dh->pub_key - -Returns the public key. - -=head1 AUTHOR & COPYRIGHT - -Benjamin Trott, ben @ rhumba.pair.com - -Brad Fitzpatrick, brad @ danga.com - -Except where otherwise noted, Crypt::DH is Copyright 2001 -Benjamin Trott. All rights reserved. Crypt::DH is free -software; you may redistribute it and/or modify it under -the same terms as Perl itself. - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/Crypt/RC5.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Crypt/RC5.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Crypt/RC5.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Crypt/RC5.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Crypt/RC5.pm Tue Oct 25 04:20:49 2005 @@ -1,152 +0,0 @@ -#---------------------------------------------------------------------------# -# Crypt::RC5 -# Date Written: 23-Nov-2001 10:47:02 AM -# Last Modified: 05-Nov-2002 09:52:18 AM -# Author: Kurt Kincaid -# Copyright (c) 2002, Kurt Kincaid -# All Rights Reserved -# -# NOTICE: RC5 is a fast block cipher designed by Ronald Rivest -# for RSA Data Security (now RSA Security) in 1994. It is a -# parameterized algorithm with a variable block size, a variable -# key size, and a variable number of rounds. This particular -# implementation is 32 bit. As such, it is suggested that a minimum -# of 12 rounds be performed. -#---------------------------------------------------------------------------# - -package Crypt::RC5; - -use Exporter; -use integer; -use strict; -no strict 'refs'; -use vars qw/ $VERSION @EXPORT_OK @ISA @S /; - - @ ISA = qw(Exporter); - @ EXPORT_OK = qw($VERSION RC5); -$VERSION = '2.00'; - -sub new ($$$) { - my ( $class, $key, $rounds ) = @_; - my $self = bless {}, $class; - my @temp = unpack( "C*", $key ); - my $newKey; - foreach my $temp ( @temp ) { - $temp = sprintf( "%lx", $temp ); - if ( length( $temp ) < 2 ) { - $temp = "0" . $temp; - } - $newKey .= $temp; - } - my @L = unpack "V*", pack "H*x3", $newKey; - my $T = 0xb7e15163; - @S = ( M( $T ), map { $T = M( $T + 0x9e3779b9 ) } 0 .. 2 * $rounds ); - my ( $A, $B ) = ( 0, 0 ); - for ( 0 .. 3 * ( @S > @L ? @S : @L ) - 1 ) { - $A = $S[ $_ % @S ] = ROTL( 3, M( $S[ $_ % @S ] ) + M( $A + $B ) ); - $B = $L[ $_ % @L ] = ROTL( M( $A + $B ), M( $L[ $_ % @L ] ) + M( $A + $B ) ); - } - return $self; -} - -sub encrypt ($$) { - my ( $self, $text ) = @_; - return $self->RC5( $text ); -} - -sub decrypt ($$) { - my ( $self, $text ) = @_; - return $self->RC5( $text, 1 ); -} - -sub decrypt_iv ($$$) { - my ( $self, $text, $iv ) = @_; - die "iv must be 8 bytes long" if length( $iv ) != 8; - - my @ivnum = unpack( 'C*', $iv . $text ); - my @plain = unpack( 'C*', $self->RC5( $text, 1 ) ); - for ( 0 .. @plain ) { $plain[ $_ ] ^= $ivnum[ $_ ]; } - return pack( 'C*', @plain ); -} - -sub RC5 ($$) { - my ( $self, $text, $decrypt ) = @_; - my $last; - my $processed = ''; - while ( $text =~ /(.{8})/gs ) { - $last = $'; - $processed .= Process( $1, $decrypt ); - } - if ( length( $text ) % 8 ) { - $processed .= Process( $last, $decrypt ); - } - return $processed; -} - -sub M ($) { - return unpack( 'V', pack( 'V', pop ) ); -} - -sub ROTL ($$) { - my ( $x, $n ); - ( $x = pop ) << ( $n = 31 & pop ) | 2**$n - 1 & $x >> 32 - $n; -} - -sub ROTR ($$) { - ROTL( 32 - ( 31 & shift ), shift ); -} - -sub Process ($$) { - my ( $block, $decrypt ) = @_; - my ( $A, $B ) = unpack "V2", $block . "\0" x 3; - $_ = '$A = M( $A+$S[0] );$B = M( $B+$S[1] )'; - $decrypt || eval; - for ( 1 .. @S - 2 ) { - if ( $decrypt ) { - $B = $A ^ ROTR( $A, M( $B - $S[ @S - $_ ] ) ); - } else { - $A = M( $S[ $_ + 1 ] + ROTL( $B, $A ^ $B ) ); - } - $A ^= $B ^= $A ^= $B; - } - $decrypt && ( y/+/-/, eval ); - return pack "V2", $A, $B; -} - -1; -__END__ - - -=head1 NAME - -Crypt::RC5 - Perl implementation of the RC5 encryption algorithm. - -=head1 SYNOPSIS - - use Crypt::RC5; - - $ref = Crypt::RC5->new( $key, $rounds ); - $ciphertext = $ref->encrypt( $plaintext ); - - $ref2 = Crypt::RC5->new( $key, $rounds ); - $plaintext2 = $ref2->decrypt( $ciphertext ); - -=head1 DESCRIPTION - -RC5 is a fast block cipher designed by Ronald Rivest for RSA Data Security (now RSA Security) in 1994. It is a parameterized algorithm with a variable block size, a variable key size, and a variable number of rounds. This particular implementation is 32 bit. As such, it is suggested that a minimum of 12 rounds be performed. - -Core logic based on "RC5 in 6 lines of perl" at http://www.cypherspace.org - -=head1 AUTHOR - -Kurt Kincaid (sifukurt @ yahoo.com) - -Ronald Rivest for RSA Security, Inc. - -=head1 SEE ALSO - -L, L, L - -=cut - - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:49 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:49 +0900 Subject: [Affelio-cvs 657] CVS update: affelio_farm/admin/skelton/affelio/extlib/Digest/Perl Message-ID: <20051024192049.CB8822AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Digest/Perl/MD5.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Digest/Perl/MD5.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Digest/Perl/MD5.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Digest/Perl/MD5.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Digest/Perl/MD5.pm Tue Oct 25 04:20:49 2005 @@ -1,421 +0,0 @@ -#!/usr/local/bin/perl -w -#$Id: MD5.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ - -package Digest::Perl::MD5; -use strict; -use integer; -use Exporter; -use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK); - - @ EXPORT_OK = qw(md5 md5_hex md5_base64); - - @ ISA = 'Exporter'; -$VERSION = '1.5'; - -# I-Vektor -sub A() { 0x67_45_23_01 } -sub B() { 0xef_cd_ab_89 } -sub C() { 0x98_ba_dc_fe } -sub D() { 0x10_32_54_76 } - -# for internal use -sub MAX() { 0xFFFFFFFF } - -# padd a message to a multiple of 64 -sub padding($) { - my $l = length (my $msg = shift() . chr(128)); - $msg .= "\0" x (($l%64<=56?56:120)-$l%64); - $l = ($l-1)*8; - $msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16); -} - - -sub rotate_left($$) { - #$_[0] << $_[1] | $_[0] >> (32 - $_[1]); - #my $right = $_[0] >> (32 - $_[1]); - #my $rmask = (1 << $_[1]) - 1; - ($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1]) ) & ((1 << $_[1]) - 1)); - #$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1); -} - -sub gen_code { - # Discard upper 32 bits on 64 bit archs. - my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : ''; -# FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;", -# GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", - my %f = ( - FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", - GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;", - HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;", - II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", - ); - #unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} } - #else { %f = %{$CODES{'64bit'}} } - - my %s = ( # shift lengths - S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14, - S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10, - S43 => 15, S44 => 21 - ); - - my $insert = ""; - while() { - chomp; - next unless /^[FGHI]/; - my ($func, @ x) = split /,/; - my $c = $f{$func}; - $c =~ s/X(\d)/$x[$1]/g; - $c =~ s/(S\d{2})/$s{$1}/; - $c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//; - - #my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))"; - $c = "\$r = $2; - $1 = ((\$r << $3) | ((\$r >> (32 - $3)) & ((1 << $3) - 1))) + $4"; - $insert .= "\t$c\n"; - } - - my $dump = ' - sub round { - my ($a,$b,$c,$d) = @_[0 .. 3]; - my $r; - - ' . $insert . ' - $_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK . - ', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . '; - }'; - eval $dump; - #print "$dump\n"; - #exit 0; -} - -gen_code(); - - -# object part of this module -sub new { - my $class = shift; - bless {}, ref($class) || $class; -} - -sub reset { - my $self = shift; - delete $self->{data}; - $self -} - -sub add(@) { - my $self = shift; - $self->{data} .= join'', @_; - $self -} - -sub addfile { - my ($self,$fh) = @_; - if (!ref($fh) && ref(\$fh) ne "GLOB") { - require Symbol; - $fh = Symbol::qualify($fh, scalar caller); - } - $self->{data} .= do{local$/;<$fh>}; - $self -} - -sub digest { - md5(shift->{data}) -} - -sub hexdigest { - md5_hex(shift->{data}) -} - -sub b64digest { - md5_base64(shift->{data}) -} - -sub md5(@) { - my $message = padding(join'', @ _); - my ($a,$b,$c,$d) = (A,B,C,D); - my $i; - for $i (0 .. (length $message)/64-1) { - my @X = unpack 'V16', substr $message,$i*64,64; - ($a,$b,$c,$d) = round($a,$b,$c,$d, @ X); - } - pack 'V4',$a,$b,$c,$d; -} - - -sub md5_hex(@) { - unpack 'H*', &md5; -} - -sub md5_base64(@) { - encode_base64(&md5); -} - - -sub encode_base64 ($) { - my $res; - while ($_[0] =~ /(.{1,45})/gs) { - $res .= substr pack('u', $1), 1; - chop $res; - } - $res =~ tr|` -_|AA-Za-z0-9+/|;#` - chop $res;chop $res; - $res; -} - -1; - -=head1 NAME - -Digest::MD5::Perl - Perl implementation of Ron Rivests MD5 Algorithm - -=head1 DISCLAIMER - -This is B an interface (like C) but a Perl implementation of MD5. -It is written in perl only and because of this it is slow but it works without C-Code. -You should use C instead of this module if it is available. -This module is only usefull for - -=over 4 - -=item - -computers where you cannot install C (e.g. lack of a C-Compiler) - -=item - -encrypting only small amounts of data (less than one million bytes). I use it to -hash passwords. - -=item - -educational purposes - -=back - -=head1 SYNOPSIS - - # Functional style - use Digest::MD5 qw(md5 md5_hex md5_base64); - - $hash = md5 $data; - $hash = md5_hex $data; - $hash = md5_base64 $data; - - - # OO style - use Digest::MD5; - - $ctx = Digest::MD5->new; - - $ctx->add($data); - $ctx->addfile(*FILE); - - $digest = $ctx->digest; - $digest = $ctx->hexdigest; - $digest = $ctx->b64digest; - -=head1 DESCRIPTION - -This modules has the same interface as the much faster C. So you can -easily exchange them, e.g. - - BEGIN { - eval { - require Digest::MD5; - import Digest::MD5 'md5_hex' - }; - if ($@) { # ups, no Digest::MD5 - require Digest::Perl::MD5; - import Digest::Perl::MD5 'md5_hex' - } - } - -If the C module is available it is used and if not you take -C. - -You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5 -and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it -cannot load its object files. - -For a detailed Documentation see the C module. - -=head1 EXAMPLES - -The simplest way to use this library is to import the md5_hex() -function (or one of its cousins): - - use Digest::Perl::MD5 'md5_hex'; - print 'Digest is ', md5_hex('foobarbaz'), "\n"; - -The above example would print out the message - - Digest is 6df23dc03f9b54cc38a0fc1483df6e21 - -provided that the implementation is working correctly. The same -checksum can also be calculated in OO style: - - use Digest::MD5; - - $md5 = Digest::MD5->new; - $md5->add('foo', 'bar'); - $md5->add('baz'); - $digest = $md5->hexdigest; - - print "Digest is $digest\n"; - -=head1 LIMITATIONS - -This implementation of the MD5 algorithm has some limitations: - -=over 4 - -=item - -It's slow, very slow. I've done my very best but Digest::MD5 is still about 135 times faster. -You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull -for encrypting small amounts of data like passwords. - -=item - -You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. You should use C -for those amounts of data. - -=item - -C loads all data to encrypt into memory. This is a todo. - -=back - -=head1 SEE ALSO - -L - -L - -RFC 1321 - -=head1 COPYRIGHT - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - Copyright 2000 Christian Lackas, Imperia Software Solutions - Copyright 1998-1999 Gisle Aas. - Copyright 1995-1996 Neil Winton. - Copyright 1991-1992 RSA Data Security, Inc. - -The MD5 algorithm is defined in RFC 1321. The basic C code -implementing the algorithm is derived from that in the RFC and is -covered by the following copyright: - -=over 4 - -=item - -Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All -rights reserved. - -License to copy and use this software is granted provided that it -is identified as the "RSA Data Security, Inc. MD5 Message-Digest -Algorithm" in all material mentioning or referencing this software -or this function. - -License is also granted to make and use derivative works provided -that such works are identified as "derived from the RSA Data -Security, Inc. MD5 Message-Digest Algorithm" in all material -mentioning or referencing the derived work. - -RSA Data Security, Inc. makes no representations concerning either -the merchantability of this software or the suitability of this -software for any particular purpose. It is provided "as is" -without express or implied warranty of any kind. - -These notices must be retained in any copies of any part of this -documentation and/or software. - -=back - -This copyright does not prohibit distribution of any version of Perl -containing this extension under the terms of the GNU or Artistic -licenses. - -=head1 AUTHORS - -The original MD5 interface was written by Neil Winton -(C). - -C was made by Gisle Aas (I took his Interface -and part of the documentation) - -Thanks to Guido Flohr for his 'use integer'-hint. - -This release was made by Christian Lackas . - -=cut - -__DATA__ -FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */ -FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */ -FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */ -FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */ -FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */ -FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */ -FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */ -FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */ -FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */ -FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */ -FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */ -FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */ -FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */ -FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */ -FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */ -FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */ -GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */ -GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */ -GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */ -GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */ -GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */ -GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */ -GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */ -GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */ -GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */ -GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */ -GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */ -GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */ -GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */ -GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */ -GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */ -GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */ -HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */ -HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */ -HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */ -HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */ -HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */ -HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */ -HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */ -HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */ -HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */ -HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */ -HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */ -HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */ -HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */ -HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */ -HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */ -HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */ -II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */ -II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */ -II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */ -II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */ -II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */ -II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */ -II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */ -II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */ -II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */ -II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */ -II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */ -II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */ -II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */ -II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */ -II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */ -II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */ From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:50 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:50 +0900 Subject: [Affelio-cvs 658] CVS update: affelio_farm/admin/skelton/affelio/extlib/I18N Message-ID: <20051024192050.36D9A2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/I18N/Collate.pm diff -u affelio_farm/admin/skelton/affelio/extlib/I18N/Collate.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/I18N/Collate.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/I18N/Collate.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/I18N/Collate.pm Tue Oct 25 04:20:50 2005 @@ -1,196 +0,0 @@ -package I18N::Collate; - -use strict; -our $VERSION = '1.00'; - -=head1 NAME - -I18N::Collate - compare 8-bit scalar data according to the current locale - -=head1 SYNOPSIS - - use I18N::Collate; - setlocale(LC_COLLATE, 'locale-of-your-choice'); - $s1 = new I18N::Collate "scalar_data_1"; - $s2 = new I18N::Collate "scalar_data_2"; - -=head1 DESCRIPTION - - *** - - WARNING: starting from the Perl version 5.003_06 - the I18N::Collate interface for comparing 8-bit scalar data - according to the current locale - - HAS BEEN DEPRECATED - - That is, please do not use it anymore for any new applications - and please migrate the old applications away from it because its - functionality was integrated into the Perl core language in the - release 5.003_06. - - See the perllocale manual page for further information. - - *** - -This module provides you with objects that will collate -according to your national character set, provided that the -POSIX setlocale() function is supported on your system. - -You can compare $s1 and $s2 above with - - $s1 le $s2 - -to extract the data itself, you'll need a dereference: $$s1 - -This module uses POSIX::setlocale(). The basic collation conversion is -done by strxfrm() which terminates at NUL characters being a decent C -routine. collate_xfrm() handles embedded NUL characters gracefully. - -The available locales depend on your operating system; try whether -C shows them or man pages for "locale" or "nlsinfo" or the -direct approach C or C or -C. Not all the locales that your vendor supports -are necessarily installed: please consult your operating system's -documentation and possibly your local system administration. The -locale names are probably something like C or -C, for example C is the Swiss (CH) -variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western -European character set. - -=cut - -# I18N::Collate.pm -# -# Author: Jarkko Hietaniemi > -# Helsinki University of Technology, Finland -# -# Acks: Guy Decoux > understood -# overloading magic much deeper than I and told -# how to cut the size of this code by more than half. -# (my first version did overload all of lt gt eq le ge cmp) -# -# Purpose: compare 8-bit scalar data according to the current locale -# -# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm() -# -# Exports: setlocale 1) -# collate_xfrm 2) -# -# Overloads: cmp # 3) -# -# Usage: use I18N::Collate; -# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4) -# $s1 = new I18N::Collate "scalar_data_1"; -# $s2 = new I18N::Collate "scalar_data_2"; -# -# now you can compare $s1 and $s2: $s1 le $s2 -# to extract the data itself, you need to deref: $$s1 -# -# Notes: -# 1) this uses POSIX::setlocale -# 2) the basic collation conversion is done by strxfrm() which -# terminates at NUL characters being a decent C routine. -# collate_xfrm handles embedded NUL characters gracefully. -# 3) due to cmp and overload magic, lt le eq ge gt work also -# 4) the available locales depend on your operating system; -# try whether "locale -a" shows them or man pages for -# "locale" or "nlsinfo" work or the more direct -# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls". -# Not all the locales that your vendor supports -# are necessarily installed: please consult your -# operating system's documentation. -# The locale names are probably something like -# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N', -# for example 'fr_CH.ISO8859-1' is the Swiss (CH) -# variant of French (fr), ISO Latin (8859) 1 (-1) -# which is the Western European character set. -# -# Updated: 19961005 -# -# --- - -use POSIX qw(strxfrm LC_COLLATE); -use warnings::register; - -require Exporter; - -our @ISA = qw(Exporter); -our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); -our @EXPORT_OK = qw(); - -use overload qw( -fallback 1 -cmp collate_cmp -); - -our($LOCALE, $C); - -our $please_use_I18N_Collate_even_if_deprecated = 0; -sub new { - my $new = $_[1]; - - if (warnings::enabled() && $] >= 5.003_06) { - unless ($please_use_I18N_Collate_even_if_deprecated) { - warnings::warn <<___EOD___; -*** - - WARNING: starting from the Perl version 5.003_06 - the I18N::Collate interface for comparing 8-bit scalar data - according to the current locale - - HAS BEEN DEPRECATED - - That is, please do not use it anymore for any new applications - and please migrate the old applications away from it because its - functionality was integrated into the Perl core language in the - release 5.003_06. - - See the perllocale manual page for further information. - -*** -___EOD___ - $please_use_I18N_Collate_even_if_deprecated++; - } - } - - bless \$new; -} - -sub setlocale { - my ($category, $locale) = @_[0,1]; - - POSIX::setlocale($category, $locale) if (defined $category); - # the current $LOCALE - $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; -} - -sub C { - my $s = ${$_[0]}; - - $C->{$LOCALE}->{$s} = collate_xfrm($s) - unless (defined $C->{$LOCALE}->{$s}); # cache when met - - $C->{$LOCALE}->{$s}; -} - -sub collate_xfrm { - my $s = $_[0]; - my $x = ''; - - for (split(/(\000+)/, $s)) { - $x .= (/^\000/) ? $_ : strxfrm("$_\000"); - } - - $x; -} - -sub collate_cmp { - &C($_[0]) cmp &C($_[1]); -} - -# init $LOCALE - -&I18N::Collate::setlocale(); - -1; # keep require happy Index: affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags.pm diff -u affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags.pm Tue Oct 25 04:20:50 2005 @@ -1,887 +0,0 @@ - -# Time-stamp: "2004-10-06 23:26:33 ADT" -# Sean M. Burke - -require 5.000; -package I18N::LangTags; -use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %Panic); -require Exporter; - @ ISA = qw(Exporter); - @ EXPORT = qw(); - @ EXPORT_OK = qw(is_language_tag same_language_tag - extract_language_tags super_languages - similarity_language_tag is_dialect_of - locale2language_tag alternate_language_tags - encode_language_tag panic_languages - implicate_supers - implicate_supers_strictly - ); -%EXPORT_TAGS = ('ALL' => \@EXPORT_OK); - -$VERSION = "0.35"; - -sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function - - -=head1 NAME - -I18N::LangTags - functions for dealing with RFC3066-style language tags - -=head1 SYNOPSIS - - use I18N::LangTags(); - -...or specify whichever of those functions you want to import, like so: - - use I18N::LangTags qw(implicate_supers similarity_language_tag); - -All the exportable functions are listed below -- you're free to import -only some, or none at all. By default, none are imported. If you -say: - - use I18N::LangTags qw(:ALL) - -...then all are exported. (This saves you from having to use -something less obvious like C.) - -If you don't import any of these functions, assume a C<&I18N::LangTags::> -in front of all the function names in the following examples. - -=head1 DESCRIPTION - -Language tags are a formalism, described in RFC 3066 (obsoleting -1766), for declaring what language form (language and possibly -dialect) a given chunk of information is in. - -This library provides functions for common tasks involving language -tags as they are needed in a variety of protocols and applications. - -Please see the "See Also" references for a thorough explanation -of how to correctly use language tags. - -=over - -=cut - -########################################################################### - -=item * the function is_language_tag($lang1) - -Returns true iff $lang1 is a formally valid language tag. - - is_language_tag("fr") is TRUE - is_language_tag("x-jicarilla") is FALSE - (Subtags can be 8 chars long at most -- 'jicarilla' is 9) - - is_language_tag("sgn-US") is TRUE - (That's American Sign Language) - - is_language_tag("i-Klikitat") is TRUE - (True without regard to the fact noone has actually - registered Klikitat -- it's a formally valid tag) - - is_language_tag("fr-patois") is TRUE - (Formally valid -- altho descriptively weak!) - - is_language_tag("Spanish") is FALSE - is_language_tag("french-patois") is FALSE - (No good -- first subtag has to match - /^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066) - - is_language_tag("x-borg-prot2532") is TRUE - (Yes, subtags can contain digits, as of RFC3066) - -=cut - -sub is_language_tag { - - ## Changes in the language tagging standards may have to be reflected here. - - my($tag) = lc($_[0]); - - return 0 if $tag eq "i" or $tag eq "x"; - # Bad degenerate cases that the following - # regexp would erroneously let pass - - return $tag =~ - /^(?: # First subtag - [xi] | [a-z]{2,3} - ) - (?: # Subtags thereafter - - # separator - [a-z0-9]{1,8} # subtag - )* - $/xs ? 1 : 0; -} - -########################################################################### - -=item * the function extract_language_tags($whatever) - -Returns a list of whatever looks like formally valid language tags -in $whatever. Not very smart, so don't get too creative with -what you want to feed it. - - extract_language_tags("fr, fr-ca, i-mingo") - returns: ('fr', 'fr-ca', 'i-mingo') - - extract_language_tags("It's like this: I'm in fr -- French!") - returns: ('It', 'in', 'fr') - (So don't just feed it any old thing.) - -The output is untainted. If you don't know what tainting is, -don't worry about it. - -=cut - -sub extract_language_tags { - - ## Changes in the language tagging standards may have to be reflected here. - - my($text) = - $_[0] =~ m/(.+)/ # to make for an untainted result - ? $1 : '' - ; - - return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags - $text =~ - m/ - \b - (?: # First subtag - [iIxX] | [a-zA-Z]{2,3} - ) - (?: # Subtags thereafter - - # separator - [a-zA-Z0-9]{1,8} # subtag - )* - \b - /xsg - ); -} - -########################################################################### - -=item * the function same_language_tag($lang1, $lang2) - -Returns true iff $lang1 and $lang2 are acceptable variant tags -representing the same language-form. - - same_language_tag('x-kadara', 'i-kadara') is TRUE - (The x/i- alternation doesn't matter) - same_language_tag('X-KADARA', 'i-kadara') is TRUE - (...and neither does case) - same_language_tag('en', 'en-US') is FALSE - (all-English is not the SAME as US English) - same_language_tag('x-kadara', 'x-kadar') is FALSE - (these are totally unrelated tags) - same_language_tag('no-bok', 'nb') is TRUE - (no-bok is a legacy tag for nb (Norwegian Bokmal)) - -C works by just seeing whether -C is the same as -C. - -(Yes, I know this function is named a bit oddly. Call it historic -reasons.) - -=cut - -sub same_language_tag { - my $el1 = &encode_language_tag($_[0]); - return 0 unless defined $el1; - # this avoids the problem of - # encode_language_tag($lang1) eq and encode_language_tag($lang2) - # being true if $lang1 and $lang2 are both undef - - return $el1 eq &encode_language_tag($_[1]) ? 1 : 0; -} - -########################################################################### - -=item * the function similarity_language_tag($lang1, $lang2) - -Returns an integer representing the degree of similarity between -tags $lang1 and $lang2 (the order of which does not matter), where -similarity is the number of common elements on the left, -without regard to case and to x/i- alternation. - - similarity_language_tag('fr', 'fr-ca') is 1 - (one element in common) - similarity_language_tag('fr-ca', 'fr-FR') is 1 - (one element in common) - - similarity_language_tag('fr-CA-joual', - 'fr-CA-PEI') is 2 - similarity_language_tag('fr-CA-joual', 'fr-CA') is 2 - (two elements in common) - - similarity_language_tag('x-kadara', 'i-kadara') is 1 - (x/i- doesn't matter) - - similarity_language_tag('en', 'x-kadar') is 0 - similarity_language_tag('x-kadara', 'x-kadar') is 0 - (unrelated tags -- no similarity) - - similarity_language_tag('i-cree-syllabic', - 'i-cherokee-syllabic') is 0 - (no B elements in common!) - -=cut - -sub similarity_language_tag { - my $lang1 = &encode_language_tag($_[0]); - my $lang2 = &encode_language_tag($_[1]); - # And encode_language_tag takes care of the whole - # no-nyn==nn, i-hakka==zh-hakka, etc, things - - # NB: (i-sil-...)? (i-sgn-...)? - - return undef if !defined($lang1) and !defined($lang2); - return 0 if !defined($lang1) or !defined($lang2); - - my @l1_subtags = split('-', $lang1); - my @l2_subtags = split('-', $lang2); - my $similarity = 0; - - while(@l1_subtags and @l2_subtags) { - if(shift(@l1_subtags) eq shift(@l2_subtags)) { - ++$similarity; - } else { - last; - } - } - return $similarity; -} - -########################################################################### - -=item * the function is_dialect_of($lang1, $lang2) - -Returns true iff language tag $lang1 represents a subform of -language tag $lang2. - -B - - is_dialect_of('en-US', 'en') is TRUE - (American English IS a dialect of all-English) - - is_dialect_of('fr-CA-joual', 'fr-CA') is TRUE - is_dialect_of('fr-CA-joual', 'fr') is TRUE - (Joual is a dialect of (a dialect of) French) - - is_dialect_of('en', 'en-US') is FALSE - (all-English is a NOT dialect of American English) - - is_dialect_of('fr', 'en-CA') is FALSE - - is_dialect_of('en', 'en' ) is TRUE - is_dialect_of('en-US', 'en-US') is TRUE - (B these are degenerate cases) - - is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE - (the x/i thing doesn't matter, nor does case) - - is_dialect_of('nn', 'no') is TRUE - (because 'nn' (New Norse) is aliased to 'no-nyn', - as a special legacy case, and 'no-nyn' is a - subform of 'no' (Norwegian)) - -=cut - -sub is_dialect_of { - - my $lang1 = &encode_language_tag($_[0]); - my $lang2 = &encode_language_tag($_[1]); - - return undef if !defined($lang1) and !defined($lang2); - return 0 if !defined($lang1) or !defined($lang2); - - return 1 if $lang1 eq $lang2; - return 0 if length($lang1) < length($lang2); - - $lang1 .= '-'; - $lang2 .= '-'; - return - (substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0; -} - -########################################################################### - -=item * the function super_languages($lang1) - -Returns a list of language tags that are superordinate tags to $lang1 --- it gets this by removing subtags from the end of $lang1 until -nothing (or just "i" or "x") is left. - - super_languages("fr-CA-joual") is ("fr-CA", "fr") - - super_languages("en-AU") is ("en") - - super_languages("en") is empty-list, () - - super_languages("i-cherokee") is empty-list, () - ...not ("i"), which would be illegal as well as pointless. - -If $lang1 is not a valid language tag, returns empty-list in -a list context, undef in a scalar context. - -A notable and rather unavoidable problem with this method: -"x-mingo-tom" has an "x" because the whole tag isn't an -IANA-registered tag -- but super_languages('x-mingo-tom') is -('x-mingo') -- which isn't really right, since 'i-mingo' is -registered. But this module has no way of knowing that. (But note -that same_language_tag('x-mingo', 'i-mingo') is TRUE.) - -More importantly, you assume I that superordinates of -$lang1 are mutually intelligible with $lang1. Consider this -carefully. - -=cut - -sub super_languages { - my $lang1 = $_[0]; - return() unless defined($lang1) && &is_language_tag($lang1); - - # a hack for those annoying new (2001) tags: - $lang1 =~ s/^nb\b/no-bok/i; # yes, backwards - $lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards - $lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way - # i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark - - my @l1_subtags = split('-', $lang1); - - ## Changes in the language tagging standards may have to be reflected here. - - # NB: (i-sil-...)? - - my @supers = (); - foreach my $bit (@l1_subtags) { - push @supers, - scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit; - } - pop @supers if @supers; - shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s; - return reverse @supers; -} - -########################################################################### - -=item * the function locale2language_tag($locale_identifier) - -This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1") -and maps it to a language tag. If it's not mappable (as with, -notably, "C" and "POSIX"), this returns empty-list in a list context, -or undef in a scalar context. - - locale2language_tag("en") is "en" - - locale2language_tag("en_US") is "en-US" - - locale2language_tag("en_US.ISO8859-1") is "en-US" - - locale2language_tag("C") is undef or () - - locale2language_tag("POSIX") is undef or () - - locale2language_tag("POSIX") is undef or () - -I'm not totally sure that locale names map satisfactorily to language -tags. Think REAL hard about how you use this. YOU HAVE BEEN WARNED. - -The output is untainted. If you don't know what tainting is, -don't worry about it. - -=cut - -sub locale2language_tag { - my $lang = - $_[0] =~ m/(.+)/ # to make for an untainted result - ? $1 : '' - ; - - return $lang if &is_language_tag($lang); # like "en" - - $lang =~ tr<_><->; # "en_US" -> en-US - $lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s; # "en_US.ISO8859-1" -> en-US - # it_IT.utf8 @ euro => it-IT - - return $lang if &is_language_tag($lang); - - return; -} - -########################################################################### - -=item * the function encode_language_tag($lang1) - -This function, if given a language tag, returns an encoding of it such -that: - -* tags representing different languages never get the same encoding. - -* tags representing the same language always get the same encoding. - -* an encoding of a formally valid language tag always is a string -value that is defined, has length, and is true if considered as a -boolean. - -Note that the encoding itself is B a formally valid language tag. -Note also that you cannot, currently, go from an encoding back to a -language tag that it's an encoding of. - -Note also that you B consider the encoded value as atomic; i.e., -you should not consider it as anything but an opaque, unanalysable -string value. (The internals of the encoding method may change in -future versions, as the language tagging standard changes over time.) - -C returns undef if given anything other than a -formally valid language tag. - -The reason C exists is because different language -tags may represent the same language; this is normally treatable with -C, but consider this situation: - -You have a data file that expresses greetings in different languages. -Its format is "[language tag]=[how to say 'Hello']", like: - - en-US=Hiho - fr=Bonjour - i-mingo=Hau' - -And suppose you write a program that reads that file and then runs as -a daemon, answering client requests that specify a language tag and -then expect the string that says how to greet in that language. So an -interaction looks like: - - greeting-client asks: fr - greeting-server answers: Bonjour - -So far so good. But suppose the way you're implementing this is: - - my %greetings; - die unless open(IN, ") { - chomp; - next unless /^([^=]+)=(.+)/s; - my($lang, $expr) = ($1, $2); - $greetings{$lang} = $expr; - } - close(IN); - -at which point %greetings has the contents: - - "en-US" => "Hiho" - "fr" => "Bonjour" - "i-mingo" => "Hau'" - -And suppose then that you answer client requests for language $wanted -by just looking up $greetings{$wanted}. - -If the client asks for "fr", that will look up successfully in -%greetings, to the value "Bonjour". And if the client asks for -"i-mingo", that will look up successfully in %greetings, to the value -"Hau'". - -But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the -lookup in %greetings fails. That's the Wrong Thing. - -You could instead do lookups on $wanted with: - - use I18N::LangTags qw(same_language_tag); - my $repsonse = ''; - foreach my $l2 (keys %greetings) { - if(same_language_tag($wanted, $l2)) { - $response = $greetings{$l2}; - last; - } - } - -But that's rather inefficient. A better way to do it is to start your -program with: - - use I18N::LangTags qw(encode_language_tag); - my %greetings; - die unless open(IN, ") { - chomp; - next unless /^([^=]+)=(.+)/s; - my($lang, $expr) = ($1, $2); - $greetings{ - encode_language_tag($lang) - } = $expr; - } - close(IN); - -and then just answer client requests for language $wanted by just -looking up - - $greetings{encode_language_tag($wanted)} - -And that does the Right Thing. - -=cut - -sub encode_language_tag { - # Only similarity_language_tag() is allowed to analyse encodings! - - ## Changes in the language tagging standards may have to be reflected here. - - my($tag) = $_[0] || return undef; - return undef unless &is_language_tag($tag); - - # For the moment, these legacy variances are few enough that - # we can just handle them here with regexps. - $tag =~ s/^iw\b/he/i; # Hebrew - $tag =~ s/^in\b/id/i; # Indonesian - $tag =~ s/^cre\b/cr/i; # Cree - $tag =~ s/^jw\b/jv/i; # Javanese - $tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger - $tag =~ s/^[ix]-navajo\b/nv/i; # Navajo - $tag =~ s/^ji\b/yi/i; # Yiddish - # SMB 2003 -- Hm. There's a bunch of new XXX->YY variances now, - # but maybe they're all so obscure I can ignore them. "Obscure" - # meaning either that the language is obscure, and/or that the - # XXX form was extant so briefly that it's unlikely it was ever - # used. I hope. - # - # These go FROM the simplex to complex form, to get - # similarity-comparison right. And that's okay, since - # similarity_language_tag is the only thing that - # analyzes our output. - $tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka - $tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal - $tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk - - $tag =~ s/^[xiXI]-//s; - # Just lop off any leading "x/i-" - - return "~" . uc($tag); -} - -#-------------------------------------------------------------------------- - -=item * the function alternate_language_tags($lang1) - -This function, if given a language tag, returns all language tags that -are alternate forms of this language tag. (I.e., tags which refer to -the same language.) This is meant to handle legacy tags caused by -the minor changes in language tag standards over the years; and -the x-/i- alternation is also dealt with. - -Note that this function does I try to equate new (and never-used, -and unusable) -ISO639-2 three-letter tags to old (and still in use) ISO639-1 -two-letter equivalents -- like "ara" -> "ar" -- because -"ara" has I been in use as an Internet language tag, -and RFC 3066 stipulates that it never should be, since a shorter -tag ("ar") exists. - -Examples: - - alternate_language_tags('no-bok') is ('nb') - alternate_language_tags('nb') is ('no-bok') - alternate_language_tags('he') is ('iw') - alternate_language_tags('iw') is ('he') - alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka') - alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka') - alternate_language_tags('en') is () - alternate_language_tags('x-mingo-tom') is ('i-mingo-tom') - alternate_language_tags('x-klikitat') is ('i-klikitat') - alternate_language_tags('i-klikitat') is ('x-klikitat') - -This function returns empty-list if given anything other than a formally -valid language tag. - -=cut - -my %alt = qw( i x x i I X X I ); -sub alternate_language_tags { - my $tag = $_[0]; - return() unless &is_language_tag($tag); - - my @em; # push 'em real goood! - - # For the moment, these legacy variances are few enough that - # we can just handle them here with regexps. - - if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1"; - } elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1"; - - } elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1"; - } elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1"; - - } elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1"; - } elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1"; - - } elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1"; - } elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1"; - - } elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1"; - } elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1"; - - } elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1"; - } elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1"; - - } elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1"; - } elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1"; - - } elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1"; - } elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1"; - } - - push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/; - return @em; -} - -########################################################################### - -{ - # Init %Panic... - - my @panic = ( # MUST all be lowercase! - # Only large ("national") languages make it in this list. - # If you, as a user, are so bizarre that the /only/ language - # you claim to accept is Galician, then no, we won't do you - # the favor of providing Catalan as a panic-fallback for - # you. Because if I start trying to add "little languages" in - # here, I'll just go crazy. - - # Scandinavian lgs. All based on opinion and hearsay. - 'sv' => [qw(nb no da nn)], - 'da' => [qw(nb no sv nn)], # I guess - [qw(no nn nb)], [qw(no nn nb sv da)], - 'is' => [qw(da sv no nb nn)], - 'fo' => [qw(da is no nb nn sv)], # I guess - - # I think this is about the extent of tolerable intelligibility - # among large modern Romance languages. - 'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French - 'ca' => [qw(es pt it fr)], - 'es' => [qw(ca it fr pt)], - 'it' => [qw(es fr ca pt)], - 'fr' => [qw(es it ca pt)], - - # Also assume that speakers of the main Indian languages prefer - # to read/hear Hindi over English - [qw( - as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur - )] => 'hi', - # Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri, - # Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya, - # Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu. - 'hi' => [qw(bn pa as or)], - # I welcome finer data for the other Indian languages. - # E.g., what should Oriya's list be, besides just Hindi? - - # And the panic languages for English is, of course, nil! - - # My guesses at Slavic intelligibility: - ([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian - 'sr' => 'hr', 'hr' => 'sr', # Serb + Croat - 'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak - - 'ms' => 'id', 'id' => 'ms', # Malay + Indonesian - - 'et' => 'fi', 'fi' => 'et', # Estonian + Finnish - - #?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai - - ); - my($k,$v); - while(@panic) { - ($k,$v) = splice(@panic,0,2); - foreach my $k (ref($k) ? @$k : $k) { - foreach my $v (ref($v) ? @$v : $v) { - push @{$Panic{$k} ||= []}, $v unless $k eq $v; - } - } - } -} - -=item * the function @langs = panic_languages(@accept_languages) - -This function takes a list of 0 or more language -tags that constitute a given user's Accept-Language list, and -returns a list of tags for I (non-super) -languages that are probably acceptable to the user, to be -used I. - -For example, if a user accepts only 'ca' (Catalan) and -'es' (Spanish), and the documents/interfaces you have -available are just in German, Italian, and Chinese, then -the user will most likely want the Italian one (and not -the Chinese or German one!), instead of getting -nothing. So C returns -a list containing 'it' (Italian). - -English ('en') is I in the return list, but -whether it's at the very end or not depends -on the input languages. This function works by consulting -an internal table that stipulates what common -languages are "close" to each other. - -A useful construct you might consider using is: - - @fallbacks = super_languages(@accept_languages); - push @fallbacks, panic_languages( - @accept_languages, @fallbacks, - ); - -=cut - -sub panic_languages { - # When in panic or in doubt, run in circles, scream, and shout! - my(@out, %seen); - foreach my $t (@_) { - next unless $t; - next if $seen{$t}++; # so we don't return it or hit it again - # push @out, super_languages($t); # nah, keep that separate - push @out, @{ $Panic{lc $t} || next }; - } - return grep !$seen{$_}++, @out, 'en'; -} - -#--------------------------------------------------------------------------- -#--------------------------------------------------------------------------- - -=item * the function implicate_supers( ...languages... ) - -This takes a list of strings (which are presumed to be language-tags; -strings that aren't, are ignored); and after each one, this function -inserts super-ordinate forms that don't already appear in the list. -The original list, plus these insertions, is returned. - -In other words, it takes this: - - pt-br de-DE en-US fr pt-br-janeiro - -and returns this: - - pt-br pt de-DE de en-US en fr pt-br-janeiro - -This function is most useful in the idiom - - implicate_supers( I18N::LangTags::Detect::detect() ); - -(See L.) - - -=item * the function implicate_supers_strictly( ...languages... ) - -This works like C except that the implicated -forms are added to the end of the return list. - -In other words, implicate_supers_strictly takes a list of strings -(which are presumed to be language-tags; strings that aren't, are -ignored) and after the whole given list, it inserts the super-ordinate forms -of all given tags, minus any tags that already appear in the input list. - -In other words, it takes this: - - pt-br de-DE en-US fr pt-br-janeiro - -and returns this: - - pt-br de-DE en-US fr pt-br-janeiro pt de en - -The reason this function has "_strictly" in its name is that when -you're processing an Accept-Language list according to the RFCs, if -you interpret the RFCs quite strictly, then you would use -implicate_supers_strictly, but for normal use (i.e., common-sense use, -as far as I'm concerned) you'd use implicate_supers. - -=cut - -sub implicate_supers { - my @languages = grep is_language_tag($_), @_; - my %seen_encoded; - foreach my $lang (@languages) { - $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1 - } - - my(@output_languages); - foreach my $lang (@languages) { - push @output_languages, $lang; - foreach my $s ( I18N::LangTags::super_languages($lang) ) { - # Note that super_languages returns the longest first. - last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) }; - push @output_languages, $s; - } - } - return uniq( @output_languages ); - -} - -sub implicate_supers_strictly { - my @tags = grep is_language_tag($_), @_; - return uniq( @_, map super_languages($_), @_ ); -} - - - -########################################################################### -1; -__END__ - -=back - -=head1 ABOUT LOWERCASING - -I've considered making all the above functions that output language -tags return all those tags strictly in lowercase. Having all your -language tags in lowercase does make some things easier. But you -might as well just lowercase as you like, or call -C where appropriate. - -=head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS - -In some future version of I18N::LangTags, I plan to include support -for RFC2482-style language tags -- which are basically just normal -language tags with their ASCII characters shifted into Plane 14. - -=head1 SEE ALSO - -* L - -* RFC 3066, C, "Tags for the -Identification of Languages". (Obsoletes RFC 1766) - -* RFC 2277, C, "IETF Policy on -Character Sets and Languages". - -* RFC 2231, C, "MIME Parameter -Value and Encoded Word Extensions: Character Sets, Languages, and -Continuations". - -* RFC 2482, C, -"Language Tagging in Unicode Plain Text". - -* Locale::Codes, in -C - -* ISO 639-2, "Codes for the representation of names of languages", -including two-letter and three-letter codes, -C - -* The IANA list of registered languages (hopefully up-to-date), -C - -=head1 COPYRIGHT - -Copyright (c) 1998+ Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -The programs and documentation in this dist are distributed in -the hope that they 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 - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:50 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:50 +0900 Subject: [Affelio-cvs 659] CVS update: affelio_farm/admin/skelton/affelio/extlib/Jcode Message-ID: <20051024192050.8B2AF2AC020@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Jcode/Constants.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Jcode/Constants.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Jcode/Constants.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Jcode/Constants.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Jcode/Constants.pm Tue Oct 25 04:20:50 2005 @@ -1,63 +0,0 @@ -# -# $Id: Constants.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# - -package Jcode::Constants; - -use strict; -use vars qw($RCSID $VERSION); - -$RCSID = q$Id: Constants.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $; -$VERSION = do { my @r = (q$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Carp; - -BEGIN { - use Exporter; - use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - @ISA = qw(Exporter); - @EXPORT = qw(); - @EXPORT_OK = qw(%CHARCODE %ESC %RE); - %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK, @EXPORT ] ); -} - -use vars @EXPORT_OK; - -my %_0208 = ( - 1978 => '\e\$\@', - 1983 => '\e\$B', - 1990 => '\e&\@\e\$B', - ); - -%CHARCODE = ( - UNDEF_EUC => "\xa2\xae", # 〓 in EUC - UNDEF_SJIS => "\x81\xac", # 〓 in SJIS - UNDEF_JIS => "\xa2\xf7", # † -- used in unicode - UNDEF_UNICODE => "\x20\x20", # † -- used in unicode - ); - -%ESC = ( - JIS_0208 => "\e\$B", - JIS_0212 => "\e\$(D", - ASC => "\e\(B", - KANA => "\e\(I", - ); - -%RE = - ( - ASCII => '[\x00-\x7f]', - BIN => '[\x00-\x06\x7f\xff]', - EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]', - EUC_C => '[\xa1-\xfe][\xa1-\xfe]', - EUC_KANA => '\x8e[\xa1-\xdf]', - JIS_0208 => "$_0208{1978}|$_0208{1983}|$_0208{1990}", - JIS_0212 => "\e" . '\$\(D', - JIS_ASC => "\e" . '\([BJ]', - JIS_KANA => "\e" . '\(I', - SJIS_C => '[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]', - SJIS_KANA => '[\xa1-\xdf]', - UTF8 => '[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf]' - ); - -1; - Index: affelio_farm/admin/skelton/affelio/extlib/Jcode/H2Z.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Jcode/H2Z.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Jcode/H2Z.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Jcode/H2Z.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Jcode/H2Z.pm Tue Oct 25 04:20:50 2005 @@ -1,168 +0,0 @@ -# -# $Id: H2Z.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# - -package Jcode::H2Z; - -use strict; -use vars qw($RCSID $VERSION); - -$RCSID = q$Id: H2Z.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $; -$VERSION = do { my @r = (q$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Carp; - -use Jcode::Constants qw(:all); - -use vars qw(%_D2Z $_PAT_D2Z - %_Z2D $_PAT_Z2D - %_H2Z $_PAT_H2Z - %_Z2H $_PAT_Z2H); - -%_H2Z = ( - "\x8e\xa1" => "\xa1\xa3", #。 - "\x8e\xa2" => "\xa1\xd6", #「 - "\x8e\xa3" => "\xa1\xd7", #」 - "\x8e\xa4" => "\xa1\xa2", #、 - "\x8e\xa5" => "\xa1\xa6", #・ - "\x8e\xa6" => "\xa5\xf2", #ヲ - "\x8e\xa7" => "\xa5\xa1", #ァ - "\x8e\xa8" => "\xa5\xa3", #ィ - "\x8e\xa9" => "\xa5\xa5", #ゥ - "\x8e\xaa" => "\xa5\xa7", #ェ - "\x8e\xab" => "\xa5\xa9", #ォ - "\x8e\xac" => "\xa5\xe3", #ャ - "\x8e\xad" => "\xa5\xe5", #ュ - "\x8e\xae" => "\xa5\xe7", #ョ - "\x8e\xaf" => "\xa5\xc3", #ッ - "\x8e\xb0" => "\xa1\xbc", #ー - "\x8e\xb1" => "\xa5\xa2", #ア - "\x8e\xb2" => "\xa5\xa4", #イ - "\x8e\xb3" => "\xa5\xa6", #ウ - "\x8e\xb4" => "\xa5\xa8", #エ - "\x8e\xb5" => "\xa5\xaa", #オ - "\x8e\xb6" => "\xa5\xab", #カ - "\x8e\xb7" => "\xa5\xad", #キ - "\x8e\xb8" => "\xa5\xaf", #ク - "\x8e\xb9" => "\xa5\xb1", #ケ - "\x8e\xba" => "\xa5\xb3", #コ - "\x8e\xbb" => "\xa5\xb5", #サ - "\x8e\xbc" => "\xa5\xb7", #シ - "\x8e\xbd" => "\xa5\xb9", #ス - "\x8e\xbe" => "\xa5\xbb", #セ - "\x8e\xbf" => "\xa5\xbd", #ソ - "\x8e\xc0" => "\xa5\xbf", #タ - "\x8e\xc1" => "\xa5\xc1", #チ - "\x8e\xc2" => "\xa5\xc4", #ツ - "\x8e\xc3" => "\xa5\xc6", #テ - "\x8e\xc4" => "\xa5\xc8", #ト - "\x8e\xc5" => "\xa5\xca", #ナ - "\x8e\xc6" => "\xa5\xcb", #ニ - "\x8e\xc7" => "\xa5\xcc", #ヌ - "\x8e\xc8" => "\xa5\xcd", #ネ - "\x8e\xc9" => "\xa5\xce", #ノ - "\x8e\xca" => "\xa5\xcf", #ハ - "\x8e\xcb" => "\xa5\xd2", #ヒ - "\x8e\xcc" => "\xa5\xd5", #フ - "\x8e\xcd" => "\xa5\xd8", #ヘ - "\x8e\xce" => "\xa5\xdb", #ホ - "\x8e\xcf" => "\xa5\xde", #マ - "\x8e\xd0" => "\xa5\xdf", #ミ - "\x8e\xd1" => "\xa5\xe0", #ム - "\x8e\xd2" => "\xa5\xe1", #メ - "\x8e\xd3" => "\xa5\xe2", #モ - "\x8e\xd4" => "\xa5\xe4", #ヤ - "\x8e\xd5" => "\xa5\xe6", #ユ - "\x8e\xd6" => "\xa5\xe8", #ヨ - "\x8e\xd7" => "\xa5\xe9", #ラ - "\x8e\xd8" => "\xa5\xea", #リ - "\x8e\xd9" => "\xa5\xeb", #ル - "\x8e\xda" => "\xa5\xec", #レ - "\x8e\xdb" => "\xa5\xed", #ロ - "\x8e\xdc" => "\xa5\xef", #ワ - "\x8e\xdd" => "\xa5\xf3", #ン - "\x8e\xde" => "\xa1\xab", #゛ - "\x8e\xdf" => "\xa1\xac", #゜ -); - -%_D2Z = ( - "\x8e\xb6\x8e\xde" => "\xa5\xac", #ガ - "\x8e\xb7\x8e\xde" => "\xa5\xae", #ギ - "\x8e\xb8\x8e\xde" => "\xa5\xb0", #グ - "\x8e\xb9\x8e\xde" => "\xa5\xb2", #ゲ - "\x8e\xba\x8e\xde" => "\xa5\xb4", #ゴ - "\x8e\xbb\x8e\xde" => "\xa5\xb6", #ザ - "\x8e\xbc\x8e\xde" => "\xa5\xb8", #ジ - "\x8e\xbd\x8e\xde" => "\xa5\xba", #ズ - "\x8e\xbe\x8e\xde" => "\xa5\xbc", #ゼ - "\x8e\xbf\x8e\xde" => "\xa5\xbe", #ゾ - "\x8e\xc0\x8e\xde" => "\xa5\xc0", #ダ - "\x8e\xc1\x8e\xde" => "\xa5\xc2", #ヂ - "\x8e\xc2\x8e\xde" => "\xa5\xc5", #ヅ - "\x8e\xc3\x8e\xde" => "\xa5\xc7", #デ - "\x8e\xc4\x8e\xde" => "\xa5\xc9", #ド - "\x8e\xca\x8e\xde" => "\xa5\xd0", #バ - "\x8e\xcb\x8e\xde" => "\xa5\xd3", #ビ - "\x8e\xcc\x8e\xde" => "\xa5\xd6", #ブ - "\x8e\xcd\x8e\xde" => "\xa5\xd9", #ベ - "\x8e\xce\x8e\xde" => "\xa5\xdc", #ボ - "\x8e\xca\x8e\xdf" => "\xa5\xd1", #パ - "\x8e\xcb\x8e\xdf" => "\xa5\xd4", #ピ - "\x8e\xcc\x8e\xdf" => "\xa5\xd7", #プ - "\x8e\xcd\x8e\xdf" => "\xa5\xda", #ペ - "\x8e\xce\x8e\xdf" => "\xa5\xdd", #ポ - "\x8e\xb3\x8e\xde" => "\xa5\xf4", #ヴ -); - -# init only once; - -#$_PAT_D2Z = join("|", keys %_D2Z); -#$_PAT_H2Z = join("|", keys %_H2Z); - -%_Z2H = reverse %_H2Z; -%_Z2D = reverse %_D2Z; - -#$_PAT_Z2H = join("|", keys %_Z2H); -#$_PAT_Z2D = join("|", keys %_Z2D); - -sub h2z { - my $r_str = shift; - my ($keep_dakuten) = @_; - my $n = 0; - unless ($keep_dakuten){ - $n = ( - $$r_str =~ s( - ($RE{EUC_KANA} - (?:\x8e[\xde\xdf])?) - ){ - my $str = $1; - $_D2Z{$str} || $_H2Z{$str} || - # in case dakuten and handakuten are side-by-side! - $_H2Z{substr($str,0,2)} . $_H2Z{substr($str,2,2)}; - }eogx - ); - }else{ - $n = ( - $$r_str =~ s( - ($RE{EUC_KANA}) - ){ - $_H2Z{$1}; - }eogx - ); - } - $n; -} - -sub z2h { - my $r_str = shift; - my $n = ( - $$r_str =~ s( - ($RE{EUC_C}|$RE{EUC_0212}|$RE{EUC_KANA}) - ){ - $_Z2D{$1} || $_Z2H{$1} || $1; - }eogx - ); - $n; -} - -1; Index: affelio_farm/admin/skelton/affelio/extlib/Jcode/Tr.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Jcode/Tr.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Jcode/Tr.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Jcode/Tr.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Jcode/Tr.pm Tue Oct 25 04:20:50 2005 @@ -1,90 +0,0 @@ -# -# $Id: Tr.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# - -package Jcode::Tr; - -use strict; -use vars qw($VERSION $RCSID); - -$RCSID = q$Id: Tr.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $; -$VERSION = do { my @r = (q$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; - -use Carp; - -use Jcode::Constants qw(:all); -use vars qw(%_TABLE); - -sub tr { - # $prev_from, $prev_to, %table are persistent variables - my ($r_str, $from, $to, $opt) = @_; - my (@from, @to); - my $n = 0; - - undef %_TABLE; - &_maketable($from, $to, $opt); - - $$r_str =~ s( - ([\x80-\xff][\x00-\xff]|[\x00-\xff]) - ) - {defined($_TABLE{$1}) && ++$n ? - $_TABLE{$1} : $1}ogex; - - return $n; -} - -sub _maketable{ - my( $from, $to, $opt ) = @_; - $opt ||= ''; - $from =~ s/($RE{EUC_0212}-$RE{EUC_0212})/&_expnd3($1)/geo; - $from =~ s/($RE{EUC_KANA}-$RE{EUC_KANA})/&_expnd2($1)/geo; - $from =~ s/($RE{EUC_C }-$RE{EUC_C })/&_expnd2($1)/geo; - $from =~ s/($RE{ASCII }-$RE{ASCII })/&_expnd1($1)/geo; - $to =~ s/($RE{EUC_0212}-$RE{EUC_0212})/&_expnd3($1)/geo; - $to =~ s/($RE{EUC_KANA}-$RE{EUC_KANA})/&_expnd2($1)/geo; - $to =~ s/($RE{EUC_C }-$RE{EUC_C })/&_expnd2($1)/geo; - $to =~ s/($RE{ASCII }-$RE{ASCII })/&_expnd1($1)/geo; - - my @from = $from =~ /$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff]/go; - my @to = $to =~ /$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff]/go; - - push @to, ($opt =~ /d/ ? '' : $to[-1]) x ($#from - $#to) if $#to < $#from; - @_TABLE{@from} = @to; - -} - -sub _expnd1 { - my ($str) = @_; - # s/\\(.)/$1/og; # I dunno what this was doing!? - my($c1, $c2) = unpack('CxC', $str); - if ($c1 <= $c2) { - for ($str = ''; $c1 <= $c2; $c1++) { - $str .= pack('C', $c1); - } - } - return $str; -} - -sub _expnd2 { - my ($str) = @_; - my ($c1, $c2, $c3, $c4) = unpack('CCxCC', $str); - if ($c1 == $c3 && $c2 <= $c4) { - for ($str = ''; $c2 <= $c4; $c2++) { - $str .= pack('CC', $c1, $c2); - } - } - return $str; -} - -sub _expnd3 { - my ($str) = @_; - my ($c1, $c2, $c3, $c4, $c5, $c6) = unpack('CCCxCCC', $str); - if ($c1 == $c4 && $c2 == $c5 && $c3 <= $c6) { - for ($str = ''; $c3 <= $c6; $c3++) { - $str .= pack('CCC', $c1, $c2, $c3); - } - } - return $str; -} - -1; From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:50 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:50 +0900 Subject: [Affelio-cvs 660] CVS update: affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags Message-ID: <20051024192050.60FDC2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/ChangeLog diff -u affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/ChangeLog:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/ChangeLog:removed --- affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/ChangeLog:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/ChangeLog Tue Oct 25 04:20:50 2005 @@ -1,180 +0,0 @@ -Revision history for Perl module I18N::LangTags. - Time-stamp: "2004-07-01 14:28:23 ADT" - -2004-07-01 Sean M. Burke sburke @ cpan.org - - * Release 0.33 - - Minor bugfix version: - The test 80_all_env.t was erroneously failing for people with - LC_ALL or LC_MESSAGES set. Fixed. Thanks to everyone, especially - Nicholas Clark, who patiently helped out with this. - - -2004-06-20 Sean M. Burke sburke @ cpan.org - - * Release 0.32 - - Minor bugfix version: - The test 80_all_env.t was erroneously failing under MSWins that - had Win32::Locale installed. A workaround added. - - -2004-06-17 Sean M. Burke sburke @ cpan.org - - * Release 0.31 - - Corrected some unevennesses in when/whether the return values from - I18N::LangTags::Detect's various internal functions would be - downcased. Now they're /always/ downcased, and are /always/ fed - thru alternate_language_tags()! - - Also, spiffed up and generally improved the earlier test - 80_all_env.t, which not even I could make sense of, and I wrote - the damned thing. Now it's sane, and checks both scalar and - list return values. Thanks to Rafael Garcia-Suarez and the - various CPAN-Testers for prodding me to fix this. (Hopefully the - earlier problems /are/ now fixed! Otherwise there'll be another - version of this module out real soon!) - - -2004-03-30 Sean M. Burke sburke @ cpan.org - - * Release 0.30 - - New in I18N::LangTags : implicate_supers and - implicate_supers_strictly. - - New module: I18N::LangTags::Detect. - - Some new tests. - - Thanks to Autrijus Tang for catching some errors in my makefile! - - - -2003-10-10 Sean M. Burke sburke @ cpan.org - - * Release 0.29 - - Minor bugfix to I18N::LangTags::List code. Addition of the - is_decent function, and the 02decency.t test for it. - - Better Makefile. Thanks to everyone who told me about the - INSTALLDIRS trick. - - - -2003-07-20 Sean M. Burke sburke @ cpan.org - - * Release 0.28 - Doc fixes in I18N::LangTags, plus a few added variances (jw/jv, - cre/cr, etc.) - Lots of updates to I18N::LangTags::List - Deleted rfc3066.txt from dist. - Moved test.pl to t/01test.t and added more tests. - -2002-02-02 Sean M. Burke sburke @ cpan.org - - * Release 0.27 -- minor mods to ::List: - Fixing its entries for sv-se and sv-fi. - Typo-fixes and rewordings in the incidental Pod text elsewhere. - -2001-06-21 Sean M. Burke sburke @ cpan.org - - * Release 0.26 -- just making cosmetic changes - to test.pl, at Jarkko's request. - -2001-06-20 Sean M. Burke sburke @ cpan.org - - * Release 0.25 -- just tweaking panic_languages behavior - for Scandinavian languages. Much better now. - Slight tweak to ::List's entries for Greek. - -2001-06-20 Sean M. Burke sburke @ cpan.org - - * Release 0.24 - - * I18N::LangTags -- some elaborate hacks to make us - recognize legacy aliases like no-nyn == nn. - Added panic_languages(). - Added :ALL export tag. - Minor docs fixes, and spiffing up test.pl. - - * I18N::LangTags::List -- minor corrections; added - a few aliases. - -2001-05-29 Sean M. Burke sburke @ cpan.org - - * Release 0.23 - - * I18N::LangTags::List -- minor corrections. And is now - a module, not just documentation. - -2001-05-27 Sean M. Burke sburke @ cpan.org - - * Release 0.22 - - * Now bundling I18N::LangTags::List, a reference for lang tags, - replacing generate_language_table.plx and language_codes.txt - -2001-05-25 Sean M. Burke sburke @ cpan.org - - * Release 0.21 - - * extract_language_tags and locale2langauge_tag now - return untainted output. Useful if you feed tainted - things, like $ENV{'LANG'}. - -2001-03-13 Sean M. Burke sburke @ cpan.org - - * Release 0.20 - - * Added support for RFC 3066 tags: allowing three-letter primary - tags ("nav"), and allowing digits in subtags ("x-borg-prot3252"). - - * Changed all references from RFC 1766 to RFC 3066. - - * Now bundling fulltext of RFC 3066 in the dist. - - * Now bundling generate_language_table.plx and language_codes.txt - - * Added some nice tests to test.pl - - * Inverting order of listings in this ChangeLog file. - -2000-05-13 Sean M. Burke sburke @ cpan.org - - * Release 0.13 - - * Just noting my new email address. - -1999-03-06 Sean M. Burke sburke @ netadventure.net - - * Release 0.11 - - * Added functions - similarity_language_tag, is_dialect_of, - locale2language_tag, alternate_language_tags, and - encode_language_tag - -1998-12-14 Sean M. Burke sburke @ netadventure.net - - * Release 0.09 - - * Added function super_languages() - -1998-10-31 Sean M. Burke sburke @ netadventure.net - - * Release 0.08 - - * Just changes in the docs and bundle -- no change - in functionality. - -1998-04-02 Sean M. Burke sburke @ netadventure.net - - * Release 0.07 - - * First public release. - -[END OF CHANGELOG] Index: affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/Detect.pm diff -u affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/Detect.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/Detect.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/Detect.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/Detect.pm Tue Oct 25 04:20:50 2005 @@ -1,237 +0,0 @@ - -# Time-stamp: "2004-06-20 21:47:55 ADT" - -require 5; -package I18N::LangTags::Detect; -use strict; - -use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS - $USE_LITERALS $MATCH_SUPERS_TIGHTLY); - -BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } - # define the constant 'DEBUG' at compile-time - -$VERSION = "1.03"; - @ ISA = (); -use I18N::LangTags qw(alternate_language_tags locale2language_tag); - -sub _uniq { my %seen; return grep(!($seen{$_}++), @_); } -sub _normalize { - my(@languages) = - map lc($_), - grep $_, - map {; $_, alternate_language_tags($_) } @_; - return _uniq(@languages) if wantarray; - return $languages[0]; -} - -#--------------------------------------------------------------------------- -# The extent of our functional interface: - -sub detect () { return __PACKAGE__->ambient_langprefs; } - -#=========================================================================== - -sub ambient_langprefs { # always returns things untainted - my $base_class = $_[0]; - - return $base_class->http_accept_langs - if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI - # it's off in its own routine because it's complicated - - # Not running as a CGI: try to puzzle out from the environment - my @languages; - - foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) { - next unless $ENV{$envname}; - DEBUG and print "Noting \$$envname: $ENV{$envname}\n"; - push @languages, - map locale2language_tag($_), - # if it's a lg tag, fine, pass thru (untainted) - # if it's a locale ID, try converting to a lg tag (untainted), - # otherwise nix it. - - split m/[,:]/, - $ENV{$envname} - ; - last; # first one wins - } - - if($ENV{'IGNORE_WIN32_LOCALE'}) { - # no-op - } elsif(&_try_use('Win32::Locale')) { - # If we have that module installed... - push @languages, Win32::Locale::get_language() || '' - if defined &Win32::Locale::get_language; - } - return _normalize @languages; -} - -#--------------------------------------------------------------------------- - -sub http_accept_langs { - # Deal with HTTP "Accept-Language:" stuff. Hassle. - # This code is more lenient than RFC 3282, which you must read. - # Hm. Should I just move this into I18N::LangTags at some point? - no integer; - - my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'}; - # (always ends up untainting) - - return() unless defined $in and length $in; - - $in =~ s/\([^\)]*\)//g; # nix just about any comment - - if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) { - # Very common case: just one language tag - return _normalize $1; - } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) { - # Common case these days: just "foo, bar, baz" - return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g ); - } - - # Else it's complicated... - - $in =~ s/\s+//g; # Yes, we can just do without the WS! - my @in = $in =~ m/([^,]+)/g; - my %pref; - - my $q; - foreach my $tag (@in) { - next unless $tag =~ - m/^([a-zA-Z][-a-zA-Z]+) - (?: - ;q= - ( - \d* # a bit too broad of a RE, but so what. - (?: - \.\d+ - )? - ) - )? - $ - /sx - ; - $q = (defined $2 and length $2) ? $2 : 1; - #print "$1 with q=$q\n"; - push @{ $pref{$q} }, lc $1; - } - - return _normalize( - # Read off %pref, in descending key order... - map @{$pref{$_}}, - sort {$b <=> $a} - keys %pref - ); -} - -#=========================================================================== - -my %tried = (); - # memoization of whether we've used this module, or found it unusable. - -sub _try_use { # Basically a wrapper around "require Modulename" - # "Many men have tried..." "They tried and failed?" "They tried and died." - return $tried{$_[0]} if exists $tried{$_[0]}; # memoization - - my $module = $_[0]; # ASSUME sane module name! - { no strict 'refs'; - return($tried{$module} = 1) - if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"}); - # weird case: we never use'd it, but there it is! - } - - print " About to use $module ...\n" if DEBUG; - { - local $SIG{'__DIE__'}; - eval "require $module"; # used to be "use $module", but no point in that. - } - if($@) { - print "Error using $module \: $@\n" if DEBUG > 1; - return $tried{$module} = 0; - } else { - print " OK, $module is used\n" if DEBUG; - return $tried{$module} = 1; - } -} - -#--------------------------------------------------------------------------- -1; -__END__ - - -=head1 NAME - -I18N::LangTags::Detect - detect the user's language preferences - -=head1 SYNOPSIS - - use I18N::LangTags::Detect; - my @user_wants = I18N::LangTags::Detect::detect(); - -=head1 DESCRIPTION - -It is a common problem to want to detect what language(s) the user would -prefer output in. - -=head1 FUNCTIONS - -This module defines one public function, -C. This function is not exported -(nor is even exportable), and it takes no parameters. - -In scalar context, the function returns the most preferred language -tag (or undef if no preference was seen). - -In list context (which is usually what you want), -the function returns a -(possibly empty) list of language tags representing (best first) what -languages the user apparently would accept output in. You will -probably want to pass the output of this through -C -or -C, like so: - - my @languages = - I18N::LangTags::implicate_supers_tightly( - I18N::LangTags::Detect::detect() - ); - - -=head1 ENVIRONMENT - -This module looks for several environment variables, including -REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE, -LANGUAGE, LC_ALL, LC_MESSAGES, and LANG. - -It will also use the L module, if it's installed. - - -=head1 SEE ALSO - -L, L, L. - -(This module's core code started out as a routine in Locale::Maketext; -but I moved it here once I realized it was more generally useful.) - - -=head1 COPYRIGHT - -Copyright (c) 1998-2004 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -The programs and documentation in this dist are distributed in -the hope that they 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 - -# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty! Index: affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/List.pm diff -u affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/List.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/List.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/List.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/List.pm Tue Oct 25 04:20:50 2005 @@ -1,1779 +0,0 @@ - -require 5; -package I18N::LangTags::List; -# Time-stamp: "2004-10-06 23:26:21 ADT" -use strict; -use vars qw(%Name %Is_Disrec $Debug $VERSION); -$VERSION = '0.35'; -# POD at the end. - -#---------------------------------------------------------------------- -{ -# read the table out of our own POD! - my $seeking = 1; - my $count = 0; - my($disrec,$tag,$name); - my $last_name = ''; - while() { - if($seeking) { - $seeking = 0 if m/=for woohah/; - } elsif( ($disrec, $tag, $name) = - m/(\[?)\{([-0-9a-zA-Z]+)\}(?:\s*:)?\s*([^\[\]]+)/ - ) { - $name =~ s/\s*[;\.]*\s*$//g; - next unless $name; - ++$count; - print "<$tag> <$name>\n" if $Debug; - $last_name = $Name{$tag} = $name; - $Is_Disrec{$tag} = 1 if $disrec; - } elsif (m/[Ff]ormerly \"([-a-z0-9]+)\"/) { - $Name{$1} = "$last_name (old tag)" if $last_name; - $Is_Disrec{$1} = 1; - } - } - die "No tags read??" unless $count; -} -#---------------------------------------------------------------------- - -sub name { - my $tag = lc($_[0] || return); - $tag =~ s/^\s+//s; - $tag =~ s/\s+$//s; - - my $alt; - if($tag =~ m/^x-(.+)/) { - $alt = "i-$1"; - } elsif($tag =~ m/^i-(.+)/) { - $alt = "x-$1"; - } else { - $alt = ''; - } - - my $subform = ''; - my $name = ''; - print "Input: {$tag}\n" if $Debug; - while(length $tag) { - last if $name = $Name{$tag}; - last if $name = $Name{$alt}; - if($tag =~ s/(-[a-z0-9]+)$//s) { - print "Shaving off: $1 leaving $tag\n" if $Debug; - $subform = "$1$subform"; - # and loop around again - - $alt =~ s/(-[a-z0-9]+)$//s && $Debug && print " alt -> $alt\n"; - } else { - # we're trying to pull a subform off a primary tag. TILT! - print "Aborting on: {$name}{$subform}\n" if $Debug; - last; - } - } - print "Output: {$name}{$subform}\n" if $Debug; - - return unless $name; # Failure - return $name unless $subform; # Exact match - $subform =~ s/^-//s; - $subform =~ s/-$//s; - return "$name (Subform \"$subform\")"; -} - -#-------------------------------------------------------------------------- - -sub is_decent { - my $tag = lc($_[0] || return 0); - #require I18N::LangTags; - - return 0 unless - $tag =~ - /^(?: # First subtag - [xi] | [a-z]{2,3} - ) - (?: # Subtags thereafter - - # separator - [a-z0-9]{1,8} # subtag - )* - $/xs; - - my @supers = (); - foreach my $bit (split('-', $tag)) { - push @supers, - scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit; - } - return 0 unless @supers; - shift @supers if $supers[0] =~ m<^(i|x|sgn)$>s; - return 0 unless @supers; - - foreach my $f ($tag, @supers) { - return 0 if $Is_Disrec{$f}; - return 2 if $Name{$f}; - # so that decent subforms of indecent tags are decent - } - return 2 if $Name{$tag}; # not only is it decent, it's known! - return 1; -} - -#-------------------------------------------------------------------------- -1; - -__DATA__ - -=head1 NAME - -I18N::LangTags::List -- tags and names for human languages - -=head1 SYNOPSIS - - use I18N::LangTags::List; - print "Parlez-vous... ", join(', ', - I18N::LangTags::List::name('elx') || 'unknown_language', - I18N::LangTags::List::name('ar-Kw') || 'unknown_language', - I18N::LangTags::List::name('en') || 'unknown_language', - I18N::LangTags::List::name('en-CA') || 'unknown_language', - ), "?\n"; - -prints: - - Parlez-vous... Elamite, Kuwait Arabic, English, Canadian English? - -=head1 DESCRIPTION - -This module provides a function -C ) > that takes -a language tag (see L) -and returns the best attempt at an English name for it, or -undef if it can't make sense of the tag. - -The function I18N::LangTags::List::name(...) is not exported. - -This module also provides a function -C )> that returns true iff -the language tag is syntactically valid and is for general use (like -"fr" or "fr-ca", below). That is, it returns false for tags that are -syntactically invalid and for tags, like "aus", that are listed in -brackets below. This function is not exported. - -The map of tags-to-names that it uses is accessable as -%I18N::LangTags::List::Name, and it's the same as the list -that follows in this documentation, which should be useful -to you even if you don't use this module. - -=head1 ABOUT LANGUAGE TAGS - -Internet language tags, as defined in RFC 3066, are a formalism -for denoting human languages. The two-letter ISO 639-1 language -codes are well known (as "en" for English), as are their forms -when qualified by a country code ("en-US"). Less well-known are the -arbitrary-length non-ISO codes (like "i-mingo"), and the -recently (in 2001) introduced three-letter ISO-639-2 codes. - -Remember these important facts: - -=over - -=item * - -Language tags are not locale IDs. A locale ID is written with a "_" -instead of a "-", (almost?) always matches C, and -I something different than a language tag. A language tag -denotes a language. A locale ID denotes a language I -a particular place, in combination with non-linguistic -location-specific information such as what currency is used -there. Locales I often denote character set information, -as in "en_US.ISO8859-1". - -=item * - -Language tags are not for computer languages. - -=item * - -"Dialect" is not a useful term, since there is no objective -criterion for establishing when two language-forms are -dialects of eachother, or are separate languages. - -=item * - -Language tags are not case-sensitive. en-US, en-us, En-Us, etc., -are all the same tag, and denote the same language. - -=item * - -Not every language tag really refers to a single language. Some -language tags refer to conditions: i-default (system-message text -in English plus maybe other languages), und (undetermined -language). Others (notably lots of the three-letter codes) are -bibliographic tags that classify whole groups of languages, as -with cus "Cushitic (Other)" (i.e., a -language that has been classed as Cushtic, but which has no more -specific code) or the even less linguistically coherent -sai for "South American Indian (Other)". Though useful in -bibliography, B. For further guidance, email me. - -=item * - -Language tags are not country codes. In fact, they are often -distinct codes, as with language tag ja for Japanese, and -ISO 3166 country code C<.jp> for Japan. - -=back - -=head1 LIST OF LANGUAGES - -The first part of each item is the language tag, between -{...}. It -is followed by an English name for the language or language-group. -Language tags that I judge to be not for general use, are bracketed. - -This list is in alphabetical order by English name of the language. - -=for reminder - The name in the =item line MUST NOT have E<...>'s in it!! - -=for woohah START - -=over - -=item {ab} : Abkhazian - -eq Abkhaz - -=item {ace} : Achinese - -=item {ach} : Acoli - -=item {ada} : Adangme - -=item {ady} : Adyghe - -eq Adygei - -=item {aa} : Afar - -=item {afh} : Afrihili - -(Artificial) - -=item {af} : Afrikaans - -=item [{afa} : Afro-Asiatic (Other)] - -=item {ak} : Akan - -(Formerly "aka".) - -=item {akk} : Akkadian - -(Historical) - -=item {sq} : Albanian - -=item {ale} : Aleut - -=item [{alg} : Algonquian languages] - -NOT Algonquin! - -=item [{tut} : Altaic (Other)] - -=item {am} : Amharic - -NOT Aramaic! - -=item {i-ami} : Ami - -eq Amis. eq 'Amis. eq Pangca. - -=item [{apa} : Apache languages] - -=item {ar} : Arabic - -Many forms are mutually un-intelligible in spoken media. -Notable forms: -{ar-ae} UAE Arabic; -{ar-bh} Bahrain Arabic; -{ar-dz} Algerian Arabic; -{ar-eg} Egyptian Arabic; -{ar-iq} Iraqi Arabic; -{ar-jo} Jordanian Arabic; -{ar-kw} Kuwait Arabic; -{ar-lb} Lebanese Arabic; -{ar-ly} Libyan Arabic; -{ar-ma} Moroccan Arabic; -{ar-om} Omani Arabic; -{ar-qa} Qatari Arabic; -{ar-sa} Sauda Arabic; -{ar-sy} Syrian Arabic; -{ar-tn} Tunisian Arabic; -{ar-ye} Yemen Arabic. - -=item {arc} : Aramaic - -NOT Amharic! NOT Samaritan Aramaic! - -=item {arp} : Arapaho - -=item {arn} : Araucanian - -=item {arw} : Arawak - -=item {hy} : Armenian - -=item {an} : Aragonese - -=item [{art} : Artificial (Other)] - -=item {ast} : Asturian - -eq Bable. - -=item {as} : Assamese - -=item [{ath} : Athapascan languages] - -eq Athabaskan. eq Athapaskan. eq Athabascan. - -=item [{aus} : Australian languages] - -=item [{map} : Austronesian (Other)] - -=item {av} : Avaric - -(Formerly "ava".) - -=item {ae} : Avestan - -eq Zend - -=item {awa} : Awadhi - -=item {ay} : Aymara - -=item {az} : Azerbaijani - -eq Azeri - -Notable forms: -{az-Arab} Azerbaijani in Arabic script; -{az-Cyrl} Azerbaijani in Cyrillic script; -{az-Latn} Azerbaijani in Latin script. - -=item {ban} : Balinese - -=item [{bat} : Baltic (Other)] - -=item {bal} : Baluchi - -=item {bm} : Bambara - -(Formerly "bam".) - -=item [{bai} : Bamileke languages] - -=item {bad} : Banda - -=item [{bnt} : Bantu (Other)] - -=item {bas} : Basa - -=item {ba} : Bashkir - -=item {eu} : Basque - -=item {btk} : Batak (Indonesia) - -=item {bej} : Beja - -=item {be} : Belarusian - -eq Belarussian. eq Byelarussian. -eq Belorussian. eq Byelorussian. -eq White Russian. eq White Ruthenian. -NOT Ruthenian! - -=item {bem} : Bemba - -=item {bn} : Bengali - -eq Bangla. - -=item [{ber} : Berber (Other)] - -=item {bho} : Bhojpuri - -=item {bh} : Bihari - -=item {bik} : Bikol - -=item {bin} : Bini - -=item {bi} : Bislama - -eq Bichelamar. - -=item {bs} : Bosnian - -=item {bra} : Braj - -=item {br} : Breton - -=item {bug} : Buginese - -=item {bg} : Bulgarian - -=item {i-bnn} : Bunun - -=item {bua} : Buriat - -=item {my} : Burmese - -=item {cad} : Caddo - -=item {car} : Carib - -=item {ca} : Catalan - -eq CatalEn. eq Catalonian. - -=item [{cau} : Caucasian (Other)] - -=item {ceb} : Cebuano - -=item [{cel} : Celtic (Other)] - -Notable forms: -{cel-gaulish} Gaulish (Historical) - -=item [{cai} : Central American Indian (Other)] - -=item {chg} : Chagatai - -(Historical?) - -=item [{cmc} : Chamic languages] - -=item {ch} : Chamorro - -=item {ce} : Chechen - -=item {chr} : Cherokee - -eq Tsalagi - -=item {chy} : Cheyenne - -=item {chb} : Chibcha - -(Historical) NOT Chibchan (which is a language family). - -=item {ny} : Chichewa - -eq Nyanja. eq Chinyanja. - -=item {zh} : Chinese - -Many forms are mutually un-intelligible in spoken media. -Notable forms: -{zh-Hans} Chinese, in simplified script; -{zh-Hant} Chinese, in traditional script; -{zh-tw} Taiwan Chinese; -{zh-cn} PRC Chinese; -{zh-sg} Singapore Chinese; -{zh-mo} Macau Chinese; -{zh-hk} Hong Kong Chinese; -{zh-guoyu} Mandarin [Putonghua/Guoyu]; -{zh-hakka} Hakka [formerly "i-hakka"]; -{zh-min} Hokkien; -{zh-min-nan} Southern Hokkien; -{zh-wuu} Shanghaiese; -{zh-xiang} Hunanese; -{zh-gan} Gan; -{zh-yue} Cantonese. - -=for etc -{i-hakka} Hakka (old tag) - -=item {chn} : Chinook Jargon - -eq Chinook Wawa. - -=item {chp} : Chipewyan - -=item {cho} : Choctaw - -=item {cu} : Church Slavic - -eq Old Church Slavonic. - -=item {chk} : Chuukese - -eq Trukese. eq Chuuk. eq Truk. eq Ruk. - -=item {cv} : Chuvash - -=item {cop} : Coptic - -=item {kw} : Cornish - -=item {co} : Corsican - -eq Corse. - -=item {cr} : Cree - -NOT Creek! (Formerly "cre".) - -=item {mus} : Creek - -NOT Cree! - -=item [{cpe} : English-based Creoles and pidgins (Other)] - -=item [{cpf} : French-based Creoles and pidgins (Other)] - -=item [{cpp} : Portuguese-based Creoles and pidgins (Other)] - -=item [{crp} : Creoles and pidgins (Other)] - -=item {hr} : Croatian - -eq Croat. - -=item [{cus} : Cushitic (Other)] - -=item {cs} : Czech - -=item {dak} : Dakota - -eq Nakota. eq Latoka. - -=item {da} : Danish - -=item {dar} : Dargwa - -=item {day} : Dayak - -=item {i-default} : Default (Fallthru) Language - -Defined in RFC 2277, this is for tagging text -(which must include English text, and might/should include text -in other appropriate languages) that is emitted in a context -where language-negotiation wasn't possible -- in SMTP mail failure -messages, for example. - -=item {del} : Delaware - -=item {din} : Dinka - -=item {dv} : Divehi - -eq Maldivian. (Formerly "div".) - -=item {doi} : Dogri - -NOT Dogrib! - -=item {dgr} : Dogrib - -NOT Dogri! - -=item [{dra} : Dravidian (Other)] - -=item {dua} : Duala - -=item {nl} : Dutch - -eq Netherlander. Notable forms: -{nl-nl} Netherlands Dutch; -{nl-be} Belgian Dutch. - -=item {dum} : Middle Dutch (ca.1050-1350) - -(Historical) - -=item {dyu} : Dyula - -=item {dz} : Dzongkha - -=item {efi} : Efik - -=item {egy} : Ancient Egyptian - -(Historical) - -=item {eka} : Ekajuk - -=item {elx} : Elamite - -(Historical) - -=item {en} : English - -Notable forms: -{en-au} Australian English; -{en-bz} Belize English; -{en-ca} Canadian English; -{en-gb} UK English; -{en-ie} Irish English; -{en-jm} Jamaican English; -{en-nz} New Zealand English; -{en-ph} Philippine English; -{en-tt} Trinidad English; -{en-us} US English; -{en-za} South African English; -{en-zw} Zimbabwe English. - -=item {enm} : Old English (1100-1500) - -(Historical) - -=item {ang} : Old English (ca.450-1100) - -eq Anglo-Saxon. (Historical) - -=item {i-enochian} : Enochian (Artificial) - -=item {myv} : Erzya - -=item {eo} : Esperanto - -(Artificial) - -=item {et} : Estonian - -=item {ee} : Ewe - -(Formerly "ewe".) - -=item {ewo} : Ewondo - -=item {fan} : Fang - -=item {fat} : Fanti - -=item {fo} : Faroese - -=item {fj} : Fijian - -=item {fi} : Finnish - -=item [{fiu} : Finno-Ugrian (Other)] - -eq Finno-Ugric. NOT Ugaritic! - -=item {fon} : Fon - -=item {fr} : French - -Notable forms: -{fr-fr} France French; -{fr-be} Belgian French; -{fr-ca} Canadian French; -{fr-ch} Swiss French; -{fr-lu} Luxembourg French; -{fr-mc} Monaco French. - -=item {frm} : Middle French (ca.1400-1600) - -(Historical) - -=item {fro} : Old French (842-ca.1400) - -(Historical) - -=item {fy} : Frisian - -=item {fur} : Friulian - -=item {ff} : Fulah - -(Formerly "ful".) - -=item {gaa} : Ga - -=item {gd} : Scots Gaelic - -NOT Scots! - -=item {gl} : Gallegan - -eq Galician - -=item {lg} : Ganda - -(Formerly "lug".) - -=item {gay} : Gayo - -=item {gba} : Gbaya - -=item {gez} : Geez - -eq Ge'ez - -=item {ka} : Georgian - -=item {de} : German - -Notable forms: -{de-at} Austrian German; -{de-be} Belgian German; -{de-ch} Swiss German; -{de-de} Germany German; -{de-li} Liechtenstein German; -{de-lu} Luxembourg German. - -=item {gmh} : Middle High German (ca.1050-1500) - -(Historical) - -=item {goh} : Old High German (ca.750-1050) - -(Historical) - -=item [{gem} : Germanic (Other)] - -=item {gil} : Gilbertese - -=item {gon} : Gondi - -=item {gor} : Gorontalo - -=item {got} : Gothic - -(Historical) - -=item {grb} : Grebo - -=item {grc} : Ancient Greek - -(Historical) (Until 15th century or so.) - -=item {el} : Modern Greek - -(Since 15th century or so.) - -=item {gn} : Guarani - -GuaranE - -=item {gu} : Gujarati - -=item {gwi} : Gwich'in - -eq Gwichin - -=item {hai} : Haida - -=item {ht} : Haitian - -eq Haitian Creole - -=item {ha} : Hausa - -=item {haw} : Hawaiian - -Hawai'ian - -=item {he} : Hebrew - -(Formerly "iw".) - -=for etc -{iw} Hebrew (old tag) - -=item {hz} : Herero - -=item {hil} : Hiligaynon - -=item {him} : Himachali - -=item {hi} : Hindi - -=item {ho} : Hiri Motu - -=item {hit} : Hittite - -(Historical) - -=item {hmn} : Hmong - -=item {hu} : Hungarian - -=item {hup} : Hupa - -=item {iba} : Iban - -=item {is} : Icelandic - -=item {io} : Ido - -(Artificial) - -=item {ig} : Igbo - -(Formerly "ibo".) - -=item {ijo} : Ijo - -=item {ilo} : Iloko - -=item [{inc} : Indic (Other)] - -=item [{ine} : Indo-European (Other)] - -=item {id} : Indonesian - -(Formerly "in".) - -=for etc -{in} Indonesian (old tag) - -=item {inh} : Ingush - -=item {ia} : Interlingua (International Auxiliary Language Association) - -(Artificial) NOT Interlingue! - -=item {ie} : Interlingue - -(Artificial) NOT Interlingua! - -=item {iu} : Inuktitut - -A subform of "Eskimo". - -=item {ik} : Inupiaq - -A subform of "Eskimo". - -=item [{ira} : Iranian (Other)] - -=item {ga} : Irish - -=item {mga} : Middle Irish (900-1200) - -(Historical) - -=item {sga} : Old Irish (to 900) - -(Historical) - -=item [{iro} : Iroquoian languages] - -=item {it} : Italian - -Notable forms: -{it-it} Italy Italian; -{it-ch} Swiss Italian. - -=item {ja} : Japanese - -(NOT "jp"!) - -=item {jv} : Javanese - -(Formerly "jw" because of a typo.) - -=item {jrb} : Judeo-Arabic - -=item {jpr} : Judeo-Persian - -=item {kbd} : Kabardian - -=item {kab} : Kabyle - -=item {kac} : Kachin - -=item {kl} : Kalaallisut - -eq Greenlandic "Eskimo" - -=item {xal} : Kalmyk - -=item {kam} : Kamba - -=item {kn} : Kannada - -eq Kanarese. NOT Canadian! - -=item {kr} : Kanuri - -(Formerly "kau".) - -=item {krc} : Karachay-Balkar - -=item {kaa} : Kara-Kalpak - -=item {kar} : Karen - -=item {ks} : Kashmiri - -=item {csb} : Kashubian - -eq Kashub - -=item {kaw} : Kawi - -=item {kk} : Kazakh - -=item {kha} : Khasi - -=item {km} : Khmer - -eq Cambodian. eq Kampuchean. - -=item [{khi} : Khoisan (Other)] - -=item {kho} : Khotanese - -=item {ki} : Kikuyu - -eq Gikuyu. - -=item {kmb} : Kimbundu - -=item {rw} : Kinyarwanda - -=item {ky} : Kirghiz - -=item {i-klingon} : Klingon - -=item {kv} : Komi - -=item {kg} : Kongo - -(Formerly "kon".) - -=item {kok} : Konkani - -=item {ko} : Korean - -=item {kos} : Kosraean - -=item {kpe} : Kpelle - -=item {kro} : Kru - -=item {kj} : Kuanyama - -=item {kum} : Kumyk - -=item {ku} : Kurdish - -=item {kru} : Kurukh - -=item {kut} : Kutenai - -=item {lad} : Ladino - -eq Judeo-Spanish. NOT Ladin (a minority language in Italy). - -=item {lah} : Lahnda - -NOT Lamba! - -=item {lam} : Lamba - -NOT Lahnda! - -=item {lo} : Lao - -eq Laotian. - -=item {la} : Latin - -(Historical) NOT Ladin! NOT Ladino! - -=item {lv} : Latvian - -eq Lettish. - -=item {lb} : Letzeburgesch - -eq Luxemburgian, eq Luxemburger. (Formerly "i-lux".) - -=for etc -{i-lux} Letzeburgesch (old tag) - -=item {lez} : Lezghian - -=item {li} : Limburgish - -eq Limburger, eq Limburgan. NOT Letzeburgesch! - -=item {ln} : Lingala - -=item {lt} : Lithuanian - -=item {nds} : Low German - -eq Low Saxon. eq Low German. eq Low Saxon. - -=item {art-lojban} : Lojban (Artificial) - -=item {loz} : Lozi - -=item {lu} : Luba-Katanga - -(Formerly "lub".) - -=item {lua} : Luba-Lulua - -=item {lui} : Luiseno - -eq LuiseEo. - -=item {lun} : Lunda - -=item {luo} : Luo (Kenya and Tanzania) - -=item {lus} : Lushai - -=item {mk} : Macedonian - -eq the modern Slavic language spoken in what was Yugoslavia. -NOT the form of Greek spoken in Greek Macedonia! - -=item {mad} : Madurese - -=item {mag} : Magahi - -=item {mai} : Maithili - -=item {mak} : Makasar - -=item {mg} : Malagasy - -=item {ms} : Malay - -NOT Malayalam! - -=item {ml} : Malayalam - -NOT Malay! - -=item {mt} : Maltese - -=item {mnc} : Manchu - -=item {mdr} : Mandar - -NOT Mandarin! - -=item {man} : Mandingo - -=item {mni} : Manipuri - -eq Meithei. - -=item [{mno} : Manobo languages] - -=item {gv} : Manx - -=item {mi} : Maori - -NOT Mari! - -=item {mr} : Marathi - -=item {chm} : Mari - -NOT Maori! - -=item {mh} : Marshall - -eq Marshallese. - -=item {mwr} : Marwari - -=item {mas} : Masai - -=item [{myn} : Mayan languages] - -=item {men} : Mende - -=item {mic} : Micmac - -=item {min} : Minangkabau - -=item {i-mingo} : Mingo - -eq the Irquoian language West Virginia Seneca. NOT New York Seneca! - -=item [{mis} : Miscellaneous languages] - -Don't use this. - -=item {moh} : Mohawk - -=item {mdf} : Moksha - -=item {mo} : Moldavian - -eq Moldovan. - -=item [{mkh} : Mon-Khmer (Other)] - -=item {lol} : Mongo - -=item {mn} : Mongolian - -eq Mongol. - -=item {mos} : Mossi - -=item [{mul} : Multiple languages] - -Not for normal use. - -=item [{mun} : Munda languages] - -=item {nah} : Nahuatl - -=item {nap} : Neapolitan - -=item {na} : Nauru - -=item {nv} : Navajo - -eq Navaho. (Formerly "i-navajo".) - -=for etc -{i-navajo} Navajo (old tag) - -=item {nd} : North Ndebele - -=item {nr} : South Ndebele - -=item {ng} : Ndonga - -=item {ne} : Nepali - -eq Nepalese. Notable forms: -{ne-np} Nepal Nepali; -{ne-in} India Nepali. - -=item {new} : Newari - -=item {nia} : Nias - -=item [{nic} : Niger-Kordofanian (Other)] - -=item [{ssa} : Nilo-Saharan (Other)] - -=item {niu} : Niuean - -=item {nog} : Nogai - -=item {non} : Old Norse - -(Historical) - -=item [{nai} : North American Indian] - -Do not use this. - -=item {no} : Norwegian - -Note the two following forms: - -=item {nb} : Norwegian Bokmal - -eq BokmEl, (A form of Norwegian.) (Formerly "no-bok".) - -=for etc -{no-bok} Norwegian Bokmal (old tag) - -=item {nn} : Norwegian Nynorsk - -(A form of Norwegian.) (Formerly "no-nyn".) - -=for etc -{no-nyn} Norwegian Nynorsk (old tag) - -=item [{nub} : Nubian languages] - -=item {nym} : Nyamwezi - -=item {nyn} : Nyankole - -=item {nyo} : Nyoro - -=item {nzi} : Nzima - -=item {oc} : Occitan (post 1500) - -eq ProvenEal, eq Provencal - -=item {oj} : Ojibwa - -eq Ojibwe. (Formerly "oji".) - -=item {or} : Oriya - -=item {om} : Oromo - -=item {osa} : Osage - -=item {os} : Ossetian; Ossetic - -=item [{oto} : Otomian languages] - -Group of languages collectively called "OtomE". - -=item {pal} : Pahlavi - -eq Pahlevi - -=item {i-pwn} : Paiwan - -eq Pariwan - -=item {pau} : Palauan - -=item {pi} : Pali - -(Historical?) - -=item {pam} : Pampanga - -=item {pag} : Pangasinan - -=item {pa} : Panjabi - -eq Punjabi - -=item {pap} : Papiamento - -eq Papiamentu. - -=item [{paa} : Papuan (Other)] - -=item {fa} : Persian - -eq Farsi. eq Iranian. - -=item {peo} : Old Persian (ca.600-400 B.C.) - -=item [{phi} : Philippine (Other)] - -=item {phn} : Phoenician - -(Historical) - -=item {pon} : Pohnpeian - -NOT Pompeiian! - -=item {pl} : Polish - -=item {pt} : Portuguese - -eq Portugese. Notable forms: -{pt-pt} Portugal Portuguese; -{pt-br} Brazilian Portuguese. - -=item [{pra} : Prakrit languages] - -=item {pro} : Old Provencal (to 1500) - -eq Old ProvenEal. (Historical.) - -=item {ps} : Pushto - -eq Pashto. eq Pushtu. - -=item {qu} : Quechua - -eq Quecha. - -=item {rm} : Raeto-Romance - -eq Romansh. - -=item {raj} : Rajasthani - -=item {rap} : Rapanui - -=item {rar} : Rarotongan - -=item [{qaa - qtz} : Reserved for local use.] - -=item [{roa} : Romance (Other)] - -NOT Romanian! NOT Romany! NOT Romansh! - -=item {ro} : Romanian - -eq Rumanian. NOT Romany! - -=item {rom} : Romany - -eq Rom. NOT Romanian! - -=item {rn} : Rundi - -=item {ru} : Russian - -NOT White Russian! NOT Rusyn! - -=item [{sal} : Salishan languages] - -Large language group. - -=item {sam} : Samaritan Aramaic - -NOT Aramaic! - -=item {se} : Northern Sami - -eq Lappish. eq Lapp. eq (Northern) Saami. - -=item {sma} : Southern Sami - -=item {smn} : Inari Sami - -=item {smj} : Lule Sami - -=item {sms} : Skolt Sami - -=item [{smi} : Sami languages (Other)] - -=item {sm} : Samoan - -=item {sad} : Sandawe - -=item {sg} : Sango - -=item {sa} : Sanskrit - -(Historical) - -=item {sat} : Santali - -=item {sc} : Sardinian - -eq Sard. - -=item {sas} : Sasak - -=item {sco} : Scots - -NOT Scots Gaelic! - -=item {sel} : Selkup - -=item [{sem} : Semitic (Other)] - -=item {sr} : Serbian - -eq Serb. NOT Sorbian. - -Notable forms: -{sr-Cyrl} : Serbian in Cyrillic script; -{sr-Latn} : Serbian in Latin script. - -=item {srr} : Serer - -=item {shn} : Shan - -=item {sn} : Shona - -=item {sid} : Sidamo - -=item {sgn-...} : Sign Languages - -Always use with a subtag. Notable forms: -{sgn-gb} British Sign Language (BSL); -{sgn-ie} Irish Sign Language (ESL); -{sgn-ni} Nicaraguan Sign Language (ISN); -{sgn-us} American Sign Language (ASL). - -(And so on with other country codes as the subtag.) - -=item {bla} : Siksika - -eq Blackfoot. eq Pikanii. - -=item {sd} : Sindhi - -=item {si} : Sinhalese - -eq Sinhala. - -=item [{sit} : Sino-Tibetan (Other)] - -=item [{sio} : Siouan languages] - -=item {den} : Slave (Athapascan) - -("Slavey" is a subform.) - -=item [{sla} : Slavic (Other)] - -=item {sk} : Slovak - -eq Slovakian. - -=item {sl} : Slovenian - -eq Slovene. - -=item {sog} : Sogdian - -=item {so} : Somali - -=item {son} : Songhai - -=item {snk} : Soninke - -=item {wen} : Sorbian languages - -eq Wendish. eq Sorb. eq Lusatian. eq Wend. NOT Venda! NOT Serbian! - -=item {nso} : Northern Sotho - -=item {st} : Southern Sotho - -eq Sutu. eq Sesotho. - -=item [{sai} : South American Indian (Other)] - -=item {es} : Spanish - -Notable forms: -{es-ar} Argentine Spanish; -{es-bo} Bolivian Spanish; -{es-cl} Chilean Spanish; -{es-co} Colombian Spanish; -{es-do} Dominican Spanish; -{es-ec} Ecuadorian Spanish; -{es-es} Spain Spanish; -{es-gt} Guatemalan Spanish; -{es-hn} Honduran Spanish; -{es-mx} Mexican Spanish; -{es-pa} Panamanian Spanish; -{es-pe} Peruvian Spanish; -{es-pr} Puerto Rican Spanish; -{es-py} Paraguay Spanish; -{es-sv} Salvadoran Spanish; -{es-us} US Spanish; -{es-uy} Uruguayan Spanish; -{es-ve} Venezuelan Spanish. - -=item {suk} : Sukuma - -=item {sux} : Sumerian - -(Historical) - -=item {su} : Sundanese - -=item {sus} : Susu - -=item {sw} : Swahili - -eq Kiswahili - -=item {ss} : Swati - -=item {sv} : Swedish - -Notable forms: -{sv-se} Sweden Swedish; -{sv-fi} Finland Swedish. - -=item {syr} : Syriac - -=item {tl} : Tagalog - -=item {ty} : Tahitian - -=item [{tai} : Tai (Other)] - -NOT Thai! - -=item {tg} : Tajik - -=item {tmh} : Tamashek - -=item {ta} : Tamil - -=item {i-tao} : Tao - -eq Yami. - -=item {tt} : Tatar - -=item {i-tay} : Tayal - -eq Atayal. eq Atayan. - -=item {te} : Telugu - -=item {ter} : Tereno - -=item {tet} : Tetum - -=item {th} : Thai - -NOT Tai! - -=item {bo} : Tibetan - -=item {tig} : Tigre - -=item {ti} : Tigrinya - -=item {tem} : Timne - -eq Themne. eq Timene. - -=item {tiv} : Tiv - -=item {tli} : Tlingit - -=item {tpi} : Tok Pisin - -=item {tkl} : Tokelau - -=item {tog} : Tonga (Nyasa) - -NOT Tsonga! - -=item {to} : Tonga (Tonga Islands) - -(Pronounced "Tong-a", not "Tong-ga") - -NOT Tsonga! - -=item {tsi} : Tsimshian - -eq Sm'algyax - -=item {ts} : Tsonga - -NOT Tonga! - -=item {i-tsu} : Tsou - -=item {tn} : Tswana - -Same as Setswana. - -=item {tum} : Tumbuka - -=item [{tup} : Tupi languages] - -=item {tr} : Turkish - -(Typically in Roman script) - -=item {ota} : Ottoman Turkish (1500-1928) - -(Typically in Arabic script) (Historical) - -=item {crh} : Crimean Turkish - -eq Crimean Tatar - -=item {tk} : Turkmen - -eq Turkmeni. - -=item {tvl} : Tuvalu - -=item {tyv} : Tuvinian - -eq Tuvan. eq Tuvin. - -=item {tw} : Twi - -=item {udm} : Udmurt - -=item {uga} : Ugaritic - -NOT Ugric! - -=item {ug} : Uighur - -=item {uk} : Ukrainian - -=item {umb} : Umbundu - -=item {und} : Undetermined - -Not a tag for normal use. - -=item {ur} : Urdu - -=item {uz} : Uzbek - -eq Ezbek - -Notable forms: -{uz-Cyrl} Uzbek in Cyrillic script; -{uz-Latn} Uzbek in Latin script. - -=item {vai} : Vai - -=item {ve} : Venda - -NOT Wendish! NOT Wend! NOT Avestan! (Formerly "ven".) - -=item {vi} : Vietnamese - -eq Viet. - -=item {vo} : Volapuk - -eq VolapEk. (Artificial) - -=item {vot} : Votic - -eq Votian. eq Vod. - -=item [{wak} : Wakashan languages] - -=item {wa} : Walloon - -=item {wal} : Walamo - -eq Wolaytta. - -=item {war} : Waray - -Presumably the Philippine language Waray-Waray (SamareEo), -not the smaller Philippine language Waray Sorsogon, nor the extinct -Australian language Waray. - -=item {was} : Washo - -eq Washoe - -=item {cy} : Welsh - -=item {wo} : Wolof - -=item {x-...} : Unregistered (Semi-Private Use) - -"x-" is a prefix for language tags that are not registered with ISO -or IANA. Example, x-double-dutch - -=item {xh} : Xhosa - -=item {sah} : Yakut - -=item {yao} : Yao - -(The Yao in Malawi?) - -=item {yap} : Yapese - -eq Yap - -=item {ii} : Sichuan Yi - -=item {yi} : Yiddish - -Formerly "ji". Usually in Hebrew script. - -Notable forms: -{yi-latn} Yiddish in Latin script - -=item {yo} : Yoruba - -=item [{ypk} : Yupik languages] - -Several "Eskimo" languages. - -=item {znd} : Zande - -=item [{zap} : Zapotec] - -(A group of languages.) - -=item {zen} : Zenaga - -NOT Zend. - -=item {za} : Zhuang - -=item {zu} : Zulu - -=item {zun} : Zuni - -eq ZuEi - -=back - -=for woohah END - -=head1 SEE ALSO - -L and its "See Also" section. - -=head1 COPYRIGHT AND DISCLAIMER - -Copyright (c) 2001+ Sean M. Burke. All rights reserved. - -You can redistribute and/or -modify this document under the same terms as Perl itself. - -This document is provided in the hope that it will be -useful, but without any warranty; -without even the implied warranty of accuracy, authoritativeness, -completeness, merchantability, or fitness for a particular purpose. - -Email any corrections or questions to me. - -=head1 AUTHOR - -Sean M. Burke, sburkeE<64>cpan.org - -=cut - - -# To generate a list of just the two and three-letter codes: - -#!/usr/local/bin/perl -w - -require 5; # Time-stamp: "2001-03-13 21:53:39 MST" - # Sean M. Burke, sburke @ cpan.org - # This program is for generating the language_codes.txt file -use strict; -use LWP::Simple; -use HTML::TreeBuilder 3.10; -my $root = HTML::TreeBuilder->new(); -my $url = 'http://lcweb.loc.gov/standards/iso639-2/bibcodes.html'; -$root->parse(get($url) || die "Can't get $url"); -$root->eof(); - -my @codes; - -foreach my $tr ($root->find_by_tag_name('tr')) { - my @f = map $_->as_text(), $tr->content_list(); - #print map("<$_> ", @f), "\n"; - next unless @f == 5; - pop @f; # nix the French name - next if $f[-1] eq 'Language Name (English)'; # it's a header line - my $xx = splice(@f, 2,1); # pull out the two-letter code - $f[-1] =~ s/^\s+//; - $f[-1] =~ s/\s+$//; - if($xx =~ m/[a-zA-Z]/) { # there's a two-letter code for it - push @codes, [ lc($f[-1]), "$xx\t$f[-1]\n" ]; - } else { # print the three-letter codes. - if($f[0] eq $f[1]) { - push @codes, [ lc($f[-1]), "$f[1]\t$f[2]\n" ]; - } else { # shouldn't happen - push @codes, [ lc($f[-1]), "@f !!!!!!!!!!\n" ]; - } - } -} - -print map $_->[1], sort {; $a->[0] cmp $b->[0] } @codes; -print "[ based on $url\n at ", scalar(localtime), "]\n", - "[Note: doesn't include IANA-registered codes.]\n"; -exit; -__END__ - Index: affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/README diff -u affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/README:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/README:removed --- affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/README:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/I18N/LangTags/README Tue Oct 25 04:20:50 2005 @@ -1,78 +0,0 @@ -README for I18N::LangTags - Time-stamp: "2001-05-29 21:52:15 MDT" - - I18N::LangTags - -I18N::LangTags - functions for dealing with RFC3066-style language -tags - -Language tags are a formalism, described in RFC 3066 (obsoleting -1766), for declaring what language form (language and possibly -dialect) a given chunk of information is in. - -This library provides functions for common tasks involving language -tags (notably the extraction of them, comparing them, and testing the -formal validity of them) as is needed in a variety of protocols and -applications. - - -I18N::LangTags::List -- tags and names for human languages. This -module goes from known language tag names ("fr-CA") to their English -names ("Canadian French"). Its documentation also lists the several -hundred known tags and some common subforms. You may find this useful -as a reference. - - -See the POD for more information. - - -INSTALLATION - -You install I18N::LangTags and I18N::LangTags::List, as you would -install any perl module library, by running these commands: - - perl Makefile.PL - make - make test - make install - -If you want to install a private copy of I18N::LangTags in your home -directory, then you should try to produce the initial Makefile with -something like this command: - - perl Makefile.PL LIB=~/perl - -See perldoc perlmodinstall for more information on installing modules. - - -DOCUMENTATION - -POD-format documentation is included in LangTags.pm. POD is readable -with the 'perldoc' utility. See ChangeLog for recent changes. - - -SUPPORT - -Questions, bug reports, useful code bits, and suggestions for -I18N::LangTags should just be sent to me at sburke @ cpan.org - - -AVAILABILITY - -The latest version of I18N::LangTags is available from the -Comprehensive Perl Archive Network (CPAN). Visit - to find a CPAN site near you. - - -COPYRIGHT - -Copyright 1998-2001, Sean M. Burke , all rights -reserved. - -The programs and documentation in this dist are distributed in -the hope that they will be useful, but without any warranty; without -even the implied warranty of merchantability or fitness for a -particular purpose. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:51 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:51 +0900 Subject: [Affelio-cvs 661] CVS update: affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext Message-ID: <20051024192051.0814F2AC01F@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext/TPJ13.pod diff -u affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext/TPJ13.pod:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext/TPJ13.pod:removed --- affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext/TPJ13.pod:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext/TPJ13.pod Tue Oct 25 04:20:50 2005 @@ -1,776 +0,0 @@ - -# This document contains text in Perl "POD" format. -# Use a POD viewer like perldoc or perlman to render it. - -=head1 NAME - -Locale::Maketext::TPJ13 -- article about software localization - -=head1 SYNOPSIS - - # This an article, not a module. - -=head1 DESCRIPTION - -The following article by Sean M. Burke and Jordan Lachler -first appeared in I #13 and is copyright 1999 The Perl Journal. It appears -courtesy of Jon Orwant and The Perl Journal. This document may be -distributed under the same terms as Perl itself. - -=head1 Localization and Perl: gettext breaks, Maketext fixes - -by Sean M. Burke and Jordan Lachler - -This article points out cases where gettext (a common system for -localizing software interfaces -- i.e., making them work in the user's -language of choice) fails because of basic differences between human -languages. This article then describes Maketext, a new system capable -of correctly treating these differences. - -=head2 A Localization Horror Story: It Could Happen To You - -=over - -"There are a number of languages spoken by human beings in this -world." - --- Harald Tveit Alvestrand, in RFC 1766, "Tags for the -Identification of Languages" - -=back - -Imagine that your task for the day is to localize a piece of software --- and luckily for you, the only output the program emits is two -messages, like this: - - I scanned 12 directories. - - Your query matched 10 files in 4 directories. - -So how hard could that be? You look at the code that produces -produces the first item, and it reads: - - printf("I scanned %g directories.", - $directory_count); - -You think about that, and realize that it doesn't even work right for -English, as it can produce this output: - - I scanned 1 directories. - -So you rewrite it to read: - - printf("I scanned %g %s.", - $directory_count, - $directory_count == 1 ? - "directory" : "directories", - ); - -...which does the Right Thing. (In case you don't recall, "%g" is for -locale-specific number interpolation, and "%s" is for string -interpolation.) - -But you still have to localize it for all the languages you're -producing this software for, so you pull Locale::gettext off of CPAN -so you can access the C C functions you've heard are standard -for localization tasks. - -And you write: - - printf(gettext("I scanned %g %s."), - $dir_scan_count, - $dir_scan_count == 1 ? - gettext("directory") : gettext("directory"), - ); - -But you then read in the gettext manual (Drepper, Miller, and Pinard 1995) -that this is not a good idea, since how a single word like "directory" -or "directories" is translated may depend on context -- and this is -true, since in a case language like German or Russian, you'd may need -these words with a different case ending in the first instance (where the -word is the object of a verb) than in the second instance, which you haven't even -gotten to yet (where the word is the object of a preposition, "in %g -directories") -- assuming these keep the same syntax when translated -into those languages. - -So, on the advice of the gettext manual, you rewrite: - - printf( $dir_scan_count == 1 ? - gettext("I scanned %g directory.") : - gettext("I scanned %g directories."), - $dir_scan_count ); - -So, you email your various translators (the boss decides that the -languages du jour are Chinese, Arabic, Russian, and Italian, so you -have one translator for each), asking for translations for "I scanned -%g directory." and "I scanned %g directories.". When they reply, -you'll put that in the lexicons for gettext to use when it localizes -your software, so that when the user is running under the "zh" -(Chinese) locale, gettext("I scanned %g directory.") will return the -appropriate Chinese text, with a "%g" in there where printf can then -interpolate $dir_scan. - -Your Chinese translator emails right back -- he says both of these -phrases translate to the same thing in Chinese, because, in linguistic -jargon, Chinese "doesn't have number as a grammatical category" -- -whereas English does. That is, English has grammatical rules that -refer to "number", i.e., whether something is grammatically singular -or plural; and one of these rules is the one that forces nouns to take -a plural suffix (generally "s") when in a plural context, as they are when -they follow a number other than "one" (including, oddly enough, "zero"). -Chinese has no such rules, and so has just the one phrase where English -has two. But, no problem, you can have this one Chinese phrase appear -as the translation for the two English phrases in the "zh" gettext -lexicon for your program. - -Emboldened by this, you dive into the second phrase that your software -needs to output: "Your query matched 10 files in 4 directories.". You notice -that if you want to treat phrases as indivisible, as the gettext -manual wisely advises, you need four cases now, instead of two, to -cover the permutations of singular and plural on the two items, -$dir_count and $file_count. So you try this: - - printf( $file_count == 1 ? - ( $directory_count == 1 ? - gettext("Your query matched %g file in %g directory.") : - gettext("Your query matched %g file in %g directories.") ) : - ( $directory_count == 1 ? - gettext("Your query matched %g files in %g directory.") : - gettext("Your query matched %g files in %g directories.") ), - $file_count, $directory_count, - ); - -(The case of "1 file in 2 [or more] directories" could, I suppose, -occur in the case of symlinking or something of the sort.) - -It occurs to you that this is not the prettiest code you've ever -written, but this seems the way to go. You mail off to the -translators asking for translations for these four cases. The -Chinese guy replies with the one phrase that these all translate to in -Chinese, and that phrase has two "%g"s in it, as it should -- but -there's a problem. He translates it word-for-word back: "To your -question, in %g directories you would find %g answers." The "%g" -slots are in an order reverse to what they are in English. You wonder -how you'll get gettext to handle that. - -But you put it aside for the moment, and optimistically hope that the -other translators won't have this problem, and that their languages -will be better behaved -- i.e., that they will be just like English. - -But the Arabic translator is the next to write back. First off, your -code for "I scanned %g directory." or "I scanned %g directories." -assumes there's only singular or plural. But, to use linguistic -jargon again, Arabic has grammatical number, like English (but unlike -Chinese), but it's a three-term category: singular, dual, and plural. -In other words, the way you say "directory" depends on whether there's -one directory, or I of them, or I of them. Your -test of C<($directory == 1)> no longer does the job. And it means -that where English's grammatical category of number necessitates -only the two permutations of the first sentence based on "directory -[singular]" and "directories [plural]", Arabic has three -- and, -worse, in the second sentence ("Your query matched %g file in %g -directory."), where English has four, Arabic has nine. You sense -an unwelcome, exponential trend taking shape. - -Your Italian translator emails you back and says that "I searched 0 -directories" (a possible English output of your program) is stilted, -and if you think that's fine English, that's your problem, but that -I in the language of Dante. He insists that where -$directory_count is 0, your program should produce the Italian text -for "I I scan I directories.". And ditto for "I didn't -match any files in any directories", although he says the last part -about "in any directories" should probably just be left off. - -You wonder how you'll get gettext to handle this; to accomodate the -ways Arabic, Chinese, and Italian deal with numbers in just these few -very simple phrases, you need to write code that will ask gettext for -different queries depending on whether the numerical values in -question are 1, 2, more than 2, or in some cases 0, and you still haven't -figured out the problem with the different word order in Chinese. - -Then your Russian translator calls on the phone, to I tell -you the bad news about how really unpleasant your life is about to -become: - -Russian, like German or Latin, is an inflectional language; that is, nouns -and adjectives have to take endings that depend on their case -(i.e., nominative, accusative, genitive, etc...) -- which is roughly a matter of -what role they have in syntax of the sentence -- -as well as on the grammatical gender (i.e., masculine, feminine, neuter) -and number (i.e., singular or plural) of the noun, as well as on the -declension class of the noun. But unlike with most other inflected languages, -putting a number-phrase (like "ten" or "forty-three", or their Arabic -numeral equivalents) in front of noun in Russian can change the case and -number that noun is, and therefore the endings you have to put on it. - -He elaborates: In "I scanned %g directories", you'd I -"directories" to be in the accusative case (since it is the direct -object in the sentnce) and the plural number, -except where $directory_count is 1, then you'd expect the singular, of -course. Just like Latin or German. I Where $directory_count % -10 is 1 ("%" for modulo, remember), assuming $directory count is an -integer, and except where $directory_count % 100 is 11, "directories" -is forced to become grammatically singular, which means it gets the -ending for the accusative singular... You begin to visualize the code -it'd take to test for the problem so far, I, and how many gettext items that'd take, but -he keeps going... But where $directory_count % 10 is 2, 3, or 4 -(except where $directory_count % 100 is 12, 13, or 14), the word for -"directories" is forced to be genitive singular -- which means another -ending... The room begins to spin around you, slowly at first... But -with I integer values, since "directory" is an inanimate -noun, when preceded by a number and in the nominative or accusative -cases (as it is here, just your luck!), it does stay plural, but it is -forced into the genitive case -- yet another another ending... And -you never hear him get to the part about how you're going to run into -similar (but maybe subtly different) problems with other Slavic -languages like Polish, because the floor comes up to meet you, and you -fade into unconsciousness. - - -The above cautionary tale relates how an attempt at localization can -lead from programmer consternation, to program obfuscation, to a need -for sedation. But careful evaluation shows that your choice of tools -merely needed further consideration. - -=head2 The Linguistic View - -=over - -"It is more complicated than you think." - --- The Eighth Networking Truth, from RFC 1925 - -=back - -The field of Linguistics has expended a great deal of effort over the -past century trying to find grammatical patterns which hold across -languages; it's been a constant process -of people making generalizations that should apply to all languages, -only to find out that, all too often, these generalizations fail -- -sometimes failing for just a few languages, sometimes whole classes of -languages, and sometimes nearly every language in the world except -English. Broad statistical trends are evident in what the "average -language" is like as far as what its rules can look like, must look -like, and cannot look like. But the "average language" is just as -unreal a concept as the "average person" -- it runs up against the -fact no language (or person) is, in fact, average. The wisdom of past -experience leads us to believe that any given language can do whatever -it wants, in any order, with appeal to any kind of grammatical -categories wants -- case, number, tense, real or metaphoric -characteristics of the things that words refer to, arbitrary or -predictable classifications of words based on what endings or prefixes -they can take, degree or means of certainty about the truth of -statements expressed, and so on, ad infinitum. - -Mercifully, most localization tasks are a matter of finding ways to -translate whole phrases, generally sentences, where the context is -relatively set, and where the only variation in content is I -in a number being expressed -- as in the example sentences above. -Translating specific, fully-formed sentences is, in practice, fairly -foolproof -- which is good, because that's what's in the phrasebooks -that so many tourists rely on. Now, a given phrase (whether in a -phrasebook or in a gettext lexicon) in one language I have a -greater or lesser applicability than that phrase's translation into -another language -- for example, strictly speaking, in Arabic, the -"your" in "Your query matched..." would take a different form -depending on whether the user is male or female; so the Arabic -translation "your[feminine] query" is applicable in fewer cases than -the corresponding English phrase, which doesn't distinguish the user's -gender. (In practice, it's not feasable to have a program know the -user's gender, so the masculine "you" in Arabic is usually used, by -default.) - -But in general, such surprises are rare when entire sentences are -being translated, especially when the functional context is restricted -to that of a computer interacting with a user either to convey a fact -or to prompt for a piece of information. So, for purposes of -localization, translation by phrase (generally by sentence) is both the -simplest and the least problematic. - -=head2 Breaking gettext - -=over - -"It Has To Work." - --- First Networking Truth, RFC 1925 - -=back - -Consider that sentences in a tourist phrasebook are of two types: ones -like "How do I get to the marketplace?" that don't have any blanks to -fill in, and ones like "How much do these ___ cost?", where there's -one or more blanks to fill in (and these are usually linked to a -list of words that you can put in that blank: "fish", "potatoes", -"tomatoes", etc.) The ones with no blanks are no problem, but the -fill-in-the-blank ones may not be really straightforward. If it's a -Swahili phrasebook, for example, the authors probably didn't bother to -tell you the complicated ways that the verb "cost" changes its -inflectional prefix depending on the noun you're putting in the blank. -The trader in the marketplace will still understand what you're saying if -you say "how much do these potatoes cost?" with the wrong -inflectional prefix on "cost". After all, I can't speak proper Swahili, -I just a tourist. But while tourists can be stupid, computers -are supposed to be smart; the computer should be able to fill in the -blank, and still have the results be grammatical. - -In other words, a phrasebook entry takes some values as parameters -(the things that you fill in the blank or blanks), and provides a value -based on these parameters, where the way you get that final value from -the given values can, properly speaking, involve an arbitrarily -complex series of operations. (In the case of Chinese, it'd be not at -all complex, at least in cases like the examples at the beginning of -this article; whereas in the case of Russian it'd be a rather complex -series of operations. And in some languages, the -complexity could be spread around differently: while the act of -putting a number-expression in front of a noun phrase might not be -complex by itself, it may change how you have to, for example, inflect -a verb elsewhere in the sentence. This is what in syntax is called -"long-distance dependencies".) - -This talk of parameters and arbitrary complexity is just another way -to say that an entry in a phrasebook is what in a programming language -would be called a "function". Just so you don't miss it, this is the -crux of this article: I - -The reason that using gettext runs into walls (as in the above -second-person horror story) is that you're trying to use a string (or -worse, a choice among a bunch of strings) to do what you really need a -function for -- which is futile. Preforming (s)printf interpolation -on the strings which you get back from gettext does allow you to do I -common things passably well... sometimes... sort of; but, to paraphrase -what some people say about C script programming, "it fools you -into thinking you can use it for real things, but you can't, and you -don't discover this until you've already spent too much time trying, -and by then it's too late." - -=head2 Replacing gettext - -So, what needs to replace gettext is a system that supports lexicons -of functions instead of lexicons of strings. An entry in a lexicon -from such a system should I look like this: - - "J'ai trouv\xE9 %g fichiers dans %g r\xE9pertoires" - -[\xE9 is e-acute in Latin-1. Some pod renderers would -scream if I used the actual character here. -- SB] - -but instead like this, bearing in mind that this is just a first stab: - - sub I_found_X1_files_in_X2_directories { - my( $files, $dirs ) = @_[0,1]; - $files = sprintf("%g %s", $files, - $files == 1 ? 'fichier' : 'fichiers'); - $dirs = sprintf("%g %s", $dirs, - $dirs == 1 ? "r\xE9pertoire" : "r\xE9pertoires"); - return "J'ai trouv\xE9 $files dans $dirs."; - } - -Now, there's no particularly obvious way to store anything but strings -in a gettext lexicon; so it looks like we just have to start over and -make something better, from scratch. I call my shot at a -gettext-replacement system "Maketext", or, in CPAN terms, -Locale::Maketext. - -When designing Maketext, I chose to plan its main features in terms of -"buzzword compliance". And here are the buzzwords: - -=head2 Buzzwords: Abstraction and Encapsulation - -The complexity of the language you're trying to output a phrase in is -entirely abstracted inside (and encapsulated within) the Maketext module -for that interface. When you call: - - print $lang->maketext("You have [quant,_1,piece] of new mail.", - scalar(@messages)); - -you don't know (and in fact can't easily find out) whether this will -involve lots of figuring, as in Russian (if $lang is a handle to the -Russian module), or relatively little, as in Chinese. That kind of -abstraction and encapsulation may encourage other pleasant buzzwords -like modularization and stratification, depending on what design -decisions you make. - -=head2 Buzzword: Isomorphism - -"Isomorphism" means "having the same structure or form"; in discussions -of program design, the word takes on the special, specific meaning that -your implementation of a solution to a problem I as, say, an informal verbal description of the solution, or -maybe of the problem itself. Isomorphism is, all things considered, -a good thing -- it's what problem-solving (and solution-implementing) -should look like. - -What's wrong the with gettext-using code like this... - - printf( $file_count == 1 ? - ( $directory_count == 1 ? - "Your query matched %g file in %g directory." : - "Your query matched %g file in %g directories." ) : - ( $directory_count == 1 ? - "Your query matched %g files in %g directory." : - "Your query matched %g files in %g directories." ), - $file_count, $directory_count, - ); - -is first off that it's not well abstracted -- these ways of testing -for grammatical number (as in the expressions like C) should be abstracted to each language -module, since how you get grammatical number is language-specific. - -But second off, it's not isomorphic -- the "solution" (i.e., the -phrasebook entries) for Chinese maps from these four English phrases to -the one Chinese phrase that fits for all of them. In other words, the -informal solution would be "The way to say what you want in Chinese is -with the one phrase 'For your question, in Y directories you would -find X files'" -- and so the implemented solution should be, -isomorphically, just a straightforward way to spit out that one -phrase, with numerals properly interpolated. It shouldn't have to map -from the complexity of other languages to the simplicity of this one. - -=head2 Buzzword: Inheritance - -There's a great deal of reuse possible for sharing of phrases between -modules for related dialects, or for sharing of auxiliary functions -between related languages. (By "auxiliary functions", I mean -functions that don't produce phrase-text, but which, say, return an -answer to "does this number require a plural noun after it?". Such -auxiliary functions would be used in the internal logic of functions -that actually do produce phrase-text.) - -In the case of sharing phrases, consider that you have an interface -already localized for American English (probably by having been -written with that as the native locale, but that's incidental). -Localizing it for UK English should, in practical terms, be just a -matter of running it past a British person with the instructions to -indicate what few phrases would benefit from a change in spelling or -possibly minor rewording. In that case, you should be able to put in -the UK English localization module I those phrases that are -UK-specific, and for all the rest, I from the American -English module. (And I expect this same situation would apply with -Brazilian and Continental Portugese, possbily with some I -closely related languages like Czech and Slovak, and possibly with the -slightly different "versions" of written Mandarin Chinese, as I hear exist in -Taiwan and mainland China.) - -As to sharing of auxiliary functions, consider the problem of Russian -numbers from the beginning of this article; obviously, you'd want to -write only once the hairy code that, given a numeric value, would -return some specification of which case and number a given quanitified -noun should use. But suppose that you discover, while localizing an -interface for, say, Ukranian (a Slavic language related to Russian, -spoken by several million people, many of whom would be relieved to -find that your Web site's or software's interface is available in -their language), that the rules in Ukranian are the same as in Russian -for quantification, and probably for many other grammatical functions. -While there may well be no phrases in common between Russian and -Ukranian, you could still choose to have the Ukranian module inherit -from the Russian module, just for the sake of inheriting all the -various grammatical methods. Or, probably better organizationally, -you could move those functions to a module called C<_E_Slavic> or -something, which Russian and Ukranian could inherit useful functions -from, but which would (presumably) provide no lexicon. - -=head2 Buzzword: Concision - -Okay, concision isn't a buzzword. But it should be, so I decree that -as a new buzzword, "concision" means that simple common things should -be expressible in very few lines (or maybe even just a few characters) -of code -- call it a special case of "making simple things easy and -hard things possible", and see also the role it played in the -MIDI::Simple language, discussed elsewhere in this issue [TPJ#13]. - -Consider our first stab at an entry in our "phrasebook of functions": - - sub I_found_X1_files_in_X2_directories { - my( $files, $dirs ) = @_[0,1]; - $files = sprintf("%g %s", $files, - $files == 1 ? 'fichier' : 'fichiers'); - $dirs = sprintf("%g %s", $dirs, - $dirs == 1 ? "r\xE9pertoire" : "r\xE9pertoires"); - return "J'ai trouv\xE9 $files dans $dirs."; - } - -You may sense that a lexicon (to use a non-committal catch-all term for a -collection of things you know how to say, regardless of whether they're -phrases or words) consisting of functions I as above would -make for rather long-winded and repetitive code -- even if you wisely -rewrote this to have quantification (as we call adding a number -expression to a noun phrase) be a function called like: - - sub I_found_X1_files_in_X2_directories { - my( $files, $dirs ) = @_[0,1]; - $files = quant($files, "fichier"); - $dirs = quant($dirs, "r\xE9pertoire"); - return "J'ai trouv\xE9 $files dans $dirs."; - } - -And you may also sense that you do not want to bother your translators -with having to write Perl code -- you'd much rather that they spend -their I on just translation. And this is to say -nothing of the near impossibility of finding a commercial translator -who would know even simple Perl. - -In a first-hack implementation of Maketext, each language-module's -lexicon looked like this: - - %Lexicon = ( - "I found %g files in %g directories" - => sub { - my( $files, $dirs ) = @_[0,1]; - $files = quant($files, "fichier"); - $dirs = quant($dirs, "r\xE9pertoire"); - return "J'ai trouv\xE9 $files dans $dirs."; - }, - ... and so on with other phrase => sub mappings ... - ); - -but I immediately went looking for some more concise way to basically -denote the same phrase-function -- a way that would also serve to -concisely denote I phrase-functions in the lexicon for I -languages. After much time and even some actual thought, I decided on -this system: - -* Where a value in a %Lexicon hash is a contentful string instead of -an anonymous sub (or, conceivably, a coderef), it would be interpreted -as a sort of shorthand expression of what the sub does. When accessed -for the first time in a session, it is parsed, turned into Perl code, -and then eval'd into an anonymous sub; then that sub replaces the -original string in that lexicon. (That way, the work of parsing and -evaling the shorthand form for a given phrase is done no more than -once per session.) - -* Calls to C (as Maketext's main function is called) happen -thru a "language session handle", notionally very much like an IO -handle, in that you open one at the start of the session, and use it -for "sending signals" to an object in order to have it return the text -you want. - -So, this: - - $lang->maketext("You have [quant,_1,piece] of new mail.", - scalar(@messages)); - -basically means this: look in the lexicon for $lang (which may inherit -from any number of other lexicons), and find the function that we -happen to associate with the string "You have [quant,_1,piece] of new -mail" (which is, and should be, a functioning "shorthand" for this -function in the native locale -- English in this case). If you find -such a function, call it with $lang as its first parameter (as if it -were a method), and then a copy of scalar(@messages) as its second, -and then return that value. If that function was found, but was in -string shorthand instead of being a fully specified function, parse it -and make it into a function before calling it the first time. - -* The shorthand uses code in brackets to indicate method calls that -should be performed. A full explanation is not in order here, but a -few examples will suffice: - - "You have [quant,_1,piece] of new mail." - -The above code is shorthand for, and will be interpreted as, -this: - - sub { - my $handle = $_[0]; - my(@params) = @_; - return join '', - "You have ", - $handle->quant($params[1], 'piece'), - "of new mail."; - } - -where "quant" is the name of a method you're using to quantify the -noun "piece" with the number $params[0]. - -A string with no brackety calls, like this: - - "Your search expression was malformed." - -is somewhat of a degerate case, and just gets turned into: - - sub { return "Your search expression was malformed." } - -However, not everything you can write in Perl code can be written in -the above shorthand system -- not by a long shot. For example, consider -the Italian translator from the beginning of this article, who wanted -the Italian for "I didn't find any files" as a special case, instead -of "I found 0 files". That couldn't be specified (at least not easily -or simply) in our shorthand system, and it would have to be written -out in full, like this: - - sub { # pretend the English strings are in Italian - my($handle, $files, $dirs) = @_[0,1,2]; - return "I didn't find any files" unless $files; - return join '', - "I found ", - $handle->quant($files, 'file'), - " in ", - $handle->quant($dirs, 'directory'), - "."; - } - -Next to a lexicon full of shorthand code, that sort of sticks out like a -sore thumb -- but this I a special case, after all; and at least -it's possible, if not as concise as usual. - -As to how you'd implement the Russian example from the beginning of -the article, well, There's More Than One Way To Do It, but it could be -something like this (using English words for Russian, just so you know -what's going on): - - "I [quant,_1,directory,accusative] scanned." - -This shifts the burden of complexity off to the quant method. That -method's parameters are: the numeric value it's going to use to -quantify something; the Russian word it's going to quantify; and the -parameter "accusative", which you're using to mean that this -sentence's syntax wants a noun in the accusative case there, although -that quantification method may have to overrule, for grammatical -reasons you may recall from the beginning of this article. - -Now, the Russian quant method here is responsible not only for -implementing the strange logic necessary for figuring out how Russian -number-phrases impose case and number on their noun-phrases, but also -for inflecting the Russian word for "directory". How that inflection -is to be carried out is no small issue, and among the solutions I've -seen, some (like variations on a simple lookup in a hash where all -possible forms are provided for all necessary words) are -straightforward but I become cumbersome when you need to inflect -more than a few dozen words; and other solutions (like using -algorithms to model the inflections, storing only root forms and -irregularities) I involve more overhead than is justifiable for -all but the largest lexicons. - -Mercifully, this design decision becomes crucial only in the hairiest -of inflected languages, of which Russian is by no means the I case -scenario, but is worse than most. Most languages have simpler -inflection systems; for example, in English or Swahili, there are -generally no more than two possible inflected forms for a given noun -("error/errors"; "kosa/makosa"), and the -rules for producing these forms are fairly simple -- or at least, -simple rules can be formulated that work for most words, and you can -then treat the exceptions as just "irregular", at least relative to -your ad hoc rules. A simpler inflection system (simpler rules, fewer -forms) means that design decisions are less crucial to maintaining -sanity, whereas the same decisions could incur -overhead-versus-scalability problems in languages like Russian. It -may I be likely that code (possibly in Perl, as with -Lingua::EN::Inflect, for English nouns) has already -been written for the language in question, whether simple or complex. - -Moreover, a third possibility may even be simpler than anything -discussed above: "Just require that all possible (or at least -applicable) forms be provided in the call to the given language's quant -method, as in:" - - "I found [quant,_1,file,files]." - -That way, quant just has to chose which form it needs, without having -to look up or generate anything. While possibly not optimal for -Russian, this should work well for most other languages, where -quantification is not as complicated an operation. - -=head2 The Devil in the Details - -There's plenty more to Maketext than described above -- for example, -there's the details of how language tags ("en-US", "i-pwn", "fi", -etc.) or locale IDs ("en_US") interact with actual module naming -("BogoQuery/Locale/en_us.pm"), and what magic can ensue; there's the -details of how to record (and possibly negotiate) what character -encoding Maketext will return text in (UTF8? Latin-1? KOI8?). There's -the interesting fact that Maketext is for localization, but nowhere -actually has a "C" anywhere in it. For the curious, -there's the somewhat frightening details of how I actually -implement something like data inheritance so that searches across -modules' %Lexicon hashes can parallel how Perl implements method -inheritance. - -And, most importantly, there's all the practical details of how to -actually go about deriving from Maketext so you can use it for your -interfaces, and the various tools and conventions for starting out and -maintaining individual language modules. - -That is all covered in the documentation for Locale::Maketext and the -modules that come with it, available in CPAN. After having read this -article, which covers the why's of Maketext, the documentation, -which covers the how's of it, should be quite straightfoward. - -=head2 The Proof in the Pudding: Localizing Web Sites - -Maketext and gettext have a notable difference: gettext is in C, -accessible thru C library calls, whereas Maketext is in Perl, and -really can't work without a Perl interpreter (although I suppose -something like it could be written for C). Accidents of history (and -not necessarily lucky ones) have made C++ the most common language for -the implementation of applications like word processors, Web browsers, -and even many in-house applications like custom query systems. Current -conditions make it somewhat unlikely that the next one of any of these -kinds of applications will be written in Perl, albeit clearly more for -reasons of custom and inertia than out of consideration of what is the -right tool for the job. - -However, other accidents of history have made Perl a well-accepted -language for design of server-side programs (generally in CGI form) -for Web site interfaces. Localization of static pages in Web sites is -trivial, feasable either with simple language-negotiation features in -servers like Apache, or with some kind of server-side inclusions of -language-appropriate text into layout templates. However, I think -that the localization of Perl-based search systems (or other kinds of -dynamic content) in Web sites, be they public or access-restricted, -is where Maketext will see the greatest use. - -I presume that it would be only the exceptional Web site that gets -localized for English I Chinese I Italian I Arabic -I Russian, to recall the languages from the beginning of this -article -- to say nothing of German, Spanish, French, Japanese, -Finnish, and Hindi, to name a few languages that benefit from large -numbers of programmers or Web viewers or both. - -However, the ever-increasing internationalization of the Web (whether -measured in terms of amount of content, of numbers of content writers -or programmers, or of size of content audiences) makes it increasingly -likely that the interface to the average Web-based dynamic content -service will be localized for two or maybe three languages. It is my -hope that Maketext will make that task as simple as possible, and will -remove previous barriers to localization for languages dissimilar to -English. - - __END__ - -Sean M. Burke (sburkeE<64>cpan.org) has a Master's in linguistics -from Northwestern University; he specializes in language technology. -Jordan Lachler (lachlerE<64>unm.edu) is a PhD student in the Department of -Linguistics at the University of New Mexico; he specializes in -morphology and pedagogy of North American native languages. - -=head2 References - -Alvestrand, Harald Tveit. 1995. I -C -[Now see RFC 3066.] - -Callon, Ross, editor. 1996. I -C - -Drepper, Ulrich, Peter Miller, -and FranEois Pinard. 1995-2001. GNU -C. Available in C, with -extensive docs in the distribution tarball. [Since -I wrote this article in 1998, I now see that the -gettext docs are now trying more to come to terms with -plurality. Whether useful conclusions have come from it -is another question altogether. -- SMB, May 2001] - -Forbes, Nevill. 1964. I Third Edition, revised -by J. C. Dumbreck. Oxford University Press. - -=cut - -#End - From slash5234 @ users.sourceforge.jp Tue Oct 25 04:20:50 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 04:20:50 +0900 Subject: [Affelio-cvs 662] CVS update: affelio_farm/admin/skelton/affelio/extlib/Locale Message-ID: <20051024192050.D3F7B2AC010@users.sourceforge.jp> Index: affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pm diff -u affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pm Tue Oct 25 04:20:50 2005 @@ -1,675 +0,0 @@ - -# Time-stamp: "2001-06-21 23:09:33 MDT" - -require 5; -package Locale::Maketext; -use strict; -use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS - $USE_LITERALS); -use Carp (); -use I18N::LangTags 0.21 (); - -#-------------------------------------------------------------------------- - -BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } - # define the constant 'DEBUG' at compile-time - -$VERSION = "1.03"; - @ ISA = (); - -$MATCH_SUPERS = 1; -$USING_LANGUAGE_TAGS = 1; - # Turning this off is somewhat of a security risk in that little or no - # checking will be done on the legality of tokens passed to the - # eval("use $module_name") in _try_use. If you turn this off, you have - # to do your own taint checking. - -$USE_LITERALS = 1 unless defined $USE_LITERALS; - # a hint for compiling bracket-notation things. - -my %isa_scan = (); - -########################################################################### - -sub quant { - my($handle, $num, @forms) = @_; - - return $num if @forms == 0; # what should this mean? - return $forms[2] if @forms > 2 and $num == 0; # special zeroth case - - # Normal case: - # Note that the formatting of $num is preserved. - return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) ); - # Most human languages put the number phrase before the qualified phrase. -} - - -sub numerate { - # return this lexical item in a form appropriate to this number - my($handle, $num, @forms) = @_; - my $s = ($num == 1); - - return '' unless @forms; - if(@forms == 1) { # only the headword form specified - return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack. - } else { # sing and plural were specified - return $s ? $forms[0] : $forms[1]; - } -} - -#-------------------------------------------------------------------------- - -sub numf { - my($handle, $num) = @_[0,1]; - if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) { - $num += 0; # Just use normal integer stringification. - # Specifically, don't let %G turn ten million into 1E+007 - } else { - $num = CORE::sprintf("%G", $num); - # "CORE::" is there to avoid confusion with the above sub sprintf. - } - while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5 - # The initial \d+ gobbles as many digits as it can, and then we - # backtrack so it un-eats the rightmost three, and then we - # insert the comma there. - - $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'}; - # This is just a lame hack instead of using Number::Format - return $num; -} - -sub sprintf { - no integer; - my($handle, $format, @params) = @_; - return CORE::sprintf($format, @params); - # "CORE::" is there to avoid confusion with myself! -} - -#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# - -use integer; # vroom vroom... applies to the whole rest of the module - -sub language_tag { - my $it = ref($_[0]) || $_[0]; - return undef unless $it =~ m/([^':]+)(?:::)?$/s; - $it = lc($1); - $it =~ tr<_><->; - return $it; -} - -sub encoding { - my $it = $_[0]; - return( - (ref($it) && $it->{'encoding'}) - || "iso-8859-1" # Latin-1 - ); -} - -#-------------------------------------------------------------------------- - -sub fallback_languages { return('i-default', 'en', 'en-US') } - -sub fallback_language_classes { return () } - -#-------------------------------------------------------------------------- - -sub fail_with { # an actual attribute method! - my($handle, @params) = @_; - return unless ref($handle); - $handle->{'fail'} = $params[0] if @params; - return $handle->{'fail'}; -} - -#-------------------------------------------------------------------------- - -sub failure_handler_auto { - # Meant to be used like: - # $handle->fail_with('failure_handler_auto') - - my($handle, $phrase, @params) = @_; - $handle->{'failure_lex'} ||= {}; - my $lex = $handle->{'failure_lex'}; - - my $value; - $lex->{$phrase} ||= ($value = $handle->_compile($phrase)); - - # Dumbly copied from sub maketext: - { - local $SIG{'__DIE__'}; - eval { $value = &$value($handle, @_) }; - } - # If we make it here, there was an exception thrown in the - # call to $value, and so scream: - if($@) { - my $err = $@; - # pretty up the error message - $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?> - <\n in bracket code [compiled line $1],>s; - #$err =~ s/\n?$/\n/s; - Carp::croak "Error in maketexting \"$phrase\":\n$err as used"; - # Rather unexpected, but suppose that the sub tried calling - # a method that didn't exist. - } else { - return $value; - } -} - -#========================================================================== - -sub new { - # Nothing fancy! - my $class = ref($_[0]) || $_[0]; - my $handle = bless {}, $class; - $handle->init; - return $handle; -} - -sub init { return } # no-op - -########################################################################### - -sub maketext { - # Remember, this can fail. Failure is controllable many ways. - Carp::croak "maketext requires at least one parameter" unless @_ > 1; - - my($handle, $phrase) = splice(@_,0,2); - - # Look up the value: - - my $value; - foreach my $h_r ( - @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs } - ) { - print "* Looking up \"$phrase\" in $h_r\n" if DEBUG; - if(exists $h_r->{$phrase}) { - print " Found \"$phrase\" in $h_r\n" if DEBUG; - unless(ref($value = $h_r->{$phrase})) { - # Nonref means it's not yet compiled. Compile and replace. - $value = $h_r->{$phrase} = $handle->_compile($value); - } - last; - } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) { - # it's an auto lex, and this is an autoable key! - print " Automaking \"$phrase\" into $h_r\n" if DEBUG; - - $value = $h_r->{$phrase} = $handle->_compile($phrase); - last; - } - print " Not found in $h_r, nor automakable\n" if DEBUG > 1; - # else keep looking - } - - unless(defined($value)) { - print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, - " fails.\n" if DEBUG; - if(ref($handle) and $handle->{'fail'}) { - print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG; - my $fail; - if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference - return &{$fail}($handle, $phrase, @_); - # If it ever returns, it should return a good value. - } else { # It's a method name - return $handle->$fail($phrase, @_); - # If it ever returns, it should return a good value. - } - } else { - # All we know how to do is this; - Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed"); - } - } - - return $$value if ref($value) eq 'SCALAR'; - return $value unless ref($value) eq 'CODE'; - - { - local $SIG{'__DIE__'}; - eval { $value = &$value($handle, @_) }; - } - # If we make it here, there was an exception thrown in the - # call to $value, and so scream: - if($@) { - my $err = $@; - # pretty up the error message - $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?> - <\n in bracket code [compiled line $1],>s; - #$err =~ s/\n?$/\n/s; - Carp::croak "Error in maketexting \"$phrase\":\n$err as used"; - # Rather unexpected, but suppose that the sub tried calling - # a method that didn't exist. - } else { - return $value; - } -} - -########################################################################### - -sub get_handle { # This is a constructor and, yes, it CAN FAIL. - # Its class argument has to be the base class for the current - # application's l10n files. - my($base_class, @languages) = @_; - $base_class = ref($base_class) || $base_class; - # Complain if they use __PACKAGE__ as a project base class? - - unless(@languages) { # Calling with no args is magical! wooo, magic! - if(length( $ENV{'REQUEST_METHOD'} || '' )) { # I'm a CGI - my $in = $ENV{'HTTP_ACCEPT_LANGUAGE'} || ''; - # supposedly that works under mod_perl, too. - $in =~ s<\([\)]*\)><>g; # Kill parens'd things -- just a hack. - @languages = &I18N::LangTags::extract_language_tags($in) if length $in; - # ...which untaints, incidentally. - - } else { # Not running as a CGI: try to puzzle out from the environment - if(length( $ENV{'LANG'} || '' )) { - push @languages, split m/[,:]/, $ENV{'LANG'}; - # LANG can be only /one/ locale as far as I know, but what the hey. - } - if(length( $ENV{'LANGUAGE'} || '' )) { - push @languages, split m/[,:]/, $ENV{'LANGUAGE'}; - } - print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG; - # Those are really locale IDs, but they get xlated a few lines down. - - if(&_try_use('Win32::Locale')) { - # If we have that module installed... - push @languages, Win32::Locale::get_language() - if defined &Win32::Locale::get_language; - } - } - } - - #------------------------------------------------------------------------ - print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG; - - if($USING_LANGUAGE_TAGS) { - @languages = map &I18N::LangTags::locale2language_tag($_), @languages; - # if it's a lg tag, fine, pass thru (untainted) - # if it's a locale ID, try converting to a lg tag (untainted), - # otherwise nix it. - - push @languages, map I18N::LangTags::super_languages($_), @languages - if $MATCH_SUPERS; - - @languages = map { $_, I18N::LangTags::alternate_language_tags($_) } - @languages; # catch alternation - - push @languages, I18N::LangTags::panic_languages(@languages) - if defined &I18N::LangTags::panic_languages; - - push @languages, $base_class->fallback_languages; - # You are free to override fallback_languages to return empty-list! - - @languages = # final bit of processing: - map { - my $it = $_; # copy - $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _ - $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_ - $it; - } @languages - ; - } - print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1; - - push @languages, $base_class->fallback_language_classes; - # You are free to override that to return whatever. - - - my %seen = (); - foreach my $module_name ( map { $base_class . "::" . $_ } @languages ) - { - next unless length $module_name; # sanity - next if $seen{$module_name}++ # Already been here, and it was no-go - || !&_try_use($module_name); # Try to use() it, but can't it. - return($module_name->new); # Make it! - } - - return undef; # Fail! -} - -########################################################################### -# -# This is where most people should stop reading. -# -########################################################################### - -sub _compile { - # This big scarp routine compiles an entry. - # It returns either a coderef if there's brackety bits in this, or - # otherwise a ref to a scalar. - - my $target = ref($_[0]) || $_[0]; - - my(@code); - my(@c) = (''); # "chunks" -- scratch. - my $call_count = 0; - my $big_pile = ''; - { - my $in_group = 0; # start out outside a group - my($m, @params); # scratch - - while($_[1] =~ # Iterate over chunks. - m<\G( - [^\~\[\]]+ # non-~[] stuff - | - ~. # ~[, ~], ~~, ~other - | - \[ # [ presumably opening a group - | - \] # ] presumably closing a group - | - ~ # terminal ~ ? - | - $ - )>xgs - ) { - print " \"$1\"\n" if DEBUG > 2; - - if($1 eq '[' or $1 eq '') { # "[" or end - # Whether this is "[" or end, force processing of any - # preceding literal. - if($in_group) { - if($1 eq '') { - $target->_die_pointing($_[1], "Unterminated bracket group"); - } else { - $target->_die_pointing($_[1], "You can't nest bracket groups"); - } - } else { - if($1 eq '') { - print " [end-string]\n" if DEBUG > 2; - } else { - $in_group = 1; - } - die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity - if(length $c[-1]) { - # Now actually processing the preceding literal - $big_pile .= $c[-1]; - if($USE_LITERALS and ( - (ord('A') == 65) - ? $c[-1] !~ m<[^\x20-\x7E]>s - # ASCII very safe chars - : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s - # EBCDIC very safe chars - )) { - # normal case -- all very safe chars - $c[-1] =~ s/'/\\'/g; - push @code, q{ '} . $c[-1] . "',\n"; - $c[-1] = ''; # reuse this slot - } else { - push @code, ' $c[' . $#c . "],\n"; - push @c, ''; # new chunk - } - } - # else just ignore the empty string. - } - - } elsif($1 eq ']') { # "]" - # close group -- go back in-band - if($in_group) { - $in_group = 0; - - print " --Closing group [$c[-1]]\n" if DEBUG > 2; - - # And now process the group... - - if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) { - DEBUG > 2 and print " -- (Ignoring)\n"; - $c[-1] = ''; # reset out chink - next; - } - - #$c[-1] =~ s/^\s+//s; - #$c[-1] =~ s/\s+$//s; - ($m, @ params) = split(",", $c[-1], -1); # was /\s*,\s*/ - - # A bit of a hack -- we've turned "~,"'s into DELs, so turn - # 'em into real commas here. - if (ord('A') == 65) { # ASCII, etc - foreach($m, @params) { tr/\x7F/,/ } - } else { # EBCDIC (1047, 0037, POSIX-BC) - # Thanks to Peter Prymmer for the EBCDIC handling - foreach($m, @params) { tr/\x07/,/ } - } - - # Special-case handling of some method names: - if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) { - # Treat [_1,...] as [,_1,...], etc. - unshift @params, $m; - $m = ''; - } elsif($m eq '*') { - $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars" - } elsif($m eq '#') { - $m = 'numf'; # "#" for "number": [#,_1] for "the number _1" - } - - # Most common case: a simple, legal-looking method name - if($m eq '') { - # 0-length method name means to just interpolate: - push @code, ' ('; - } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s - and $m !~ m<(?:^|\:)\d>s - # exclude starting a (sub)package or symbol with a digit - ) { - # Yes, it even supports the demented (and undocumented?) - # $obj->Foo::bar(...) syntax. - $target->_die_pointing( - $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method", - 2 + length($c[-1]) - ) - if $m =~ m/^SUPER::/s; - # Because for SUPER:: to work, we'd have to compile this into - # the right package, and that seems just not worth the bother, - # unless someone convinces me otherwise. - - push @code, ' $_[0]->' . $m . '('; - } else { - # TODO: implement something? or just too icky to consider? - $target->_die_pointing( - $_[1], - "Can't use \"$m\" as a method name in bracket group", - 2 + length($c[-1]) - ); - } - - pop @c; # we don't need that chunk anymore - ++$call_count; - - foreach my $p (@params) { - if($p eq '_*') { - # Meaning: all parameters except $_[0] - $code[-1] .= ' @_[1 .. $#_], '; - # and yes, that does the right thing for all @_ < 3 - } elsif($p =~ m<^_(-?\d+)$>s) { - # _3 meaning $_[3] - $code[-1] .= '$_[' . (0 + $1) . '], '; - } elsif($USE_LITERALS and ( - (ord('A') == 65) - ? $p !~ m<[^\x20-\x7E]>s - # ASCII very safe chars - : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s - # EBCDIC very safe chars - )) { - # Normal case: a literal containing only safe characters - $p =~ s/'/\\'/g; - $code[-1] .= q{'} . $p . q{', }; - } else { - # Stow it on the chunk-stack, and just refer to that. - push @c, $p; - push @code, ' $c[' . $#c . "], "; - } - } - $code[-1] .= "),\n"; - - push @c, ''; - } else { - $target->_die_pointing($_[1], "Unbalanced ']'"); - } - - } elsif(substr($1,0,1) ne '~') { - # it's stuff not containing "~" or "[" or "]" - # i.e., a literal blob - $c[-1] .= $1; - - } elsif($1 eq '~~') { # "~~" - $c[-1] .= '~'; - - } elsif($1 eq '~[') { # "~[" - $c[-1] .= '['; - - } elsif($1 eq '~]') { # "~]" - $c[-1] .= ']'; - - } elsif($1 eq '~,') { # "~," - if($in_group) { - # This is a hack, based on the assumption that no-one will actually - # want a DEL inside a bracket group. Let's hope that's it's true. - if (ord('A') == 65) { # ASCII etc - $c[-1] .= "\x7F"; - } else { # EBCDIC (cp 1047, 0037, POSIX-BC) - $c[-1] .= "\x07"; - } - } else { - $c[-1] .= '~,'; - } - - } elsif($1 eq '~') { # possible only at string-end, it seems. - $c[-1] .= '~'; - - } else { - # It's a "~X" where X is not a special character. - # Consider it a literal ~ and X. - $c[-1] .= $1; - } - } - } - - if($call_count) { - undef $big_pile; # Well, nevermind that. - } else { - # It's all literals! Ahwell, that can happen. - # So don't bother with the eval. Return a SCALAR reference. - return \$big_pile; - } - - die "Last chunk isn't null??" if @c and length $c[-1]; # sanity - print scalar(@c), " chunks under closure\n" if DEBUG; - if(@code == 0) { # not possible? - print "Empty code\n" if DEBUG; - return \''; - } elsif(@code > 1) { # most cases, presumably! - unshift @code, "join '',\n"; - } - unshift @code, "use strict; sub {\n"; - push @code, "}\n"; - - print @code if DEBUG; - my $sub = eval(join '', @code); - die "$@ while evalling" . join('', @code) if $@; # Should be impossible. - return $sub; -} - -# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -sub _die_pointing { - # This is used by _compile to throw a fatal error - my $target = shift; # class name - # ...leaving $_[0] the error-causing text, and $_[1] the error message - - my $i = index($_[0], "\n"); - - my $pointy; - my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1; - if($pos < 1) { - $pointy = "^=== near there\n"; - } else { # we need to space over - my $first_tab = index($_[0], "\t"); - if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) { - # No tabs, or the first tab is harmlessly after where we will point to, - # AND we're far enough from the margin that we can draw a proper arrow. - $pointy = ('=' x $pos) . "^ near there\n"; - } else { - # tabs screw everything up! - $pointy = substr($_[0],0,$pos); - $pointy =~ tr/\t //cd; - # make everything into whitespace, but preseving tabs - $pointy .= "^=== near there\n"; - } - } - - my $errmsg = "$_[1], in\:\n$_[0]"; - - if($i == -1) { - # No newline. - $errmsg .= "\n" . $pointy; - } elsif($i == (length($_[0]) - 1) ) { - # Already has a newline at end. - $errmsg .= $pointy; - } else { - # don't bother with the pointy bit, I guess. - } - Carp::croak( "$errmsg via $target, as used" ); -} - -########################################################################### - -my %tried = (); - # memoization of whether we've used this module, or found it unusable. - -sub _try_use { # Basically a wrapper around "require Modulename" - # "Many men have tried..." "They tried and failed?" "They tried and died." - return $tried{$_[0]} if exists $tried{$_[0]}; # memoization - - my $module = $_[0]; # ASSUME sane module name! - { no strict 'refs'; - return($tried{$module} = 1) - if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"}); - # weird case: we never use'd it, but there it is! - } - - print " About to use $module ...\n" if DEBUG; - { - local $SIG{'__DIE__'}; - eval "require $module"; # used to be "use $module", but no point in that. - } - if($@) { - print "Error using $module \: $@\n" if DEBUG > 1; - return $tried{$module} = 0; - } else { - print " OK, $module is used\n" if DEBUG; - return $tried{$module} = 1; - } -} - -#-------------------------------------------------------------------------- - -sub _lex_refs { # report the lexicon references for this handle's class - # returns an arrayREF! - no strict 'refs'; - my $class = ref($_[0]) || $_[0]; - print "Lex refs lookup on $class\n" if DEBUG > 1; - return $isa_scan{$class} if exists $isa_scan{$class}; # memoization! - - my @lex_refs; - my $seen_r = ref($_[1]) ? $_[1] : {}; - - if( defined( *{$class . '::Lexicon'}{'HASH'} )) { - push @lex_refs, *{$class . '::Lexicon'}{'HASH'}; - print "%" . $class . "::Lexicon contains ", - scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG; - } - - # Implements depth(height?)-first recursive searching of superclasses. - # In hindsight, I suppose I could have just used Class::ISA! - foreach my $superclass (@{$class . "::ISA"}) { - print " Super-class search into $superclass\n" if DEBUG; - next if $seen_r->{$superclass}++; - push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself - } - - $isa_scan{$class} = \@lex_refs; # save for next time - return \@lex_refs; -} - -sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity! - -########################################################################### -1; - Index: affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pod diff -u affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pod:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pod:removed --- affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pod:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/Locale/Maketext.pod Tue Oct 25 04:20:50 2005 @@ -1,1321 +0,0 @@ - -# Time-stamp: "2001-06-21 23:12:39 MDT" - -=head1 NAME - -Locale::Maketext -- framework for localization - -=head1 SYNOPSIS - - package MyProgram; - use strict; - use MyProgram::L10N; - # ...which inherits from Locale::Maketext - my $lh = MyProgram::L10N->get_handle() || die "What language?"; - ... - # And then any messages your program emits, like: - warn $lh->maketext( "Can't open file [_1]: [_2]\n", $f, $! ); - ... - -=head1 DESCRIPTION - -It is a common feature of applications (whether run directly, -or via the Web) for them to be "localized" -- i.e., for them -to a present an English interface to an English-speaker, a German -interface to a German-speaker, and so on for all languages it's -programmed with. Locale::Maketext -is a framework for software localization; it provides you with the -tools for organizing and accessing the bits of text and text-processing -code that you need for producing localized applications. - -In order to make sense of Maketext and how all its -components fit together, you should probably -go read L, and -I read the following documentation. - -You may also want to read over the source for C -and its constituent modules -- they are a complete (if small) -example application that uses Maketext. - -=head1 QUICK OVERVIEW - -The basic design of Locale::Maketext is object-oriented, and -Locale::Maketext is an abstract base class, from which you -derive a "project class". -The project class (with a name like "TkBocciBall::Localize", -which you then use in your module) is in turn the base class -for all the "language classes" for your project -(with names "TkBocciBall::Localize::it", -"TkBocciBall::Localize::en", -"TkBocciBall::Localize::fr", etc.). - -A language class is -a class containing a lexicon of phrases as class data, -and possibly also some methods that are of use in interpreting -phrases in the lexicon, or otherwise dealing with text in that -language. - -An object belonging to a language class is called a "language -handle"; it's typically a flyweight object. - -The normal course of action is to call: - - use TkBocciBall::Localize; # the localization project class - $lh = TkBocciBall::Localize->get_handle(); - # Depending on the user's locale, etc., this will - # make a language handle from among the classes available, - # and any defaults that you declare. - die "Couldn't make a language handle??" unless $lh; - -From then on, you use the C function to access -entries in whatever lexicon(s) belong to the language handle -you got. So, this: - - print $lh->maketext("You won!"), "\n"; - -...emits the right text for this language. If the object -in C<$lh> belongs to class "TkBocciBall::Localize::fr" and -%TkBocciBall::Localize::fr::Lexicon contains C<("You won!" -=E "Tu as gagnE!")>, then the above -code happily tells the user "Tu as gagnE!". - -=head1 METHODS - -Locale::Maketext offers a variety of methods, which fall -into three categories: - -=over - -=item * - -Methods to do with constructing language handles. - -=item * - -C and other methods to do with accessing %Lexicon data -for a given language handle. - -=item * - -Methods that you may find it handy to use, from routines of -yours that you put in %Lexicon entries. - -=back - -These are covered in the following section. - -=head2 Construction Methods - -These are to do with constructing a language handle: - -=over - -=item * - -$lh = YourProjClass->get_handle( ...langtags... ) || die "lg-handle?"; - -This tries loading classes based on the language-tags you give (like -C<("en-US", "sk", "kon", "es-MX", "ja", "i-klingon")>, and for the first class -that succeeds, returns YourProjClass::I->new(). - -It runs thru the entire given list of language-tags, and finds no classes -for those exact terms, it then tries "superordinate" language classes. -So if no "en-US" class (i.e., YourProjClass::en_us) -was found, nor classes for anything else in that list, we then try -its superordinate, "en" (i.e., YourProjClass::en), and so on thru -the other language-tags in the given list: "es". -(The other language-tags in our example list: -happen to have no superordinates.) - -If none of those language-tags leads to loadable classes, we then -try classes derived from YourProjClass->fallback_languages() and -then if nothing comes of that, we use classes named by -YourProjClass->fallback_language_classes(). Then in the (probably -quite unlikely) event that that fails, we just return undef. - -=item * - -$lh = YourProjClass->get_handleB<()> || die "lg-handle?"; - -When C is called with an empty parameter list, magic happens: - -If C senses that it's running in program that was -invoked as a CGI, then it tries to get language-tags out of the -environment variable "HTTP_ACCEPT_LANGUAGE", and it pretends that -those were the languages passed as parameters to C. - -Otherwise (i.e., if not a CGI), this tries various OS-specific ways -to get the language-tags for the current locale/language, and then -pretends that those were the value(s) passed to C. - -Currently this OS-specific stuff consists of looking in the environment -variables "LANG" and "LANGUAGE"; and on MSWin machines (where those -variables are typically unused), this also tries using -the module Win32::Locale to get a language-tag for whatever language/locale -is currently selected in the "Regional Settings" (or "International"?) -Control Panel. I welcome further -suggestions for making this do the Right Thing under other operating -systems that support localization. - -If you're using localization in an application that keeps a configuration -file, you might consider something like this in your project class: - - sub get_handle_via_config { - my $class = $_[0]; - my $preferred_language = $Config_settings{'language'}; - my $lh; - if($preferred_language) { - $lh = $class->get_handle($chosen_language) - || die "No language handle for \"$chosen_language\" or the like"; - } else { - # Config file missing, maybe? - $lh = $class->get_handle() - || die "Can't get a language handle"; - } - return $lh; - } - -=item * - -$lh = YourProjClass::langname->new(); - -This constructs a language handle. You usually B call this -directly, but instead let C find a language class to C -and to then call ->new on. - -=item * - -$lh->init(); - -This is called by ->new to initialize newly-constructed language handles. -If you define an init method in your class, remember that it's usually -considered a good idea to call $lh->SUPER::init in it (presumably at the -beginning), so that all classes get a chance to initialize a new object -however they see fit. - -=item * - -YourProjClass->fallback_languages() - -C appends the return value of this to the end of -whatever list of languages you pass C. Unless -you override this method, your project class -will inherit Locale::Maketext's C, which -currently returns C<('i-default', 'en', 'en-US')>. -("i-default" is defined in RFC 2277). - -This method (by having it return the name -of a language-tag that has an existing language class) -can be used for making sure that -C will always manage to construct a language -handle (assuming your language classes are in an appropriate - @ INC directory). Or you can use the next method: - -=item * - -YourProjClass->fallback_language_classes() - -C appends the return value of this to the end -of the list of classes it will try using. Unless -you override this method, your project class -will inherit Locale::Maketext's C, -which currently returns an empty list, C<()>. -By setting this to some value (namely, the name of a loadable -language class), you can be sure that -C will always manage to construct a language -handle. - -=back - -=head2 The "maketext" Method - -This is the most important method in Locale::Maketext: - -$text = $lh->maketext(I, ...parameters for this phrase...); - -This looks in the %Lexicon of the language handle -$lh and all its superclasses, looking -for an entry whose key is the string I. Assuming such -an entry is found, various things then happen, depending on the -value found: - -If the value is a scalarref, the scalar is dereferenced and returned -(and any parameters are ignored). -If the value is a coderef, we return &$value($lh, ...parameters...). -If the value is a string that I look like it's in Bracket Notation, -we return it (after replacing it with a scalarref, in its %Lexicon). -If the value I look like it's in Bracket Notation, then we compile -it into a sub, replace the string in the %Lexicon with the new coderef, -and then we return &$new_sub($lh, ...parameters...). - -Bracket Notation is discussed in a later section. Note -that trying to compile a string into Bracket Notation can throw -an exception if the string is not syntactically valid (say, by not -balancing brackets right.) - -Also, calling &$coderef($lh, ...parameters...) can throw any sort of -exception (if, say, code in that sub tries to divide by zero). But -a very common exception occurs when you have Bracket -Notation text that says to call a method "foo", but there is no such -method. (E.g., "You have [quaB,_1,ball]." will throw an exception -on trying to call $lh->quaB($_[1],'ball') -- you presumably meant -"quant".) C catches these exceptions, but only to make the -error message more readable, at which point it rethrows the exception. - -An exception I be thrown if I is not found in any -of $lh's %Lexicon hashes. What happens if a key is not found, -is discussed in a later section, "Controlling Lookup Failure". - -Note that you might find it useful in some cases to override -the C method with an "after method", if you want to -translate encodings, or even scripts: - - package YrProj::zh_cn; # Chinese with PRC-style glyphs - use base ('YrProj::zh_tw'); # Taiwan-style - sub maketext { - my $self = shift(@_); - my $value = $self->maketext(@_); - return Chineeze::taiwan2mainland($value); - } - -Or you may want to override it with something that traps -any exceptions, if that's critical to your program: - - sub maketext { - my($lh, @stuff) = @_; - my $out; - eval { $out = $lh->SUPER::maketext(@stuff) }; - return $out unless $@; - ...otherwise deal with the exception... - } - -Other than those two situations, I don't imagine that -it's useful to override the C method. (If -you run into a situation where it is useful, I'd be -interested in hearing about it.) - -=over - -=item $lh->fail_with I $lh->fail_with(I) - -=item $lh->failure_handler_auto - -These two methods are discussed in the section "Controlling -Lookup Failure". - -=back - -=head2 Utility Methods - -These are methods that you may find it handy to use, generally -from %Lexicon routines of yours (whether expressed as -Bracket Notation or not). - -=over - -=item $language->quant($number, $singular) - -=item $language->quant($number, $singular, $plural) - -=item $language->quant($number, $singular, $plural, $negative) - -This is generally meant to be called from inside Bracket Notation -(which is discussed later), as in - - "Your search matched [quant,_1,document]!" - -It's for I a noun (i.e., saying how much of it there is, -while giving the currect form of it). The behavior of this method is -handy for English and a few other Western European languages, and you -should override it for languages where it's not suitable. You can feel -free to read the source, but the current implementation is basically -as this pseudocode describes: - - if $number is 0 and there's a $negative, - return $negative; - elsif $number is 1, - return "1 $singular"; - elsif there's a $plural, - return "$number $plural"; - else - return "$number " . $singular . "s"; - # - # ...except that we actually call numf to - # stringify $number before returning it. - -So for English (with Bracket Notation) -C<"...[quant,_1,file]..."> is fine (for 0 it returns "0 files", -for 1 it returns "1 file", and for more it returns "2 files", etc.) - -But for "directory", you'd want C<"[quant,_1,direcory,directories]"> -so that our elementary C method doesn't think that the -plural of "directory" is "directorys". And you might find that the -output may sound better if you specify a negative form, as in: - - "[quant,_1,file,files,No files] matched your query.\n" - -Remember to keep in mind verb agreement (or adjectives too, in -other languages), as in: - - "[quant,_1,document] were matched.\n" - -Because if _1 is one, you get "1 document B matched". -An acceptable hack here is to do something like this: - - "[quant,_1,document was, documents were] matched.\n" - -=item $language->numf($number) - -This returns the given number formatted nicely according to -this language's conventions. Maketext's default method is -mostly to just take the normal string form of the number -(applying sprintf "%G" for only very large numbers), and then -to add commas as necessary. (Except that -we apply C

- -
Owner Page: -... -
-
- -
-
-
- -
- -
-
-
- - - - - - - - - - - - - - - - - -
- -
-
- -
- - - - -
- - - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol.tmpl Tue Oct 25 04:20:57 2005 @@ -1,177 +0,0 @@ - - - - - -
- - -
- - -
-... -
-
- -
-
-
- -
- -
- - - - - - - -
-
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- -" disabled>" >" >" >" >" >" disabled>" >" >" >" >" >" >" >" >" >
 
- -" disabled>" >" >" >" >" >" disabled>" >" >" >" >" >" >" >" >" >
 


()
-

-"> -

-
- - - - -
- -
-
- - - - - -
- - - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_showapp.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_showapp.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_showapp.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_showapp.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_showapp.tmpl Tue Oct 25 04:20:57 2005 @@ -1,88 +0,0 @@ - - -/style.css" media="screen"> - - - - - - - - - - - -
- - -
- -
- -
-
- -
- -
- - - - -
"> - -"> -"> -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
- - -" checked> -
-
- -

-"> -

-
-
- -
-
-
-
- - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_top.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_top.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_top.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_top.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_accesscontrol_apps_top.tmpl Tue Oct 25 04:20:57 2005 @@ -1,71 +0,0 @@ - - - - -
- - -
- - -
-... -
-
- -
-
-
- -
- -
-
-
- - - - - - - - - - - - - - - - - - -
" TARGET="FCHILD">" TARGET="_blank">
-
-
- - - - - - - - - - -
-
- - - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_affelio_config.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_affelio_config.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_affelio_config.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_affelio_config.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_affelio_config.tmpl Tue Oct 25 04:20:57 2005 @@ -1,76 +0,0 @@ - - - - - -
- - -
- - -
Owner Page: -... -
-
- -
-
-
- -
- -
- -
-
-
-" > -

- -

-
- -
-
-
- -

-> -> -

-
- -
-
-
- -

-" disabled> -

-
- - -"> - - - -
-
- - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_composemessage.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_composemessage.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_composemessage.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_composemessage.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_composemessage.tmpl Tue Oct 25 04:20:57 2005 @@ -1,65 +0,0 @@ - - - -
- -
- - -
-... -
-
- -
-
-
- - -
- -
- -
- -
- - - - - - - - - - - - - -
- -
">
-
-
- -
- -" tabindex="4"> -
- -
-
- - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_skins.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_skins.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_skins.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_skins.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_skins.tmpl Tue Oct 25 04:20:57 2005 @@ -1,116 +0,0 @@ - - - - -
- - -
- - -
-... -
-
- -
-
-
- -
- -
-
- -
- -"> -
- -
- - -
-
- - - -
-
- - -
-
- -
-
-()
- -
-"> -
-
-
-
- - -
-
- -
- -
- - - - - - -
- -> - -" > -
-
-
- - - -
-
-
-: skin//style.css
-

-
- -"> -
-
- - - - -
- -
- - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_templates.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_templates.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_templates.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_templates.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_edit_templates.tmpl Tue Oct 25 04:20:57 2005 @@ -1,94 +0,0 @@ - - - -
- - -
- - -
-... -
-
- -
- -

- - -

-
-
- -
- -
-
-"> -
-
- -
- -
-
- -"> -
- -
-
- -"> -
- -
-
- -"> -
- -
-
- -"> -
- -
-
- -
-
- -"> -
- -
-
- -"> -
- -
-
- -"> -
- -
- -
- -
- - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_editprofile.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_editprofile.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_editprofile.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_editprofile.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_editprofile.tmpl Tue Oct 25 04:20:57 2005 @@ -1,169 +0,0 @@ - - - - - -
- - -
- - -
: -... -
-
- -
-
-
- -
-
-
-

-

- - - - - - - - - - -
-"> -:" SIZE="15">:" SIZE="15">:" SIZE="15">
-:" SIZE="15"> (free format :P)
  -"> -
-
-
- - -
-
-
- -
-
- -
- -
-
- -

- -  -  -"> - -

-
-
- - -
-
-

-

- -

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-:" SIZE="50">
-:" SIZE="50"> -

-:" SIZE="50">
:" SIZE="50"> -

-:" SIZE="50">
:" SIZE="50"> -

-:" SIZE="50">
:" SIZE="50"> -

-:" SIZE="50">
:" SIZE="50"> -

-:" SIZE="50">
:" SIZE="50"> -

-:" SIZE="50">
:" SIZE="50"> -
-

- - -
-
-
- -
- -
-
- -
- -
-
-
- -
- -
-
- -"> - - - -
-
- - - - - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_friendsgraph.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_friendsgraph.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_friendsgraph.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_friendsgraph.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_friendsgraph.tmpl Tue Oct 25 04:20:57 2005 @@ -1,57 +0,0 @@ - - - - - - - - - - - -
- - - - - - -
- Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_groupmember_table.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_groupmember_table.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_groupmember_table.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_groupmember_table.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_groupmember_table.tmpl Tue Oct 25 04:20:57 2005 @@ -1,78 +0,0 @@ - - - - -
- -
- - -
-... -
-
- -
-
-
- -
- - - - - -
- -
-
- - - - - - - - - - - - - - - - - - - -
  - -" VALUE="there"> -
- - -" > -
-
-

-"> - -

- - -
- -
- - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_showmember.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_showmember.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_showmember.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_showmember.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_showmember.tmpl Tue Oct 25 04:20:57 2005 @@ -1,202 +0,0 @@ - - -/style.css" media="screen"> - - - - - - - - - - -
- - -
- -
-
- - -
- -
- -
-
- -
- -
-
- - - - - -
-" BORDER="0" WIDTH="96" > -
- -
- -
&modified=intro"> - -"> -
-
-
-
- -

- -

-
-"> -
- -
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
-">
&gid=">" title=""> - -
-
-
- -

- -

-
-
-
" METHOD="POST"> - -"> -
-
-
-
- - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_top.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_top.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_top.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_top.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managefriends_top.tmpl Tue Oct 25 04:20:57 2005 @@ -1,68 +0,0 @@ - - - - -
- - -
- - -
-... -
-
- -
-
-
- -
- - - - - - - - - - - - - - - -
-
- - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managegroups_top.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managegroups_top.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managegroups_top.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managegroups_top.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_managegroups_top.tmpl Tue Oct 25 04:20:57 2005 @@ -1,59 +0,0 @@ - - - -
- -
- - -
-... -
-
- -
-
-
- -
- -
-
- -
- - - - - - - - - -
" METHOD="POST">" NAME="new_name">
   ">   ">   ">
-
-
- -
-
-
-

-
" title=""> -
- - - -
- -
- - - - - -
- - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu.tmpl Tue Oct 25 04:20:57 2005 @@ -1,52 +0,0 @@ - - - - - - - -
- - -
    -
  • -Advanced -
  • - - -
      -
    • -
    • -
    - -
      -
    • -
    • -
    • -
    - -
      -
    • -
    • -
    - - -
- -
    -
  • -
- - -
Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu_advanced.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu_advanced.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu_advanced.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu_advanced.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_menu_advanced.tmpl Tue Oct 25 04:20:57 2005 @@ -1,48 +0,0 @@ - - - - - - - -
- - -
    -
  • -Advanced -
  • -
      -
    • -
    • -
    - -
      -
    • -
    • -
    • -
    - -
      -
    • -
    • -
    -
- -
    -
  • -
- - -
Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage.tmpl Tue Oct 25 04:20:57 2005 @@ -1,58 +0,0 @@ - - - - - - -
- - -
- - -
Message Box -
-
- - -
- -
- -
-
- - - - - - - - -
:    -
:    -
- -
-
- - -
" METHOD="POST"> -"> -
- -
- -
- - - - - -
- - - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage_list.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage_list.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage_list.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage_list.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_showmessage_list.tmpl Tue Oct 25 04:20:57 2005 @@ -1,91 +0,0 @@ - - - -
- - -
- -
-
- -
- -
-
- -
- - -
-... -
-
- -
-
-
- - -
- -
- - -
-">
- -
- -
- - - - - - - - - - - - - - - - - - - - - - - - - - -
- - - "> - - -
-
- -
- -
-
- - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_top.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_top.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_top.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_top.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_top.tmpl Tue Oct 25 04:20:57 2005 @@ -1,109 +0,0 @@ - - - - - -
- - -
- - -
Owner Page: -... -
-
- -
-
-
- -
- -
-
's Stuff
- - - -
-
- -
-
-

-
-
- -">"> - -
-
- - -
-
- -
-
-
- - -
-
-
- - -
-
- - -
-
-
-Example: http://home1.affelio.jp/user/slash/ -
- -
-
- -
- -
- -
- - - - - -
-
- - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_uploadimage.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_uploadimage.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_uploadimage.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_uploadimage.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/admin_uploadimage.tmpl Tue Oct 25 04:20:57 2005 @@ -1,54 +0,0 @@ - - - - -
- -
- - -
-... -
-
- -
-
-
- -
- -
-
-
-
- -
- -
-
- -

- -

-"> - -
- -
-
- - - - - - - - -
- - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_footer.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_footer.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_footer.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_footer.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_footer.tmpl Tue Oct 25 04:20:57 2005 @@ -1,24 +0,0 @@ -
- - - - - - - - - - - - -
- - - - - - - - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_header.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_header.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_header.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_header.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/app_frame_header.tmpl Tue Oct 25 04:20:57 2005 @@ -1,23 +0,0 @@ - - - -Affelio: <TMPL_VAR ESCAPE="HTML" NAME="siteowner_nickname">: <TMPL_VAR ESCAPE="HTML" NAME="app_page_title"> -/style.css" media="screen"> -" media="screen"> - - - - - - - - - -
- - - - - - -
Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/error.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/error.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/error.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/error.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/error.tmpl Tue Oct 25 04:20:57 2005 @@ -1,33 +0,0 @@ - - -Affelio -/owner_side/style.css" media="screen"> - - - - - - - - - -
-
-
- -
-
-
- -

-: -

-

-
- -
-
-
- - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/footer.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/footer.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/footer.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/footer.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/footer.tmpl Tue Oct 25 04:20:57 2005 @@ -1,4 +0,0 @@ -
-">Affelio by Affelio Project
-Copyright (C) 2004-2005 Fish Grove. All Rights Reserved. -
Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/handshake_sent.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/handshake_sent.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/handshake_sent.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/handshake_sent.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/handshake_sent.tmpl Tue Oct 25 04:20:57 2005 @@ -1,45 +0,0 @@ - - -Affelio -/owner_side/style.css" media="screen"> - - - - - - - - - -
-
-
- -
- -
-
- -

- - -

-
- -

-:
" target="_blank"> - -
-
-
-
-"> -

-
- -
-
-
- - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/login.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/login.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/login.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/login.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/login.tmpl Tue Oct 25 04:20:57 2005 @@ -1,35 +0,0 @@ - - - - - - -
- - -
- -
-
-
- -
- -
- -

-

-
- - - -
-Username:
Password:
-"> -"> -
-
-
-
- -
\ No newline at end of file Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/loginfailed.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/loginfailed.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/loginfailed.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/loginfailed.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/loginfailed.tmpl Tue Oct 25 04:20:57 2005 @@ -1,33 +0,0 @@ - - -Affelio -/owner_side/style.css" media="screen"> -"> - - - - - - - - - -
- -
- -
- -
-
-
- -
-
-
- -
-
- - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/mail_ack_recved.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/mail_ack_recved.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/mail_ack_recved.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/mail_ack_recved.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/mail_ack_recved.tmpl Tue Oct 25 04:20:57 2005 @@ -1,41 +0,0 @@ - - -Affelio -/owner_side/style.css" media="screen"> - - - - - - - - - - -
-
-
- - -
-
-
- -
-
- - -
-
-
- - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/outgoing_warn.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/outgoing_warn.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/outgoing_warn.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/outgoing_warn.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/outgoing_warn.tmpl Tue Oct 25 04:20:57 2005 @@ -1,33 +0,0 @@ - - -Affelio: Warning -/style.css" media="screen"> -"> - - - - - - - - - -
- -
- -
- -
-
-
- -
-
-
- -
-
- - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_0.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_0.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_0.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_0.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_0.tmpl Tue Oct 25 04:20:57 2005 @@ -1,54 +0,0 @@ - - -Affelio: Setup wizard -/style.css" media="screen"> - - - - - - - - - - -
- -
Affelio Setup Wizard
- - - - - -
-/images/" width=200> - -
" method="POST"> - -

Welcome to the Affelio Setup Wizard!

- -

-

-Choose your language! -

- - - -

- -
- - - -
- -
- -
- - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_1.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_1.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_1.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_1.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/setup_1.tmpl Tue Oct 25 04:20:57 2005 @@ -1,107 +0,0 @@ - - -Affelio: Setup wizard -/style.css" media="screen"> - - - - - - - - - - - - - -
- -
- - - - - -
-/images/" width=200> - -
" method="POST"> - -

- - -

-

- -
-
- -

-

- -
- -
- - -"> - -"> - - -"> -
- -
- -
- - - - Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/showmore.js diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/showmore.js:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/showmore.js:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/showmore.js:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/showmore.js Tue Oct 25 04:20:57 2005 @@ -1,23 +0,0 @@ - - - - - - -if(document.getElementById){ - document.writeln(''); -} - -function showHide(id){ - var disp = document.getElementById(id).style.display; - if(disp == "block"){ - document.getElementById(id).style.display = "none"; - }else{ - document.getElementById(id).style.display = "block"; - } - return false; -} Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/style.css diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/style.css:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/style.css:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/style.css:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/style.css Tue Oct 25 04:20:57 2005 @@ -1,538 +0,0 @@ -/* Affelio: Open social networking software */ -/* Copyright 2004-2005 Fish Grove */ -/* For more information, please refer following web site. */ -/* http://affelio.jp/ (Japan) */ -/* http://affelio.jp/ (USA and other area) */ - -body { -margin: 0px 0px 20px 0px; -text-align: center; -} - -a { -text-decoration: underline; -} - -a:link { -color: #8FABBE; -} -a:visited { -color: #8FABBE; -} -a:active { -color: #8FABBE; -} -a:hover { -color: #006699; -} - -h1, h2, h3 { -margin: 0px; -padding: 0px; -font-weight: normal; -} - -.afPriButton{ - font-weight: bold; - background: #ccc; - border: #aaa solid 1px; - float:left; - padding: 5px; - margin: 0px 10px 10px 0px; -} -.afPriButton a{ - font-weight: bold; - text-size: medium; - color: #000; -} -.afPriButton a:link { - text-size: medium; - color: #000; -} -.afPriButton a:visited { - text-size: medium; - color: #000; -} -.afPriButton a:active { - text-size: medium; - color: #8FABBE; -} -.afPriButton a:hover { - text-size: medium; - color: #006699; -} - -/**************************************************************************/ -/* div ID container */ -/**************************************************************************/ -div#container { - margin-right: auto; - margin-left: auto; - text-align: left; - padding: 0px; - width: 800px; - height: auto; - background-color: #FFFFFF; - border: 1px solid #FFFFFF; -} - -/*****************************************/ -/* Banner */ -/*****************************************/ -.afBanner { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - height: 72px; - background-color: #3A99F9; - background:transparent url("./images/toplogo/affelio_top5.gif") left top; - border-bottom: 2px solid #FFFFFF; - text-align: right; -} -.afBanner iframe{ - align: right; -} - - -/**************************************************************************/ -/* infomation_box */ -/**************************************************************************/ -.box_a -{background:transparent url("images/box/a.png") repeat-x left top; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_b -{background:transparent url("images/box/b.png") repeat-y right top; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_c -{background:transparent url("images/box/c.png") repeat-x left bottom; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_d -{background:transparent url("images/box/d.png") repeat-y left top; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_e -{background:transparent url("images/box/e.png") no-repeat left bottom; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_f -{background:transparent url("images/box/f.png") no-repeat right bottom; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_g -{background:transparent url("images/box/g.png") no-repeat left top; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_h -{background:transparent url("images/box/h.png") no-repeat right top; -padding: 0px 0px 0px 0px; margin: 0px 0px 0px 0px;} -.box_main_outer { - background: transparent; - margin: 0px 0px 0px 0px; - padding: 15px 15px 15px 15px; -} -.box_main_inner { - background: #D1F2EF; -} -.box_text{ - font-family: Verdana, Arial, sans-serif; - font-size: small; - line-height: 120%; - text-align: left; -} - -/**************************************************************************/ -/* div ID afMenu */ -/**************************************************************************/ -div#afMenu { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - width:150px; - height: auto; - float: left; - border-right: 1px solid #aaa; - background-color: #fff; - font-family: Verdana, Arial, sans-serif; -} - -div#afMenuLogin { - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - color: balck; -} - -div#afMenu a:link{ - text-decoration: none; - color: #333; -} -div#afMenu a:visited{ - text-decoration: none; - color: #333; -} -div#afMenu a:hover{ - text-decoration: none; - color: black; -} - -/**************************************************************************/ -/* div ID afMain */ -/**************************************************************************/ -div#afMain { - margin: 0px 0px 0px 0px; - padding: 10px 10px 10px 10px; - width: 620px; - height: auto; - float: left; - font-family: Verdana, Arial, sans-serif; -} - -.afContent { - margin: 0px 0px 0px 0px; - padding: 10px 10px 10px 10px; - width: 600px; - height: auto; - float: left; - font-family: Verdana, Arial, sans-serif; -} - -.afMain { - margin: 0px 0px 0px 0px; - padding: 10px 10px 10px 10px; - width: 800px; - height: auto; - float: left; - font-family: Verdana, Arial, sans-serif; -} - -.afMain_friend{ - width:100%; - filter:Shadow(color=Silver, direction=45); -} - -.afMain h2 { - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: large; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 5px;*/ -} - -/**************************************************************************/ -/* div ID afAd */ -/**************************************************************************/ -div#afAd { - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - float: right; - height: auto; - border: 3px solid #FBC903; - background-color:#FFFFFF; -} - - -/**************************************************************************/ -/* div ID afFooter */ -/**************************************************************************/ - -div#afFooter { - width: 800px; - background-color: #cccccc; - text-align: center; - font-family: Verdana, Arial, sans-serif; - font-size: xx-small; - line-height: 170% -} - -div#afFooter a { - color: #000000; - clear:both; - text-decoration: none; -} - -/**************************************************************************/ -/*Setup wizard */ -/**************************************************************************/ - -.afSetupWizardWindow { - width: 650px; - margin: 50px 0px 0px 0px; - padding: 5px 5px 5px 5px; - background-color: #fff; - border: 3px solid #676161; - color: #555; - font-family: Verdana, Arial, sans-serif; - font-size: small; - font-weight: normal; -} - -.afSetupWizardWindow h2{ - color: #555; - font-family: Verdana, Arial, sans-serif; - font-size: normal; - font-weight: bold; -} - -.afSetupWizardWindow_content{ - color: #555; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; -} - -/**************************************************************************/ -/* classes */ -/**************************************************************************/ -.my_intro{ - padding: 0px 0px 0px 0px; - border: 0px; - font-family: Verdana, Arial, sans-serif; - font-size: small; - line-height: 140%; - text-align: left; -} -.my_intro h2{ - font-size: large; - font-weight: bold; -} - -.friends_list{ - margin: 5px 0px 5px 0px; - border-top: 2px dotted; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - line-height: 140%; - text-align: left; -} - -.friend_intro{ - font-size: x-small; -} - -.friend{ - margin: 5px 5px 5px 5px; - font-family: Verdana, Arial, sans-serif; - font-size: small; - line-height: 100%; - text-align: left; - float: left; -} - - - -/**************************************************************************/ -.information{ - margin: 0px 0px 0px 0px; - padding: 5px 5px 5px 5px; - background-color: #E1F0FF; - border: 2px solid #027BF4; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 140%; - text-align: left; -} - -.information2{ - margin: 0px 0px 0px 0px; - padding: 0px 0px 0px 0px; - background-color: #E1F0FF; - border: 0px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 140%; - text-align: left; -} - -.afPriError{ - margin: 0px 0px 10px 0px; - padding: 5px 5px 5px 5px; - background-color: #FFE0E0; - border: 2px solid red; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 140%; -} - -.afPriMesg{ - margin: 0px 0px 10px 0px; - padding: 5px 5px 5px 5px; - background-color: #E1F0FF; - border: 2px solid blue; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 140%; -} - -.notice{ - margin: 0px 0px 0px 0px; - padding: 5px 5px 5px 5px; - background-color: #FFE0E0; - border: 2px solid red; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - line-height: 140%; -} - -/**************************************************************************/ -.content { - padding: 20px 5px 5px 5px; - background-color: #FFF; - border: 0px solid #027BF4; - background: white; -} - -.content h2 { - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: large; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 5px;*/ -} - -.content h3 { - color: #666666; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - /*margin-bottom: 5px;*/ -} - -/**************************************************************************/ -.main_title{ - color: #FFFFFF; - font-family: Verdana, Arial, sans-serif; - font-size: medium; - text-align: left; - font-weight: bold; - line-height: 100%; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background:transparent url("./images/titlebar-back.png") repeat-x left top; - background-color: #eee; -} -.main_title a{ color: #FFFFFF; } -.main_title a:link{ color: #FFFFFF; } -.main_title a:visited{ color: #FFFFFF; } -.main_title a:active{ color: #FFFFFF; } -.main_title a:hover{ color: #cccccc; } - -/**************************************************************************/ - -.content_block { - color: black; - margin: 10px 0px 10px 0px; - padding: 5px 5px 5px 5px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - line-height: 130%; - text-align: left; - background: none; - background-color: #eee; -} - -.content_block th{ - width: 100px; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - text-align: left; - background-color: #CCC; -} - -.content_block td{ - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - font-weight: normal; - text-align: left; -} - -/********************************************************************/ -.content_block.table1 { - width: 570px; - overflow-x: scroll; -} -.content_block.table1 table{ - height: 200px; - width: 700px; -} -.content_block.table1 th{ - font-weight: bold; - text-align: center; - background-color: #ccc; -} -.content_block.table1 td{ - text-align: center; -} -/********************************************************************/ -.content_block.table2{ - text-align: center; -} -.content_block.table2 table{ - width: 90%; -} -.content_block.table2 th{ - width: 50%; - text-align: center; - font-weight: bold; -} -/********************************************************************/ -.table3 { - width: 570px; - overflow: auto; -} -.table3 table{ - width: 1000px; -} -.table3 th{ - font-weight: bold; - text-align: center; - background-color: #ccc; -} -.table3 td{ - text-align: center; -} - -/********************************************************************/ -.content_block.table4 { - width: 570px; - overflow-x: scroll; -} -.content_block.table4 table{ - width: 570px; -} -.content_block.table4 th{ - font-weight: bold; - text-align: center; - background-color: #ccc; -} -.content_block.table4 td{ - text-align: center; -} - -/**************************************************************************/ - -.blocktitle{ - color: #FFF; - font-family: Verdana, Arial, sans-serif; - font-size: x-small; - text-align: left; - font-weight: bold; - line-height: 100%; - padding: 5px 5px 5px 5px; - margin: 0px 0px 0px 0px; - background-color: #7297CE; -} -.blocktitle a{ color: #FFFFFF; } -.blocktitle a:link{ color: #FFFFFF; } -.blocktitle a:visited{ color: #FFFFFF; } -.blocktitle a:active{ color: #FFFFFF; } -.blocktitle a:hover{ color: #cccccc; } - -/**************************************************************************/ -table.admin { - width : 600px; -} - -.left_text { - text-align: left; -} Index: affelio_farm/admin/skelton/affelio/templates/default/owner_side/top_banner.tmpl diff -u affelio_farm/admin/skelton/affelio/templates/default/owner_side/top_banner.tmpl:1.1.1.1 affelio_farm/admin/skelton/affelio/templates/default/owner_side/top_banner.tmpl:removed --- affelio_farm/admin/skelton/affelio/templates/default/owner_side/top_banner.tmpl:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/templates/default/owner_side/top_banner.tmpl Tue Oct 25 04:20:57 2005 @@ -1,14 +0,0 @@ - - - - - - - - - - -
- -
- From slash5234 @ users.sourceforge.jp Tue Oct 25 12:42:37 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Tue, 25 Oct 2005 12:42:37 +0900 Subject: [Affelio-cvs 705] CVS update: affelio_farm/admin/config Message-ID: <20051025034237.8DE542AC01D@users.sourceforge.jp> Index: affelio_farm/admin/config/AffelioFarm.cfg diff -u affelio_farm/admin/config/AffelioFarm.cfg:1.1.1.1 affelio_farm/admin/config/AffelioFarm.cfg:removed --- affelio_farm/admin/config/AffelioFarm.cfg:1.1.1.1 Tue Oct 25 04:14:41 2005 +++ affelio_farm/admin/config/AffelioFarm.cfg Tue Oct 25 12:42:37 2005 @@ -1,37 +0,0 @@ -[af_func_ctrl] -AF_CTRL_can_invite_others=no -AF_CTRL_can_upload_skin=no - -[af_inst_def] -db_type=sqlite -farm_connecter=SimpleFileConnecter:/my_affelio_jp/htdocs/hosting/admin/config/AffelioFarm.cfg -sendmail_path=/usr/sbin/sendmail - -[farming] -farm_name=篆堺??≪??с??????-farm_owner=篆堺??у?????吾???? -farm_owner_url=http://oresama/ -farm_support_url=http://oresama.jp/ -invitation_limit_per_day=100 -register_without_invitation=yes -registration_limit_without_invitation_per_day=100 -use_invite_token_system=yes -user_can_invite=yes - -[site] -data_storage_root=/my_affelio_jp/htdocs/hosting/admin/data/ -farm_fs_root=/my_affelio_jp/htdocs/ -farm_web_root=http://my.affelio.jp/ -locale=ja -script_fs_root=/my_affelio_jp/htdocs/hosting/ -script_web_root=http://my.affelio.jp/hosting/ -template=default - -[system] -admin_email=slash @ affelio.jp -email_at_account_creation=yes -email_at_limit_reached=yes -email_sender_to_admin=from @ affelio.jp -email_sender_to_user=from @ affelio.jp -nkf_path=/usr/bin/nkf -sendmail_path=/usr/sbin/sendmail Index: affelio_farm/admin/config/AffelioFarm.cfg-dist diff -u /dev/null affelio_farm/admin/config/AffelioFarm.cfg-dist:1.1 --- /dev/null Tue Oct 25 12:42:37 2005 +++ affelio_farm/admin/config/AffelioFarm.cfg-dist Tue Oct 25 12:42:37 2005 @@ -0,0 +1,38 @@ +[site] +data_storage_root=/home/htdocs/affelio_farm/admin/data/ +farm_fs_root=/home/htdocs/ +farm_web_root=http://farm.your.affelio.site.com/ +locale=ja +script_fs_root=/home/htdocs/affelio_farm/ +script_web_root=http://farm.your.affelio.site.com/affelio_farm/ +template=default + +[system] +admin_email=admin @ your.affelio.site.com +email_at_account_creation=yes +email_at_limit_reached=yes +email_sender_to_admin=from @ your.affelio.site.com +email_sender_to_user=from @ your.affelio.site.com +nkf_path=/usr/bin/nkf +sendmail_path=/usr/sbin/sendmail + +[af_func_ctrl] +AF_CTRL_can_invite_others=no +AF_CTRL_can_upload_skin=no + +[af_inst_def] +db_type=sqlite +farm_connecter=SimpleFileConnecter:/home/htdocs/affelio_farm/admin/config/AffelioFarm.cfg +sendmail_path=/usr/sbin/sendmail + +[farming] +farm_name=篆堺??≪??с??????+farm_owner=篆堺??у?????吾???? +farm_owner_url=http://www.your.affelio.site.com/ +farm_support_url=http://support.your.affelio.site.com/ +invitation_limit_per_day=100 +register_without_invitation=yes +registration_limit_without_invitation_per_day=100 +use_invite_token_system=yes +user_can_invite=yes + From slash5234 @ users.sourceforge.jp Thu Oct 27 19:26:37 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 19:26:37 +0900 Subject: [Affelio-cvs 706] CVS update: affelio/lib Message-ID: <20051027102637.448572AC054@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.22 affelio/lib/Affelio.pm:1.23 --- affelio/lib/Affelio.pm:1.22 Tue Oct 25 03:41:21 2005 +++ affelio/lib/Affelio.pm Thu Oct 27 19:26:37 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.22 2005/10/24 18:41:21 slash5234 Exp $ +# $Id: Affelio.pm,v 1.23 2005/10/27 10:26:37 slash5234 Exp $ package Affelio; { @@ -36,6 +36,7 @@ use Affelio::misc::Debug; use Affelio::misc::L10N; use Affelio::misc::WebInput; + use Affelio::misc::Util; use Affelio::exception::TaintedInputException; use Affelio::exception::DBException; use Affelio::exception::SystemException; @@ -521,22 +522,13 @@ $self->{cmd__sendmail} = $Config->{command}->{sendmail}; #Determine userdata/..../ directory - my $dir; - eval{ - opendir(DIR, "$self->{top_dir}/userdata"); - while (defined($dir = readdir(DIR))) { - if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS') - && ($dir ne 'index.html')){ - $self->{site__user_dir} = - $wi->PTN_dirname("$self->{top_dir}/userdata/$dir"); - } - } + try{ + $self->{site__user_dir} = + get_userdir("$self->{top_dir}/userdata"); + }catch Error with{ + my $e = shift; + throw ($e); }; - if($@){ - throw Affelio::exception::SystemException("cannot open userdata directory."); - } - closedir(DIR); #Load username and password my $Config2 = Config::Tiny->new(); Index: affelio/lib/AffelioApp.pm diff -u affelio/lib/AffelioApp.pm:1.12 affelio/lib/AffelioApp.pm:1.13 --- affelio/lib/AffelioApp.pm:1.12 Mon Oct 24 17:52:49 2005 +++ affelio/lib/AffelioApp.pm Thu Oct 27 19:26:37 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: AffelioApp.pm,v 1.12 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: AffelioApp.pm,v 1.13 2005/10/27 10:26:37 slash5234 Exp $ package AffelioApp; { @@ -184,7 +184,6 @@ return($self->{userdata_dbh}); } - ###################################################################### #check_access ###################################################################### From slash5234 @ users.sourceforge.jp Thu Oct 27 19:26:37 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 19:26:37 +0900 Subject: [Affelio-cvs 707] CVS update: affelio/lib/Affelio/misc Message-ID: <20051027102637.635FB2AC055@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.7 affelio/lib/Affelio/misc/InitAffelio.pm:1.8 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.7 Tue Oct 25 01:50:09 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Thu Oct 27 19:26:37 2005 @@ -14,14 +14,14 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.7 2005/10/24 16:50:09 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.8 2005/10/27 10:26:37 slash5234 Exp $ package Affelio::misc::InitAffelio; { use strict; use Exporter; @Affelio::misc::InitAffelio::ISA = "Exporter"; - @Affelio::misc::InitAffelio::EXPORT = qw (create_userdir get_userdir create_af_cfg create_db_cfg create_login_cfg copy_def_files init_db set_datadir_perm setup_affelio); + @Affelio::misc::InitAffelio::EXPORT = qw (create_userdir create_af_cfg create_db_cfg create_login_cfg copy_def_files init_db set_datadir_perm setup_affelio); use lib("../../../extlib/"); use Cwd; @@ -33,6 +33,7 @@ use Affelio::misc::CGIError; use Affelio::misc::Debug; use Affelio::misc::MyCrypt; + use Affelio::misc::Util qw(get_userdir); use Affelio::App::Admin::EditTemplates; use Affelio::exception::Exception; use Affelio::exception::DBException; @@ -51,29 +52,6 @@ } ##################################################################### - sub get_userdir{ - my $userdata_dir = shift; - - my $dir; - my $ret; - try{ - opendir(DIR, $userdata_dir); - - while (defined($dir = readdir(DIR))) { - if(($dir ne '.') && ($dir ne '..') - && ($dir ne 'default') && ($dir ne 'CVS') - && ($dir ne 'index.html')){ - $ret = "$userdata_dir/$dir"; - } - } - }catch Error with{ - my $e=shift; - throw($e); - }; - return($ret); - } - - ##################################################################### sub create_af_cfg{ my $affelio_cfg_path = shift; my $fs_root = shift; From slash5234 @ users.sourceforge.jp Thu Oct 27 19:27:05 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 19:27:05 +0900 Subject: [Affelio-cvs 708] CVS update: affelio/lib/Affelio/misc Message-ID: <20051027102705.95B982AC054@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/Util.pm diff -u /dev/null affelio/lib/Affelio/misc/Util.pm:1.1 --- /dev/null Thu Oct 27 19:27:05 2005 +++ affelio/lib/Affelio/misc/Util.pm Thu Oct 27 19:27:05 2005 @@ -0,0 +1,67 @@ +# Copyright (C) 2005 FishGrove Inc. +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# 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. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# $Id: Util.pm,v 1.1 2005/10/27 10:27:05 slash5234 Exp $ + +package Affelio::misc::Util; +{ + use strict; + use Exporter; + @Affelio::misc::Util::ISA = "Exporter"; + @Affelio::misc::Util::EXPORT = qw (get_userdir); + + use lib("../../../extlib/"); + use Cwd; + use Error qw(:try); + use lib("."); + use lib("../../../lib/"); + use Affelio::exception::SystemException; + + ##################################################################### + sub get_userdir{ + my $userdata_dir = shift; + + my $dir; + my $ret=""; + try{ + opendir(DIR, $userdata_dir); + + while (defined($dir = readdir(DIR))) { + if( ($dir ne '.') + && ($dir ne '..') + && ($dir ne 'default') + && ($dir ne 'CVS') + && ($dir ne 'index.html') + && ($dir ne '.htaccess') + ){ + $ret = "$userdata_dir/$dir"; + } + } + }catch Error with{ + my $e=shift; + throw($e); + }; + + if($ret eq ""){ + throw Affelio::exception::SystemException("userdata/* directory not found!"); + }else{ + return($ret); + } + + } + +} +1; From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:00 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:00 +0900 Subject: [Affelio-cvs 709] CVS update: affelio Message-ID: <20051027111500.F2B9B2AC012@users.sourceforge.jp> Index: affelio/incoming.cgi diff -u affelio/incoming.cgi:1.8 affelio/incoming.cgi:1.9 --- affelio/incoming.cgi:1.8 Mon Oct 24 17:52:49 2005 +++ affelio/incoming.cgi Thu Oct 27 20:15:00 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: incoming.cgi,v 1.8 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: incoming.cgi,v 1.9 2005/10/27 11:15:00 slash5234 Exp $ use strict; @@ -74,7 +74,7 @@ ############################################################################ my $passAB; try{ - $passAB = $af->{fm}->get_attribute_by_afid($referrer, "password"); + $passAB = $af->getFM->get_attribute_by_afid($referrer, "password"); }catch Error with{ my $e = shift; error($q, "Error from FriendManager.\n" . $e); @@ -180,7 +180,7 @@ #lookup our friend table with FID_visitorAFID my $tmp1; try{ - $tmp1 = $af->{fm}->get_attribute_by_afid($FID_visitorAFID, "password"); + $tmp1 = $af->getFM->get_attribute_by_afid($FID_visitorAFID, "password"); }catch Error with{ my $e = shift; error($q, "Error from FriendManager.\n" . $e); Index: affelio/index.cgi diff -u affelio/index.cgi:1.14 affelio/index.cgi:1.15 --- affelio/index.cgi:1.14 Mon Oct 24 17:52:49 2005 +++ affelio/index.cgi Thu Oct 27 20:15:00 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: index.cgi,v 1.14 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: index.cgi,v 1.15 2005/10/27 11:15:00 slash5234 Exp $ use strict; @@ -213,8 +213,8 @@ $output_data{"friendlist_all_IF"} = \@friendlist_all_IF; try{ - $output_data{"friend__F1count"} = $af->{fm}->get_F1_count(); - $output_data{"friend__F2count"} = $af->{fm}->get_F2_count(); + $output_data{"friend__F1count"} = $af->getFM->get_F1_count(); + $output_data{"friend__F2count"} = $af->getFM->get_F2_count(); }catch Error with{ my $e = shift; error($q, "Affelio: error from FriendManager\n" . $e); @@ -249,7 +249,7 @@ } try{ - $af->{alm}->save_log($afid, $visitor_nickname, $visitor_type); + $af->getALM->save_log($afid, $visitor_nickname, $visitor_type); }catch Error with{ my $e = shift; error($q, "Affelio: error in AccessLogging\n" . $e); Index: affelio/outgoing.cgi diff -u affelio/outgoing.cgi:1.7 affelio/outgoing.cgi:1.8 --- affelio/outgoing.cgi:1.7 Mon Oct 24 17:52:49 2005 +++ affelio/outgoing.cgi Thu Oct 27 20:15:00 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: outgoing.cgi,v 1.7 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: outgoing.cgi,v 1.8 2005/10/27 11:15:00 slash5234 Exp $ use strict; @@ -95,7 +95,7 @@ # retrieve passAB my $passAB=""; try{ - $passAB = $af->{fm}->get_attribute_by_afid($dest_URL, "password"); + $passAB = $af->getFM->get_attribute_by_afid($dest_URL, "password"); }catch Error with{ my $e = shift; error($q, "Error from FriendManager.\n" . $e); From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:01 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:01 +0900 Subject: [Affelio-cvs 710] CVS update: affelio/bin Message-ID: <20051027111501.1FB902AC025@users.sourceforge.jp> Index: affelio/bin/get_content.cgi diff -u affelio/bin/get_content.cgi:1.22 affelio/bin/get_content.cgi:1.23 --- affelio/bin/get_content.cgi:1.22 Mon Oct 24 17:52:49 2005 +++ affelio/bin/get_content.cgi Thu Oct 27 20:15:01 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: get_content.cgi,v 1.22 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: get_content.cgi,v 1.23 2005/10/27 11:15:01 slash5234 Exp $ use strict; @@ -126,7 +126,7 @@ my $referrer = $wi->PTN_URL($q->param("referrer")); debug_print("get_content: referrer = $referrer\n"); #referrer URL - my $passAB = $af->{fm}->get_attribute_by_afid($referrer, "password"); + my $passAB = $af->getFM->get_attribute_by_afid($referrer, "password"); if($passAB eq "" || !defined($passAB)){ error($q,"Parameters are not defined. (1): Your peer does not have shared password with you..."); } @@ -197,7 +197,7 @@ #Is this visitor a friend of this site? if($visitor_type < 3){ - my $tmp1 = $af->{fm}->get_attribute_by_afid($visitor_afid, "password"); + my $tmp1 = $af->getFM->get_attribute_by_afid($visitor_afid, "password"); if($tmp1 ne ""){ $visitor_type = 2; Index: affelio/bin/recv_mail_ack.cgi diff -u affelio/bin/recv_mail_ack.cgi:1.8 affelio/bin/recv_mail_ack.cgi:1.9 --- affelio/bin/recv_mail_ack.cgi:1.8 Mon Oct 24 17:52:49 2005 +++ affelio/bin/recv_mail_ack.cgi Thu Oct 27 20:15:01 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: recv_mail_ack.cgi,v 1.8 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: recv_mail_ack.cgi,v 1.9 2005/10/27 11:15:01 slash5234 Exp $ use strict; use lib("../extlib"); @@ -162,7 +162,7 @@ ############################################################################ #Add peer to my friends list. try{ - $af->{fm}->add_friend($peer_af_id, + $af->getFM->add_friend($peer_af_id, $peer_nickname, $timestamp, $pass); From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:01 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:01 +0900 Subject: [Affelio-cvs 711] CVS update: affelio/lib Message-ID: <20051027111501.42A142AC012@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.23 affelio/lib/Affelio.pm:1.24 --- affelio/lib/Affelio.pm:1.23 Thu Oct 27 19:26:37 2005 +++ affelio/lib/Affelio.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.23 2005/10/27 10:26:37 slash5234 Exp $ +# $Id: Affelio.pm,v 1.24 2005/10/27 11:15:01 slash5234 Exp $ package Affelio; { @@ -139,33 +139,12 @@ $self->read_site_config(); $self->read_user_prefs(); - #Connect to DB - $self->openDB(); - #Load locale $self->load_Locale(); - #Load profile manager - $self->load_ProfileManager(); - - #Load friend manager - $self->load_FriendManager(); - - #Load group manager - $self->load_GroupManager(); - - #Load permission manager - $self->load_PermissionManager(); - - #Load permission manager - $self->load_MessageManager(); - - #Load permission manager - $self->load_AccessLogManager(); - - if($self->{mode} ne "init"){ - $self->load_ApplicationManager(); - } + #if($self->{mode} ne "init"){ + # $self->load_ApplicationManager(); + #} debug_print("Affelio::new: end."); return $self; @@ -193,6 +172,20 @@ $self->{guest_owner_switch} = "owner"; } + + ###################################################################### + #getDB + ###################################################################### + sub getDB{ + my $self=shift; + + if(! ($self->{db}) ){ + $self->openDB(); + } + return($self->{db}); + } + + ###################################################################### #openDB ###################################################################### @@ -308,6 +301,18 @@ } ###################################################################### + #getPM + ###################################################################### + sub getPM{ + my $self=shift; + + if(! ($self->{pm}) ){ + $self->load_ProfileManager(); + } + return($self->{pm}); + } + + ###################################################################### #load_ProfileManager ###################################################################### sub load_ProfileManager{ @@ -325,6 +330,18 @@ } ###################################################################### + #getFM + ###################################################################### + sub getFM{ + my $self=shift; + + if(! ($self->{fm}) ){ + $self->load_FriendManager(); + } + return($self->{fm}); + } + + ###################################################################### #load_FriendManager ###################################################################### sub load_FriendManager{ @@ -340,6 +357,18 @@ } ###################################################################### + #getGM + ###################################################################### + sub getGM{ + my $self=shift; + + if(! ($self->{gm}) ){ + $self->load_GroupManager(); + } + return($self->{gm}); + } + + ###################################################################### #load_GroupManager ###################################################################### sub load_GroupManager{ @@ -357,6 +386,18 @@ } ###################################################################### + #getPERM + ###################################################################### + sub getPERM{ + my $self=shift; + + if(! ($self->{perm}) ){ + $self->load_PermissionManager(); + } + return($self->{perm}); + } + + ###################################################################### #load_PermissionManager ###################################################################### sub load_PermissionManager{ @@ -373,6 +414,18 @@ } ###################################################################### + #getMESGM + ###################################################################### + sub getMESGM{ + my $self=shift; + + if(! ($self->{mesgm}) ){ + $self->load_MessageManager(); + } + return($self->{mesgm}); + } + + ###################################################################### #load_MessageManager ###################################################################### sub load_MessageManager{ @@ -390,6 +443,18 @@ } ###################################################################### + #getALM + ###################################################################### + sub getALM{ + my $self=shift; + + if(! ($self->{alm}) ){ + $self->load_AccessLogManager(); + } + return($self->{alm}); + } + + ###################################################################### #load_AccessLogManager ###################################################################### sub load_AccessLogManager{ @@ -407,6 +472,18 @@ } ###################################################################### + #getAM + ###################################################################### + sub getAM{ + my $self=shift; + + if(! ($self->{am}) ){ + $self->load_ApplicationManager(); + } + return($self->{am}); + } + + ###################################################################### #load_ApplicationManager ###################################################################### sub load_ApplicationManager{ @@ -444,7 +521,6 @@ ###################################################################### #get_farm_connecter{ - # ###################################################################### sub get_farm_connecter{ my $self = shift; @@ -639,9 +715,9 @@ my $owner_mode_url=""; if($self->{caller}){ $guest_mode_url - = $self->{am}->{apps}->{$self->{caller}}->{guest_index}; + = $self->getAM->{apps}->{$self->{caller}}->{guest_index}; $owner_mode_url - = $self->{am}->{apps}->{$self->{caller}}->{owner_index}; + = $self->getAM->{apps}->{$self->{caller}}->{owner_index}; }else{ $guest_mode_url= $self->{site__web_root} . "/index.cgi?mode=index"; $owner_mode_url= $self->{site__web_root} . "/admin.cgi"; @@ -721,17 +797,17 @@ ######################### my $tmp_name; my $this_app_ref; - while ( ($tmp_name, $this_app_ref) = each( %{$self->{am}->{apps}} ) ){ + while ( ($tmp_name, $this_app_ref) = each( %{$self->getAM->{apps}} ) ){ my %this_app = %$this_app_ref; debug_print("Affelio::get_module_list: $this_app{'install_name'}"); #Is this application permmited to be printed at the tab?? - $self->{am}->prepare_app_perm_table($this_app{'install_name'}); + $self->getAM->prepare_app_perm_table($this_app{'install_name'}); my $perm_to_tab=0; $perm_to_tab - = $self->{am}->get_summed_app_perm($visitor_afid, + = $self->getAM->get_summed_app_perm($visitor_afid, $visitor_type, $this_app{'install_name'}, "DF_visibility"); Index: affelio/lib/AffelioApp.pm diff -u affelio/lib/AffelioApp.pm:1.13 affelio/lib/AffelioApp.pm:1.14 --- affelio/lib/AffelioApp.pm:1.13 Thu Oct 27 19:26:37 2005 +++ affelio/lib/AffelioApp.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: AffelioApp.pm,v 1.13 2005/10/27 10:26:37 slash5234 Exp $ +# $Id: AffelioApp.pm,v 1.14 2005/10/27 11:15:01 slash5234 Exp $ package AffelioApp; { @@ -123,7 +123,7 @@ debug_print("AffelioApp::new: visitor_nickname= $visitor_nickname"); debug_print("AffelioApp::new: visitor_afid= $visitor_afid"); - my $install_title = $af->{am}->{apps}->{$install_name}->{install_title}; + my $install_title = $af->getAM->{apps}->{$install_name}->{install_title}; my $dbh = $af->openAppDB($install_name); @@ -194,7 +194,7 @@ my $ret=0; try{ $ret= - $self->{af}->{am}->get_summed_app_perm($self->{visitor_afid}, + $self->{af}->getAM->get_summed_app_perm($self->{visitor_afid}, $self->{visitor_type}, $self->{install_name}, $action_type); From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:01 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:01 +0900 Subject: [Affelio-cvs 712] CVS update: affelio/lib/Affelio/App Message-ID: <20051027111501.786F82AC025@users.sourceforge.jp> Index: affelio/lib/Affelio/App/FriendRoutines.pm diff -u affelio/lib/Affelio/App/FriendRoutines.pm:1.5 affelio/lib/Affelio/App/FriendRoutines.pm:1.6 --- affelio/lib/Affelio/App/FriendRoutines.pm:1.5 Sun Jul 3 07:46:12 2005 +++ affelio/lib/Affelio/App/FriendRoutines.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: FriendRoutines.pm,v 1.5 2005/07/02 22:46:12 slash5234 Exp $ +# $Id: FriendRoutines.pm,v 1.6 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::FriendRoutines; { @@ -50,7 +50,7 @@ # f2 or PB #################### - my $SQL_ret = $af->{perm}->get_permission("f", $visitor_mode); + my $SQL_ret = $af->getPERM->get_permission("f", $visitor_mode); @ret_list = $SQL_ret->fetchrow_array; # Now... # $ret_list[0] = Permission ID @@ -72,7 +72,7 @@ #################### #In case of "self" .... everything is 1. - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); my @row=(); while(@row = $attributes->fetchrow_array){ @@ -87,22 +87,22 @@ # perm(f1) OR Vx(perm(G)) #Get permssion for F1 - my $SQL_ret1 = $af->{perm}->get_permission("f", $visitor_mode); + my $SQL_ret1 = $af->getPERM->get_permission("f", $visitor_mode); @ret_list = $SQL_ret1->fetchrow_array; #Get the visitor's UID my ($t_uid, $t_afid, $t_nickname, $t_time, $t_pass, $t_intro, $t_pid, $t_lastupdated, $t_f2list) - = $af->{fm}->get_friend_by_afid($visitor_id); + = $af->getFM->get_friend_by_afid($visitor_id); #Get the visitor's groups - my $SQL_result = $af->{gm}->get_groups_by_uid($t_uid); + my $SQL_result = $af->getGM->get_groups_by_uid($t_uid); #For each group... my @g_data=(); while(@g_data = $SQL_result->fetchrow_array) { my $gid = $g_data[0]; - my $SQL_ret2 = $af->{perm}->get_permission("g", $gid); + my $SQL_ret2 = $af->getPERM->get_permission("g", $gid); my @list1 = $SQL_ret2->fetchrow_array; #For each value... @@ -154,7 +154,7 @@ ###################################### #Get all friends' table from FriendManager ###################################### - my $sth = $af->{fm}->get_all_friend_list(); + my $sth = $af->getFM->get_all_friend_list(); ###################################### #Build up a return array @@ -244,7 +244,7 @@ ###################################### #Get all friends' table from FriendManager ###################################### - my $sth = $af->{fm}->get_all_friend_list(); + my $sth = $af->getFM->get_all_friend_list(); ###################################### #Build up a return array Index: affelio/lib/Affelio/App/ShowProfile.pm diff -u affelio/lib/Affelio/App/ShowProfile.pm:1.3 affelio/lib/Affelio/App/ShowProfile.pm:1.4 --- affelio/lib/Affelio/App/ShowProfile.pm:1.3 Fri Jul 1 11:00:06 2005 +++ affelio/lib/Affelio/App/ShowProfile.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ShowProfile.pm,v 1.3 2005/07/01 02:00:06 slash5234 Exp $ +# $Id: ShowProfile.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::ShowProfile; { @@ -57,7 +57,7 @@ # $list[1] = perm for 1st element ...aid=1 # $list[2] = ... - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); my @row=(); while(@row = $attributes->fetchrow_array){ From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:01 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:01 +0900 Subject: [Affelio-cvs 713] CVS update: affelio/lib/Affelio/App/Admin Message-ID: <20051027111501.BA5632AC012@users.sourceforge.jp> Index: affelio/lib/Affelio/App/Admin/AccessControl.pm diff -u affelio/lib/Affelio/App/Admin/AccessControl.pm:1.3 affelio/lib/Affelio/App/Admin/AccessControl.pm:1.4 --- affelio/lib/Affelio/App/Admin/AccessControl.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/AccessControl.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: AccessControl.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: AccessControl.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::AccessControl; { @@ -60,7 +60,7 @@ debug_print("save_GroupAttribute_table: For group[$gid]..."); #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values my @g_perm=(); @@ -74,7 +74,7 @@ } $g_perm[0] = 1; debug_print("save_GroupAttribute_table: group_permission=[@g_perm]"); - $af->{perm}->update_permission($option_pid, \@g_perm); + $af->getPERM->update_permission($option_pid, \@g_perm); } #while }#part @@ -83,7 +83,7 @@ ####################################################### # Save registered groups { - my $groups_SQL = $af->{gm}->get_all_group_list(); + my $groups_SQL = $af->getGM->get_all_group_list(); #For each group returned... while( (my ($gid, $group_name, $members, $option_pid) @@ -93,7 +93,7 @@ if($gid <1){last;} #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values my @g_perm=(); @@ -107,7 +107,7 @@ } $g_perm[0] = 1; debug_print("save_GroupAttribute_table: group_permission=[@g_perm]"); - $af->{perm}->update_permission($option_pid, \@g_perm); + $af->getPERM->update_permission($option_pid, \@g_perm); }#while }#part @@ -117,10 +117,10 @@ { if($q->param("newg_group_name") ne ""){ - my $gid = $af->{gm}->add_group($q->param("newg_group_name")); + my $gid = $af->getGM->add_group($q->param("newg_group_name")); #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values my @g_perm=(); @@ -134,7 +134,7 @@ } $g_perm[1] = 1; debug_print("save_GroupAttribute_table: newg group=[@g_perm]"); - $af->{perm}->add_permission("g", $gid, \@g_perm); + $af->getPERM->add_permission("g", $gid, \@g_perm); } } @@ -173,11 +173,11 @@ $this_group_ret{"group_name"} = $group_name; #For each group, get the permission list. - my $g_perm_result = $af->{perm}->get_permission("f", "$gid"); + my $g_perm_result = $af->getPERM->get_permission("f", "$gid"); my @g_perm = $g_perm_result->fetchrow_array; debug_print("show_GroupAttribute_table: group_permission=[@g_perm]"); #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values while(my ($attr_id, $attr_name, $attr_type) @@ -207,7 +207,7 @@ ####################################################### # Registered Groups - my $groups_SQL = $af->{gm}->get_all_group_list(); + my $groups_SQL = $af->getGM->get_all_group_list(); #For each group returned... while( (my ($gid, $group_name, $members, $option_pid) @@ -222,11 +222,11 @@ $this_group_ret{"group_name"} = $group_name; #For each group, get the permission list. - my $g_perm_result = $af->{perm}->get_permission("g", "$gid"); + my $g_perm_result = $af->getPERM->get_permission("g", "$gid"); my @g_perm = $g_perm_result->fetchrow_array; debug_print("show_GroupAttribute_table: group_permission=[@g_perm]"); #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values while(my ($attr_id, $attr_name, $attr_type) Index: affelio/lib/Affelio/App/Admin/AccessLog.pm diff -u affelio/lib/Affelio/App/Admin/AccessLog.pm:1.9 affelio/lib/Affelio/App/Admin/AccessLog.pm:1.10 --- affelio/lib/Affelio/App/Admin/AccessLog.pm:1.9 Sun Jul 3 18:15:30 2005 +++ affelio/lib/Affelio/App/Admin/AccessLog.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: AccessLog.pm,v 1.9 2005/07/03 09:15:30 slash5234 Exp $ +# $Id: AccessLog.pm,v 1.10 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::AccessLog; { @@ -66,7 +66,7 @@ ############################### #Access to AccessLog Manager ############################### - my $result = $af->{alm}->get_log($start_time, $cur_time); + my $result = $af->getALM->get_log($start_time, $cur_time); ############################### #Parse result Index: affelio/lib/Affelio/App/Admin/Configuration.pm diff -u affelio/lib/Affelio/App/Admin/Configuration.pm:1.3 affelio/lib/Affelio/App/Admin/Configuration.pm:1.4 --- affelio/lib/Affelio/App/Admin/Configuration.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/Configuration.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Configuration.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: Configuration.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::Configuration; { @@ -104,7 +104,7 @@ ############### #Apps ############### - while (($install_name, $app) = each(%{$af->{am}->{apps}})){ + while (($install_name, $app) = each(%{$af->getAM->{apps}})){ if($af->{userpref__toppage_app_installname} eq $app->{install_name}){ Index: affelio/lib/Affelio/App/Admin/EditProfile.pm diff -u affelio/lib/Affelio/App/Admin/EditProfile.pm:1.3 affelio/lib/Affelio/App/Admin/EditProfile.pm:1.4 --- affelio/lib/Affelio/App/Admin/EditProfile.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/EditProfile.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: EditProfile.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: EditProfile.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::EditProfile; { @@ -132,7 +132,7 @@ #$err .= ... #Save Profile - $af->{pm}->save_profile(); + $af->getPM->save_profile(); return($err); } Index: affelio/lib/Affelio/App/Admin/FriendsGraph.pm diff -u affelio/lib/Affelio/App/Admin/FriendsGraph.pm:1.7 affelio/lib/Affelio/App/Admin/FriendsGraph.pm:1.8 --- affelio/lib/Affelio/App/Admin/FriendsGraph.pm:1.7 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/FriendsGraph.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: FriendsGraph.pm,v 1.7 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: FriendsGraph.pm,v 1.8 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::FriendsGraph; { @@ -42,7 +42,7 @@ my $af = shift; my @friends_list=(); - my $result = $af->{fm}->get_all_friend_list(); + my $result = $af->getFM->get_all_friend_list(); my %tmp_hash; while( my @row = $result->fetchrow_array ){ @@ -63,7 +63,7 @@ ################################################## #Save the F2 list into my DB - $af->{fm}->save_F2List($ret, $peer_af_id); + $af->getFM->save_F2List($ret, $peer_af_id); }catch Affelio::exception::IOException with{ @@ -85,7 +85,7 @@ my $ret=""; - my $f1_result= $af->{fm}->get_all_friend_list(); + my $f1_result= $af->getFM->get_all_friend_list(); my @person=(); while(@person = $f1_result->fetchrow_array) { # $person[0] uid @@ -100,13 +100,13 @@ if($f2_uid > 0){ #The other peer is also an F1 person. my $f2_nickname - = $af->{fm}->get_attribute_by_uid($f2_uid, + = $af->getFM->get_attribute_by_uid($f2_uid, "nickname"); $ret .= $person[2] . "-" . $f2_nickname . ","; }else{ #The other peer is an F2 person. my $f2_nickname - = $af->{fm}->F2_get_attribute_by_uid($f2_uid, + = $af->getFM->F2_get_attribute_by_uid($f2_uid, "nickname"); $ret .= $person[2] . "-" . $f2_nickname . ","; } Index: affelio/lib/Affelio/App/Admin/GroupMemberTable.pm diff -u affelio/lib/Affelio/App/Admin/GroupMemberTable.pm:1.3 affelio/lib/Affelio/App/Admin/GroupMemberTable.pm:1.4 --- affelio/lib/Affelio/App/Admin/GroupMemberTable.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/GroupMemberTable.pm Thu Oct 27 20:15:01 2005 @@ -1,5 +1,4 @@ # Copyright (C) 2005 FishGrove Inc. -# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -14,7 +13,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: GroupMemberTable.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: GroupMemberTable.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::GroupMemberTable; { @@ -58,7 +57,7 @@ } foreach my $gid (@gid_array){ - $af->{gm}->set_member_by_intarray($gid, \@{$gid_uid_table[$gid]}); + $af->getGM->set_member_by_intarray($gid, \@{$gid_uid_table[$gid]}); } } @@ -77,7 +76,7 @@ my @group_names=(); $output_ref->{'group_names'} = \@group_names; - my $groups_SQL = $af->{gm}->get_all_group_list(); + my $groups_SQL = $af->getGM->get_all_group_list(); while( (my ($gid, $group_name, $members, $option_pid, $lastupdated, $f2list) = $groups_SQL->fetchrow_array)){ push(@group_names, @@ -93,7 +92,7 @@ my @members=(); $output_ref->{'members'} = \@members; - my $SQL_result = $af->{fm}->get_all_friend_list(); + my $SQL_result = $af->getFM->get_all_friend_list(); my @person=(); while(@person = $SQL_result->fetchrow_array) { #For each friend.... @@ -112,7 +111,7 @@ } #Set "checked_flag" for each belonging group - my $SQL_result2 = $af->{gm}->get_groups_by_uid($person[0]); + my $SQL_result2 = $af->getGM->get_groups_by_uid($person[0]); while((my $tmp_gid, my @rest) = $SQL_result2->fetchrow_array) { $my_belonging_groups[$tmp_gid-1]{'checked_flag'} ="checked"; } Index: affelio/lib/Affelio/App/Admin/ManageApplication.pm diff -u affelio/lib/Affelio/App/Admin/ManageApplication.pm:1.3 affelio/lib/Affelio/App/Admin/ManageApplication.pm:1.4 --- affelio/lib/Affelio/App/Admin/ManageApplication.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/ManageApplication.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ManageApplication.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: ManageApplication.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::ManageApplication; { @@ -46,7 +46,7 @@ my @pids = split('[\s]+', $pid_list); my @type_array = - @{$af->{am}->{apps}->{$app_name}->{action_types}}; + @{$af->getAM->{apps}->{$app_name}->{action_types}}; unshift(@type_array, "DF_access"); unshift(@type_array, "DF_visibility"); @@ -63,7 +63,7 @@ } debug_print("ManageApp:save: [$pid]:[$type_array[$type_count]] = [$param_value]"); - $af->{am}->update_permission($app_name, + $af->getAM->update_permission($app_name, $pid, $type_array[$type_count], $param_value); @@ -84,7 +84,7 @@ $output_ref->{"install_name"} = $app_name; $output_ref->{"install_title"} - = $af->{am}->{apps}->{$app_name}->{install_title}; + = $af->getAM->{apps}->{$app_name}->{install_title}; ####################### #Headers @@ -96,7 +96,7 @@ push(@headers, {header => ''}); my $type_desc_array = - $af->{am}->{apps}->{$app_name}->{action_types_desc}; + $af->getAM->{apps}->{$app_name}->{action_types_desc}; my $count=0; foreach my $desc (@{$type_desc_array}){ @@ -113,10 +113,10 @@ $output_ref->{"groups"} = \@groups; #prepare application permission table - $af->{am}->prepare_app_perm_table($app_name); + $af->getAM->prepare_app_perm_table($app_name); #Retrieve table - my $result= $af->{am}->get_all_permission($app_name); + my $result= $af->getAM->get_all_permission($app_name); ################## #For each group... @@ -142,8 +142,8 @@ $af->{lh}->maketext("_VISITOR_TYPE_PB") . "
"; }elsif($type eq "g"){ my $query = "select group_name from AFuser_CORE_group where gid=$target_id"; - my $sth = $af->{db}->prepare($query) or die $af->{db}->errstr; - $sth->execute() or die $af->{db}->errstr; + my $sth = $af->getDB->prepare($query) or die $af->getDB->errstr; + $sth->execute() or die $af->getDB->errstr; my @tmp_array = $sth->fetchrow_array; $this_group{group_name} = $tmp_array[0]; } #if @@ -181,7 +181,7 @@ my $install_name; my $app; - while (($install_name, $app) = each(%{$af->{am}->{apps}})){ + while (($install_name, $app) = each(%{$af->getAM->{apps}})){ push(@applications, {install_title => $app->{install_title}, install_name => $app->{install_name}, Index: affelio/lib/Affelio/App/Admin/ManageFriend.pm diff -u affelio/lib/Affelio/App/Admin/ManageFriend.pm:1.4 affelio/lib/Affelio/App/Admin/ManageFriend.pm:1.5 --- affelio/lib/Affelio/App/Admin/ManageFriend.pm:1.4 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/ManageFriend.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ManageFriend.pm,v 1.4 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: ManageFriend.pm,v 1.5 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::ManageFriend; { @@ -47,7 +47,7 @@ my $value = $cgi->param($attr); debug_print("modify_member [$attr] is modified to [$value]"); - $af->{fm}->set_attribute_by_id($uid, $attr, $value); + $af->getFM->set_attribute_by_id($uid, $attr, $value); debug_print("modify_member uid[$uid] end."); } @@ -61,16 +61,16 @@ my $cgi = shift; #arg(3) cgi debug_print("remove_member uid[$uid] start."); - my $afid = $af->{fm}->get_attribute_by_uid($uid, "af_id"); + my $afid = $af->getFM->get_attribute_by_uid($uid, "af_id"); #Remove entry(uid) from AFuser_CORE_friends #Remove uid from friends of others in AFuser_CORE_friends #Remove entry(uid) from AFuser_CORE_friendsfriends #Remove uid from friends of others in AFuser_CORE_friendsfriends - $af->{fm}->remove_friend($uid); + $af->getFM->remove_friend($uid); #Remove uid from groups - $af->{gm}->remove_person_from_all($uid); + $af->getGM->remove_person_from_all($uid); #add uid to erasedfriends @@ -89,7 +89,7 @@ debug_print("show_member uid[$uid] start."); - my @person = $af->{fm}->get_friend_by_uid($uid); + my @person = $af->getFM->get_friend_by_uid($uid); # returns array(0uid, 1af_id, 2nickname, 3timestamp, # 4password, 5intro, 6option_pid, 7lastupdated, 8 f2list) debug_print("show_member [@person]"); @@ -114,13 +114,13 @@ ##################### #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); ##################### #F1 #Get permission list of "F1" - my $perm_result = $af->{perm}->get_permission("f", "f1"); + my $perm_result = $af->getPERM->get_permission("f", "f1"); my @perm_F1 = $perm_result->fetchrow_array; debug_print("show_member: perm_F1=[@perm_F1]"); @@ -152,7 +152,7 @@ #Group #Get group lists which the target friends belongs to - my $groups_SQL = $af->{gm}->get_groups_by_uid($person[0]); + my $groups_SQL = $af->getGM->get_groups_by_uid($person[0]); my @groups_ret=(); @@ -169,12 +169,12 @@ $this_group_ret{"group_name"} = $group_name; #For each group, get the permission list. - my $g_perm_result = $af->{perm}->get_permission("g", "$gid"); + my $g_perm_result = $af->getPERM->get_permission("g", "$gid"); my @g_perm = $g_perm_result->fetchrow_array; debug_print("show_member: group_permission=[@g_perm]"); #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values while(my ($attr_id, $attr_name, $attr_type) @@ -203,7 +203,7 @@ ################################################## #Groups that the user DOES NOT belong to - my $add_groups_SQL = $af->{gm}->get_unsubscribing_groups_by_uid($uid); + my $add_groups_SQL = $af->getGM->get_unsubscribing_groups_by_uid($uid); my @add_groups_ret=(); @@ -230,7 +230,7 @@ debug_print("subscribe_group: start. g[$gid] u[$uid]"); - $af->{gm}->add_member($gid, $uid); + $af->getGM->add_member($gid, $uid); debug_print("subscribe_group: end."); } @@ -245,7 +245,7 @@ debug_print("unsubscribe_group: start. g[$gid] u[$uid]"); - $af->{gm}->remove_member($gid, $uid); + $af->getGM->remove_member($gid, $uid); debug_print("unsubscribe_group: end."); } @@ -259,7 +259,7 @@ my $output_ref = shift; #arg(2) ref of %output_data; my @friends_list=(); - my $result = $af->{fm}->get_all_friend_list(); + my $result = $af->getFM->get_all_friend_list(); while( my @row = $result->fetchrow_array ){ Index: affelio/lib/Affelio/App/Admin/ManageGroup.pm diff -u affelio/lib/Affelio/App/Admin/ManageGroup.pm:1.3 affelio/lib/Affelio/App/Admin/ManageGroup.pm:1.4 --- affelio/lib/Affelio/App/Admin/ManageGroup.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/ManageGroup.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ManageGroup.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: ManageGroup.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::ManageGroup; { @@ -39,7 +39,7 @@ my $gid = shift; #arg(2) gid my $new_name = shift; #arg(3) new_name - $af->{gm}->rename_group($gid,$new_name); + $af->getGM->rename_group($gid,$new_name); } ##################################################################### @@ -56,10 +56,10 @@ debug_print("ManageGroup:add_group start.[$group_name]"); #Create a new group - my $gid = $af->{gm}->add_group($group_name); + my $gid = $af->getGM->add_group($group_name); #Get attribute table - my $attributes = $af->{pm}->get_attribute_table(); + my $attributes = $af->getPM->get_attribute_table(); #Set values my @g_perm=(); while(my ($attr_id, $attr_name, $attr_type) @@ -69,7 +69,7 @@ $g_perm[1] = 0; debug_print("ManageGroup:add_group newg group=[@g_perm]"); - $af->{perm}->add_permission("g", $gid, \@g_perm); + $af->getPM->add_permission("g", $gid, \@g_perm); } ##################################################################### @@ -80,7 +80,7 @@ my $gid = shift; #arg(2) gid my $q = shift; #arg(3) CGI - $af->{gm}->remove_group($gid); + $af->getGM->remove_group($gid); } @@ -92,7 +92,7 @@ my $output_ref = shift; #arg(2) ref of %output_data; my @friends_list=(); - my $result = $af->{gm}->get_all_group_list(); + my $result = $af->getGM->get_all_group_list(); while( my @row = $result->fetchrow_array ){ Index: affelio/lib/Affelio/App/Admin/Messaging.pm diff -u affelio/lib/Affelio/App/Admin/Messaging.pm:1.15 affelio/lib/Affelio/App/Admin/Messaging.pm:1.16 --- affelio/lib/Affelio/App/Admin/Messaging.pm:1.15 Sun Jul 3 07:46:13 2005 +++ affelio/lib/Affelio/App/Admin/Messaging.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Messaging.pm,v 1.15 2005/07/02 22:46:13 slash5234 Exp $ +# $Id: Messaging.pm,v 1.16 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::Messaging; { @@ -52,7 +52,7 @@ debug_print("Mesg::send: $msg_to $msg_title $msg_body"); - my $passAB = $af->{fm}->get_attribute_by_afid($msg_to, "password"); + my $passAB = $af->getFM->get_attribute_by_afid($msg_to, "password"); if(!defined($passAB) || $passAB eq ""){ #Exception! exit(1); @@ -101,7 +101,7 @@ #To: ############################ my @friends_list=(); - my $result = $af->{fm}->get_all_friend_list(); + my $result = $af->getFM->get_all_friend_list(); while( my @row = $result->fetchrow_array ){ my $selected = ""; @@ -142,7 +142,7 @@ debug_print("marK_as_read: start"); - my $ret= $af->{mesgm}->mark_as_read($mid); + my $ret= $af->getMESGM->mark_as_read($mid); debug_print("marK_as_read: end"); } @@ -154,7 +154,7 @@ my $af = shift; debug_print("get_new: start"); - my $ret= $af->{mesgm}->get_unread_message_num(); + my $ret= $af->getMESGM->get_unread_message_num(); debug_print("get_new: end"); return($ret); @@ -174,7 +174,7 @@ debug_print("show_message: start."); - my @message= $af->{mesgm}->retrieve_message($mid); + my @message= $af->getMESGM->retrieve_message($mid); my ($msg_mid, $msg_timestamp, $msg_title, $msg_type, $msg_from, $msg_body, $msg_readflag) = @message; @@ -257,7 +257,7 @@ my @ret_messages=(); $output_ref->{'messages'} = \@ret_messages; - my $messages= $af->{mesgm}->retrieve_all_messages(); + my $messages= $af->getMESGM->retrieve_all_messages(); my @message=(); while(@message = $messages->fetchrow_array) { Index: affelio/lib/Affelio/App/Admin/MyStatus.pm diff -u affelio/lib/Affelio/App/Admin/MyStatus.pm:1.3 affelio/lib/Affelio/App/Admin/MyStatus.pm:1.4 --- affelio/lib/Affelio/App/Admin/MyStatus.pm:1.3 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/MyStatus.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: MyStatus.pm,v 1.3 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: MyStatus.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::App::Admin::MyStatus; { @@ -42,7 +42,7 @@ $af->{user__currentstatus} = $currentstatus; - $af->{pm}->save_profile(); + $af->getPM->save_profile(); debug_print("MyStatus::post end"); } From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:01 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:01 +0900 Subject: [Affelio-cvs 714] CVS update: affelio/lib/Affelio/Managing Message-ID: <20051027111501.EBE252AC025@users.sourceforge.jp> Index: affelio/lib/Affelio/Managing/AccessLogManager.pm diff -u affelio/lib/Affelio/Managing/AccessLogManager.pm:1.7 affelio/lib/Affelio/Managing/AccessLogManager.pm:1.8 --- affelio/lib/Affelio/Managing/AccessLogManager.pm:1.7 Sat Jul 2 01:24:40 2005 +++ affelio/lib/Affelio/Managing/AccessLogManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: AccessLogManager.pm,v 1.7 2005/07/01 16:24:40 slash5234 Exp $ +# $Id: AccessLogManager.pm,v 1.8 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::AccessLogManager; { @@ -69,7 +69,7 @@ ################################ my $create_tbl_cmd = "CREATE TABLE AFuser_CORE_accesslog(id INTEGER PRIMARY KEY, id2 INTEGER, timestamp BIGINT, nickname TEXT, afid TEXT, type TEXT)"; eval{ - $af->{db}->do($create_tbl_cmd); + $af->getDB()->do($create_tbl_cmd); }; if($@){ }else{ @@ -84,12 +84,12 @@ $query1 = "SELECT * FROM AFuser_CORE_accesslog WHERE timestamp >= $startoftheday AND afid = '$afid'"; debug_print("AccessLog:save: q=[$query1]"); eval{ - $sth1 = $af->{db}->prepare($query1); + $sth1 = $af->getDB()->prepare($query1); $sth1->execute(); @row1 = $sth1->fetchrow_array; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } if(@row1 == () ){ @@ -101,11 +101,11 @@ my $query2 = 'SELECT max(id) FROM AFuser_CORE_accesslog'; my $sth2; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB()->prepare($query2); $sth2->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } my @row2 = $sth2->fetchrow_array; @@ -125,11 +125,11 @@ if($afid =~ /http/){ $query2 = 'SELECT max(id2) FROM AFuser_CORE_accesslog'; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB()->prepare($query2); $sth2->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } @row2 = $sth2->fetchrow_array; @@ -149,12 +149,12 @@ my $query3; my $sth3; $query3 = "insert into AFuser_CORE_accesslog(id, id2, timestamp, nickname, afid, type) values ($newid, $newid2, $cur_time, '$nickname', '$afid', '$type')"; eval{ - $sth3 = $af->{db}->prepare($query3); + $sth3 = $af->getDB()->prepare($query3); $sth3->execute(); }; debug_print("AccessLog:save: inserted [$query3]"); if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } debug_print("AccessLog:save: recorded!"); @@ -179,7 +179,7 @@ ################################ my $create_tbl_cmd = "CREATE TABLE AFuser_CORE_accesslog(id INTEGER PRIMARY KEY, id2 INTEGER, timestamp INTEGER, nickname TEXT, afid TEXT, type TEXT)"; eval{ - $af->{db}->do($create_tbl_cmd); + $af->getDB()->do($create_tbl_cmd); }; if($@){ }else{ @@ -191,11 +191,11 @@ my $query = "SELECT * FROM AFuser_CORE_accesslog WHERE timestamp > $from AND timestamp < $to order by id desc"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB()->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } return($sth); } Index: affelio/lib/Affelio/Managing/ApplicationManager.pm diff -u affelio/lib/Affelio/Managing/ApplicationManager.pm:1.8 affelio/lib/Affelio/Managing/ApplicationManager.pm:1.9 --- affelio/lib/Affelio/Managing/ApplicationManager.pm:1.8 Mon Oct 24 17:52:49 2005 +++ affelio/lib/Affelio/Managing/ApplicationManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: ApplicationManager.pm,v 1.8 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: ApplicationManager.pm,v 1.9 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::ApplicationManager; { @@ -78,7 +78,7 @@ debug_print("AppManager::get_summed_app_perm: q=[$query]"); - my $sth = $af->{db}->prepare($query) or + my $sth = $af->getDB()->prepare($query) or throw Affelio::exception::DBException("cannot insert"); $sth->execute() or throw Affelio::exception::DBException("cannot insert"); @@ -103,7 +103,7 @@ #(1) as a friend my $query = "select $action_type from AFuser_" . $app_name ."_permission where type = 'f' and target_id = '$visitor_mode'"; - my $sth = $af->{db}->prepare($query) or + my $sth = $af->getDB()->prepare($query) or throw Affelio::exception::DBException("cannot insert"); $sth->execute() or throw Affelio::exception::DBException("cannot insert"); @@ -118,10 +118,10 @@ #Get the visitor's UID my ($t_uid, $t_afid, $t_nickname, $t_time, $t_pass, $t_intro, $t_pid, $t_lastupdated, $t_f2list) - = $af->{fm}->get_friend_by_afid($visitor_id); + = $af->getFM->get_friend_by_afid($visitor_id); #Get the visitor's groups - my $SQL_result = $af->{gm}->get_groups_by_uid($t_uid); + my $SQL_result = $af->getGM->get_groups_by_uid($t_uid); #For each group... my @g_data=(); @@ -131,7 +131,7 @@ my $query = "select $action_type from AFuser_" . $app_name ."_permission where type = 'g' and target_id = '$gid'"; - my $sth = $af->{db}->prepare($query) or + my $sth = $af->getDB()->prepare($query) or throw Affelio::exception::DBException("cannot insert"); $sth->execute() or throw Affelio::exception::DBException("cannot insert"); @@ -163,11 +163,11 @@ my $query = 'SELECT * FROM AFuser_' . $app_name . '_permission'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB()->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } debug_print("get_all_premission: end"); @@ -188,7 +188,7 @@ my $query = "SELECT * FROM " . $my_table_name; eval{ - my $sth = $af->{db}->prepare($query); + my $sth = $af->getDB()->prepare($query); my @dummy = $sth->execute(); }; if($@){ @@ -218,7 +218,7 @@ debug_print("AppManager::check_table: create_SQL = [".$create_table_SQL."]"); - my $sth = $af->{db}->prepare($create_table_SQL) or + my $sth = $af->getDB()->prepare($create_table_SQL) or throw Affelio::exception::DBException("cannot create table"); $sth->execute() or throw Affelio::exception::DBException("cannot create table"); @@ -229,7 +229,7 @@ #Synchronized the table # Find all records from AFuser_CORE_permission and # prepare 0-filled records into my table - my $CORE_perm_tbl = $af->{perm}->get_all_permission(); + my $CORE_perm_tbl = $af->getPERM->get_all_permission(); while( my($pid, $type, $target, $dummy) = $CORE_perm_tbl->fetchrow_array ){ my $SQL = $new_rec_SQL . " values ('$pid','$type','$target',1,0,"; @@ -240,7 +240,7 @@ $SQL .= ")"; debug_print("AppManager::check_table: insert_SQL = [".$SQL."]"); - my $sth = $af->{db}->prepare($SQL) or + my $sth = $af->getDB()->prepare($SQL) or throw Affelio::exception::DBException("cannot insert"); $sth->execute() or throw Affelio::exception::DBException("cannot insert"); @@ -272,11 +272,11 @@ #access DB my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB()->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB()->errstr); } #debug_print("AppManager::update_permission end."); Index: affelio/lib/Affelio/Managing/GroupManager.pm diff -u affelio/lib/Affelio/Managing/GroupManager.pm:1.6 affelio/lib/Affelio/Managing/GroupManager.pm:1.7 --- affelio/lib/Affelio/Managing/GroupManager.pm:1.6 Fri Jul 1 13:00:30 2005 +++ affelio/lib/Affelio/Managing/GroupManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: GroupManager.pm,v 1.6 2005/07/01 04:00:30 slash5234 Exp $ +# $Id: GroupManager.pm,v 1.7 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::GroupManager; { @@ -62,11 +62,11 @@ my $query = 'SELECT max(gid) FROM AFuser_CORE_group'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -82,11 +82,11 @@ #Insert a new record $query = 'insert into AFuser_CORE_group(gid, group_name, members, option_pid) values (?,?,?,?)'; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($maxid+1, $group_name, ",", -1); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("add_group: end."); @@ -106,11 +106,11 @@ my $query1 = 'SELECT option_pid FROM AFuser_CORE_group WHERE gid = ?'; my $sth1; eval{ - $sth1 = $af->{db}->prepare($query1); + $sth1 = $af->getDB->prepare($query1); $sth1->execute($gid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row1 = $sth1->fetchrow_array; @@ -119,15 +119,15 @@ my $query2 = 'DELETE FROM AFuser_CORE_group WHERE gid = ?'; my $sth2; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute($gid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } use Affelio::Managing::PermissionManager; - $af->{perm}->remove_permission_by_pid($perm_id); + $af->getPERM->remove_permission_by_pid($perm_id); debug_print("remove_group: end."); } @@ -148,11 +148,11 @@ my $query = "update AFuser_CORE_group set group_name = '$new_name' where gid = $gid"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("rename_group: end."); @@ -172,11 +172,11 @@ my $query = 'SELECT members FROM AFuser_CORE_group WHERE gid = ?'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($gid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -207,11 +207,11 @@ my $query = 'SELECT * FROM AFuser_CORE_group WHERE gid = ?'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($gid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -238,11 +238,11 @@ #Update DB $query = "update AFuser_CORE_group set members = '$new_mem' where gid = $gid"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("add_member: end."); @@ -258,7 +258,7 @@ my $af=$self->{af}; - db_value_replace($af->{db}, + db_value_replace($af->getDB, "AFuser_CORE_group", "gid", "members", @@ -282,11 +282,11 @@ my $query = 'SELECT members FROM AFuser_CORE_group WHERE gid = ?'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($gid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -302,11 +302,11 @@ my $query2 = "update AFuser_CORE_group set members = '$row[0]' where gid = $gid"; my $sth2; eval{ - $sth2= $af->{db}->prepare($query2); + $sth2= $af->getDB->prepare($query2); $sth2->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("remove_member: end."); @@ -333,11 +333,11 @@ #retrieve a friend record from DB my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } return($sth); } @@ -363,11 +363,11 @@ #retrieve a friend record from DB my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } return($sth); } @@ -388,11 +388,11 @@ my $query = 'SELECT * FROM AFuser_CORE_group'; my $sth; eval{ - $sth= $af->{db}->prepare($query); + $sth= $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } return($sth); @@ -434,11 +434,11 @@ my $query = "update AFuser_CORE_group set members = '$uids_str' where gid = $gid"; my $sth; eval{ - $sth= $af->{db}->prepare($query); + $sth= $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("set_member_by_string: end."); @@ -460,11 +460,11 @@ my $query = "update AFuser_CORE_group set option_pid = $pid where gid = $gid"; my $sth; eval{ - $sth= $af->{db}->prepare($query); + $sth= $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("set_pid: end."); Index: affelio/lib/Affelio/Managing/MessageManager.pm diff -u affelio/lib/Affelio/Managing/MessageManager.pm:1.8 affelio/lib/Affelio/Managing/MessageManager.pm:1.9 --- affelio/lib/Affelio/Managing/MessageManager.pm:1.8 Fri Jul 1 16:56:31 2005 +++ affelio/lib/Affelio/Managing/MessageManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: MessageManager.pm,v 1.8 2005/07/01 07:56:31 slash5234 Exp $ +# $Id: MessageManager.pm,v 1.9 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::MessageManager; { @@ -62,11 +62,11 @@ my $sth; eval{ - $sth = $af->{db}->prepare(q{SELECT * FROM AFuser_CORE_message where readflag=0}); + $sth = $af->getDB->prepare(q{SELECT * FROM AFuser_CORE_message where readflag=0}); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); return(""); } @@ -92,11 +92,11 @@ my $query = "update AFuser_CORE_message set readflag = 1 where mid = $mid"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("MM::retrieve_all: end"); @@ -119,11 +119,11 @@ #retrieve all friend records from DB my $sth; eval{ - $sth = $af->{db}->prepare(q{SELECT * FROM AFuser_CORE_message order by timestamp desc}); + $sth = $af->getDB->prepare(q{SELECT * FROM AFuser_CORE_message order by timestamp desc}); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("MM::retrieve_all: end"); @@ -146,11 +146,11 @@ #retrieve all friend records from DB my $sth; eval{ - $sth = $af->{db}->prepare("SELECT * FROM AFuser_CORE_message where mid = $mid"); + $sth = $af->getDB->prepare("SELECT * FROM AFuser_CORE_message where mid = $mid"); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -189,11 +189,11 @@ #Get existing max ID my $sth; eval{ - $sth = $af->{db}->prepare(q{SELECT max(mid) FROM AFuser_CORE_message}); + $sth = $af->getDB->prepare(q{SELECT max(mid) FROM AFuser_CORE_message}); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -217,11 +217,11 @@ #Insert a new record my $str10 = "insert into AFuser_CORE_message(msgbody, mid, timestamp, msgtitle, msgtype, msgfrom, readflag) values ('$body', $newid, '$cur_time', '$title', '$type', '$from', 0)"; eval{ - $sth = $af->{db}->prepare($str10); + $sth = $af->getDB->prepare($str10); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } undef($sth); Index: affelio/lib/Affelio/Managing/PermissionManager.pm diff -u affelio/lib/Affelio/Managing/PermissionManager.pm:1.4 affelio/lib/Affelio/Managing/PermissionManager.pm:1.5 --- affelio/lib/Affelio/Managing/PermissionManager.pm:1.4 Fri Jul 1 11:00:08 2005 +++ affelio/lib/Affelio/Managing/PermissionManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: PermissionManager.pm,v 1.4 2005/07/01 02:00:08 slash5234 Exp $ +# $Id: PermissionManager.pm,v 1.5 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::PermissionManager; { @@ -73,11 +73,11 @@ my $query = 'SELECT max(pid) FROM AFuser_CORE_permission'; my $sth; eval{ - $sth= $af->{db}->prepare($query); + $sth= $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -103,11 +103,11 @@ #DB access eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($newid, $type, $id); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("add_permission DB access done."); @@ -118,7 +118,7 @@ if($type eq "p"){ #Set this new pid into Friend table record. try{ - $af->{fm}->set_attribute_by_id($id, "option_pid", $newid); + $af->getFM->set_attribute_by_id($id, "option_pid", $newid); }catch Affelio::exception::DBException with { my $e = shift; throw $e; @@ -126,7 +126,7 @@ } if($type eq "g"){ #Set this new pid into Group table record. - $af->{gm}->set_pid($id, $newid); + $af->getGM->set_pid($id, $newid); } debug_print("add_permission end."); @@ -165,11 +165,11 @@ #access DB my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("PermissionManager::update_permission end."); @@ -191,11 +191,11 @@ my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("get_permission end."); @@ -217,11 +217,11 @@ my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($pid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("get_permission_by_pid end."); @@ -241,11 +241,11 @@ my $query = 'DELETE FROM AFuser_CORE_permission WHERE pid = ?'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute($pid); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("remove_permission_by_pid end."); @@ -268,11 +268,11 @@ my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } debug_print("get_all_premission: end"); Index: affelio/lib/Affelio/Managing/ProfileManager.pm diff -u affelio/lib/Affelio/Managing/ProfileManager.pm:1.4 affelio/lib/Affelio/Managing/ProfileManager.pm:1.5 --- affelio/lib/Affelio/Managing/ProfileManager.pm:1.4 Fri Jul 1 11:00:08 2005 +++ affelio/lib/Affelio/Managing/ProfileManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -# $Id: ProfileManager.pm,v 1.4 2005/07/01 02:00:08 slash5234 Exp $ +# $Id: ProfileManager.pm,v 1.5 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::ProfileManager; { @@ -92,11 +92,11 @@ my $query = "SELECT * FROM AFuser_CORE_prof where attribute = '$attribute'"; my $sth1; eval{ - $sth1 = $af->{db}->prepare($query); + $sth1 = $af->getDB->prepare($query); $sth1->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @result= $sth1->fetchrow_array(); @@ -104,11 +104,11 @@ my $query2 = 'insert into AFuser_CORE_prof(attribute, value) values (?,?)'; my $sth2; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute($attribute, $value); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } }else{ @@ -116,11 +116,11 @@ my $sth3; eval{ - $sth3 = $af->{db}->prepare($query3); + $sth3 = $af->getDB->prepare($query3); $sth3->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } } } @@ -167,11 +167,11 @@ my $query = 'SELECT * FROM AFuser_CORE_prof'; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); }; return($sth); @@ -191,11 +191,11 @@ my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); }; return($sth); Index: affelio/lib/Affelio/Managing/WhatsNewManager.pm diff -u affelio/lib/Affelio/Managing/WhatsNewManager.pm:1.3 affelio/lib/Affelio/Managing/WhatsNewManager.pm:1.4 --- affelio/lib/Affelio/Managing/WhatsNewManager.pm:1.3 Fri Jul 1 11:00:08 2005 +++ affelio/lib/Affelio/Managing/WhatsNewManager.pm Thu Oct 27 20:15:01 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: WhatsNewManager.pm,v 1.3 2005/07/01 02:00:08 slash5234 Exp $ +# $Id: WhatsNewManager.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ package Affelio::Managing::WhatsNewManager; { @@ -62,7 +62,7 @@ ############################## #retrieve all friend records from DB - my $sth = $af->{db}->prepare(q{SELECT * FROM AFuser_CORE_message}) or die $af->{db}->errstr; + my $sth = $af->getDB->prepare(q{SELECT * FROM AFuser_CORE_message}) or die $af->getDB->errstr; $sth->execute; debug_print("MM::retrieve: end"); @@ -95,7 +95,7 @@ ############################## #Get existing max ID - my $sth = $af->{db}->prepare(q{SELECT max(mid) FROM AFuser_CORE_message}) or die $af->{db}->errstr; + my $sth = $af->getDB->prepare(q{SELECT max(mid) FROM AFuser_CORE_message}) or die $af->getDB->errstr; $sth->execute; my @row = $sth->fetchrow_array; my $maxid = $row[0]; @@ -115,8 +115,8 @@ ############################## #Insert a new record my $str1 = "insert into AFuser_CORE_message(mid, timestamp, msgtitle, msgtype, msgfrom, msgbody, readflag) values ($newid, '$cur_time', '$title', '$type', '$from', '$body', 0)"; - $sth = $af->{db}->prepare($str1) or die $af->{db}->errstr; - $sth->execute or die $af->{db}->errstr; + $sth = $af->getDB->prepare($str1) or die $af->getDB->errstr; + $sth->execute or die $af->getDB->errstr; Affelio::misc::Debug::debug_print("MM::post_message: end."); From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:02 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:02 +0900 Subject: [Affelio-cvs 715] CVS update: affelio/lib/Affelio/SNS Message-ID: <20051027111502.312F02AC012@users.sourceforge.jp> Index: affelio/lib/Affelio/SNS/FriendManager.pm diff -u affelio/lib/Affelio/SNS/FriendManager.pm:1.9 affelio/lib/Affelio/SNS/FriendManager.pm:1.10 --- affelio/lib/Affelio/SNS/FriendManager.pm:1.9 Fri Jul 1 12:38:15 2005 +++ affelio/lib/Affelio/SNS/FriendManager.pm Thu Oct 27 20:15:02 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: FriendManager.pm,v 1.9 2005/07/01 03:38:15 slash5234 Exp $ +# $Id: FriendManager.pm,v 1.10 2005/10/27 11:15:02 slash5234 Exp $ package Affelio::SNS::FriendManager; { @@ -60,11 +60,11 @@ my $query = 'SELECT count(*) FROM AFuser_CORE_friends'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -83,11 +83,11 @@ my $query = 'SELECT count(*) FROM AFuser_CORE_friendsfriends'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -123,11 +123,11 @@ # $query = "SELECT * FROM AFuser_CORE_friends WHERE af_id = '$af_id'"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } @row = $sth->fetchrow_array; @@ -137,11 +137,11 @@ $query = "update AFuser_CORE_friends set timestamp = '$timestamp', password = '$password' where af_id = '$af_id'"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } Affelio::misc::Debug::debug_print("FM::add_friend:\tUpdated an existing friend."); Affelio::misc::Debug::debug_print("FM::add_friend: end($row[0])."); @@ -154,11 +154,11 @@ #Get existing max ID $query = 'SELECT max(uid) FROM AFuser_CORE_friends'; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } @row = $sth->fetchrow_array; $maxid = $row[0]; @@ -175,11 +175,11 @@ #If so, we have to move it from F2 table to F1 table. $query = "SELECT * FROM AFuser_CORE_friendsfriends WHERE af_id = '$af_id'"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } @row = $sth->fetchrow_array; @@ -198,18 +198,18 @@ #Delete the record in the F2 table. $query = "DELETE FROM AFuser_CORE_friendsfriends WHERE uid = $old_uid_in_f2tbl"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } Affelio::misc::Debug::debug_print("FM::add_friend:\tRecord($old_uid_in_f2tbl) in F2 tbl deleted."); #Update all other F1 and F2 entries' "flist" column # from $old_uid_in_f2tbl to $newid # update sample set data=translate(data,'b','z') - db_value_replace($af->{db}, + db_value_replace($af->getDB, "AFuser_CORE_friendsfriends", "uid", "f1list", @@ -217,7 +217,7 @@ ",$newid," , ); - db_value_replace($af->{db}, + db_value_replace($af->getDB, "AFuser_CORE_friends", "uid", "f2list", @@ -233,11 +233,11 @@ #Insert a new record into my F1 list. $query = "insert into AFuser_CORE_friends(uid, af_id, nickname, timestamp, password, intro, option_pid,lastupdated,f2list) values ($newid, '$af_id', '$nickname', $timestamp, '$password', ' ', -1, 0, '$old_f1list_in_f2tbl')"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } Affelio::misc::Debug::debug_print("FM::add_friend:\tInserted a new record."); @@ -260,18 +260,18 @@ my $q1 = "DELETE FROM AFuser_CORE_friends WHERE uid = $uid"; my $s1; eval{ - $s1 = $af->{db}->prepare($q1); + $s1 = $af->getDB->prepare($q1); $s1->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } undef($q1); undef($s1); Affelio::misc::Debug::debug_print("FM::remove_friend:\t removed entry($uid) from F1 DB"); #Remove uid from friends of others in AFuser_CORE_friends - db_value_replace($af->{db}, + db_value_replace($af->getDB, "AFuser_CORE_friends", "uid", "f2list", @@ -281,7 +281,7 @@ Affelio::misc::Debug::debug_print("FM::remove_friend:\t removed entry($uid) from other's F2list in F1 DB"); #Remove uid from friends of others in AFuser_CORE_friendsfriends - db_value_replace($af->{db}, + db_value_replace($af->getDB, "AFuser_CORE_friendsfriends", "uid", "f1list", @@ -357,11 +357,11 @@ #The guy with F2_AF_ID is in the Friend table? $query = "SELECT * FROM AFuser_CORE_friends WHERE af_id = '$f2_af_id'"; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } @row_in_f1table = $sth->fetchrow_array; @@ -386,11 +386,11 @@ Affelio::misc::Debug::debug_print("FM::save_F2List: \tnew_f1_f2list=[$new_f1_f2list]"); $query2 = "update AFuser_CORE_friends set f2list = '$new_f1_f2list' where uid = '$f1_uid'"; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } Affelio::misc::Debug::debug_print("FM::save_F2list: New F1($f1_uid)'s F2list = [$new_f1_f2list]"); @@ -401,11 +401,11 @@ Affelio::misc::Debug::debug_print("FM::save_F2List: \tnew_f2_f1list=[$new_f2_f1list]"); $query2 = "update AFuser_CORE_friends set f2list = '$new_f2_f1list' where uid = $f2_uid"; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } Affelio::misc::Debug::debug_print("FM::save_F2list: New F2($f2_uid)'s F1list = [$new_f2_f1list]"); @@ -416,11 +416,11 @@ #The guy with F2_AF_ID is in the FriendsFriends table? $query2 = "SELECT * FROM AFuser_CORE_friendsfriends WHERE af_id = '$f2_af_id'"; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } @row_in_f2table = $sth2->fetchrow_array; @@ -437,11 +437,11 @@ #Get existing min ID $query3 = 'SELECT min(uid) FROM AFuser_CORE_friendsfriends'; eval{ - $sth3 = $af->{db}->prepare($query3); + $sth3 = $af->getDB->prepare($query3); $sth3->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } @row = $sth3->fetchrow_array; @@ -457,11 +457,11 @@ my $tmpnewid = $minid-1; $query3 = "insert into AFuser_CORE_friendsfriends (uid, af_id, nickname, timestamp, f1list) values ('$tmpnewid', '$f2_af_id', '$nickname', $timestamp, ',')"; eval{ - $sth3 = $af->{db}->prepare($query3); + $sth3 = $af->getDB->prepare($query3); $sth3->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } $f2_uid = $minid - 1; #F2 UID is negative! @@ -484,11 +484,11 @@ Affelio::misc::Debug::debug_print("FM::save_F2List:\tnew_f1_f2list=[$new_f1_f2list]"); $query2 = "update AFuser_CORE_friends set f2list = '$new_f1_f2list' where uid = $f1_uid"; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } #Modify "FriendsFriends" table @@ -497,11 +497,11 @@ Affelio::misc::Debug::debug_print("FM::save_F2List:\tnew_f2_f1list=[$new_f2_f1list]"); $query2 = "update AFuser_CORE_friendsfriends set f1list = '$new_f2_f1list' where uid = $f2_uid"; eval{ - $sth2 = $af->{db}->prepare($query2); + $sth2 = $af->getDB->prepare($query2); $sth2->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } }#if @@ -544,11 +544,11 @@ my $query = "SELECT af_id, timestamp, nickname FROM AFuser_CORE_friends WHERE timestamp > " . $req_timestamp; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my $retmsg=""; @@ -585,11 +585,11 @@ my $query = 'SELECT * FROM AFuser_CORE_friends order by uid desc'; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } return($sth); @@ -613,11 +613,11 @@ my $query = "SELECT * FROM AFuser_CORE_friends WHERE uid = $uid"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; if(@row==()) {undef @row}; @@ -642,11 +642,11 @@ my $query = "SELECT * FROM AFuser_CORE_friends WHERE af_id = '$af_id'"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -671,11 +671,11 @@ my $query = "SELECT $attr FROM AFuser_CORE_friends WHERE uid = '$uid'"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -698,11 +698,11 @@ my $query = "SELECT $attr FROM AFuser_CORE_friendsfriends WHERE uid = $uid"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute(); }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; return($row[0]); @@ -717,7 +717,7 @@ my $attr = shift; #arg(2) attr (string) my $af = $self->{af}; - $af_id = $af->{db}->quote($af_id); + $af_id = $af->getDB->quote($af_id); ############################## #retrieve a friend record from DB @@ -725,11 +725,11 @@ my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } my @row = $sth->fetchrow_array; @@ -751,7 +751,7 @@ || ($attr eq "af_id") || ($attr eq "nickname") || ($attr eq "intro") ){ - $value = $af->{db}->quote($value); + $value = $af->getDB->quote($value); } ############################## @@ -759,11 +759,11 @@ my $query = "update AFuser_CORE_friends set $attr = $value where uid = $uid"; my $sth; eval{ - $sth = $af->{db}->prepare($query); + $sth = $af->getDB->prepare($query); $sth->execute; }; if($@){ - throw Affelio::exception::DBException($af->{db}->errstr); + throw Affelio::exception::DBException($af->getDB->errstr); } } Index: affelio/lib/Affelio/SNS/Handshaker_s.pm diff -u affelio/lib/Affelio/SNS/Handshaker_s.pm:1.21 affelio/lib/Affelio/SNS/Handshaker_s.pm:1.22 --- affelio/lib/Affelio/SNS/Handshaker_s.pm:1.21 Mon Oct 24 17:52:49 2005 +++ affelio/lib/Affelio/SNS/Handshaker_s.pm Thu Oct 27 20:15:02 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Handshaker_s.pm,v 1.21 2005/10/24 08:52:49 slash5234 Exp $ +# $Id: Handshaker_s.pm,v 1.22 2005/10/27 11:15:02 slash5234 Exp $ use strict; use lib("../../../extlib/"); @@ -114,7 +114,7 @@ # timestamp > req_timestamp #Retrieve erased friends whose # timestamp > req_timestamp - my $retmsg = $af->{fm}->get_updated_friends($req_timestamp); + my $retmsg = $af->getFM->get_updated_friends($req_timestamp); Affelio::misc::Debug::debug_print("server.F2List: ret=[$retmsg]"); Affelio::misc::Debug::debug_print("server.F2List: end."); @@ -143,7 +143,7 @@ $peer_afid, $MIMed_mesg) = @_; - my $passAB = $af->{fm}->get_attribute_by_afid($peer_afid, "password"); + my $passAB = $af->getFM->get_attribute_by_afid($peer_afid, "password"); if(!defined($passAB) || $passAB eq ""){ return { flerror => XMLRPC::Data->type('boolean', 1), @@ -230,7 +230,7 @@ $msg_from = '' . $msg_from_nickname . ''; - $af->{mesgm}->post_message($msg_from, + $af->getMESGM->post_message($msg_from, $msg_title, "UserToUser/OneToOne", $msg_body); @@ -289,7 +289,7 @@ . "$MIMed_mesg\n" . MIME::Base64::Perl::encode_base64("\n\nClick following link to approve this request.\n\n$af->{site__web_root}/bin/recv_mail_ack.cgi?id=$sessionid"); - $af->{mesgm}->post_message("Your Affelio", + $af->getMESGM->post_message("Your Affelio", "Link Request from $peer_nickname", "SystemToUser/LinkRequest/Encode-Base64", $message_body); @@ -395,15 +395,15 @@ ########################################### #Add peer to my friends list. ########################################### - my $uid = $af->{fm}->add_friend($peer_af_id, + my $uid = $af->getFM->add_friend($peer_af_id, $peer_nickname, $timestamp, $pass); Affelio::misc::Debug::debug_print("server.HandShakeReply: add_friend finished.\n"); eval{ - $af->{db}->commit; - $af->{db}->disconnect; + $af->getDB->commit; + $af->getDB->disconnect; undef($af); }; if($@){ @@ -424,7 +424,7 @@ ########################################### $af = Affelio::SNS::Handshaker_s::Util::af_new(); Affelio::misc::Debug::debug_print("server.HandshakeReply: Let's save peer's flist!"); - $af->{fm}->save_F2List($ret, $peer_af_id); + $af->getFM->save_F2List($ret, $peer_af_id); Affelio::misc::Debug::debug_print("server.HandshakeReply: save_F2List finished."); #Make a new instance of Affelio Index: affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm diff -u affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm:1.3 affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm:1.4 --- affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm:1.3 Fri Jul 1 11:00:09 2005 +++ affelio/lib/Affelio/SNS/Handshaker_tmpDB.pm Thu Oct 27 20:15:02 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Handshaker_tmpDB.pm,v 1.3 2005/07/01 02:00:09 slash5234 Exp $ +# $Id: Handshaker_tmpDB.pm,v 1.4 2005/10/27 11:15:02 slash5234 Exp $ use strict; use lib("../../../extlib/"); @@ -94,8 +94,8 @@ my $af = $self->{af}; my $str = "insert into $dbname (sessionid, timestamp, af_id, nickname, DH_key_str) values ('$sessionid', '$timestamp', '$af_id', '$nickname', '$DH_key_str')"; - my $sth = $af->{db}->prepare($str); - $sth->execute() or die $af->{db}->errstr; + my $sth = $af->getDB->prepare($str); + $sth->execute() or die $af->getDB->errstr; Affelio::misc::Debug::debug_print("add: end."); return; @@ -114,8 +114,8 @@ Affelio::misc::Debug::debug_print("removedb: $sessionid"); my $str = "SELECT sessionid, timestamp, af_id, nickname, DH_key_str FROM $dbname WHERE sessionid= '$sessionid'"; - my $sth = $af->{db}->prepare($str) or die $af->{db}->errstr; - $sth->execute() or die $af->{db}->errstr; + my $sth = $af->getDB->prepare($str) or die $af->getDB->errstr; + $sth->execute() or die $af->getDB->errstr; my @row = $sth->fetchrow_array; if(!defined(@row)){ @@ -124,7 +124,7 @@ } my $str = "DELETE FROM $dbname WHERE sessionid=?"; - my $sth = $af->{db}->prepare($str) or die $af->{db}->errstr; + my $sth = $af->getDB->prepare($str) or die $af->getDB->errstr; $sth->execute($sessionid); Affelio::misc::Debug::debug_print("removedb: end."); From slash5234 @ users.sourceforge.jp Thu Oct 27 20:15:02 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:15:02 +0900 Subject: [Affelio-cvs 716] CVS update: affelio/lib/Affelio/misc Message-ID: <20051027111502.63EEA2AC025@users.sourceforge.jp> Index: affelio/lib/Affelio/misc/InitAffelio.pm diff -u affelio/lib/Affelio/misc/InitAffelio.pm:1.8 affelio/lib/Affelio/misc/InitAffelio.pm:1.9 --- affelio/lib/Affelio/misc/InitAffelio.pm:1.8 Thu Oct 27 19:26:37 2005 +++ affelio/lib/Affelio/misc/InitAffelio.pm Thu Oct 27 20:15:02 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: InitAffelio.pm,v 1.8 2005/10/27 10:26:37 slash5234 Exp $ +# $Id: InitAffelio.pm,v 1.9 2005/10/27 11:15:02 slash5234 Exp $ package Affelio::misc::InitAffelio; { @@ -164,7 +164,7 @@ try{ $af = new Affelio(ConfigDir => $cfg_dir, Mode => "init"); - $dbh = $af->{db}; + $dbh = $af->getDB; }catch Error with{ my $e = shift; throw Affelio::exception::Exception("Could not load Affelio (init): $e"); @@ -187,7 +187,7 @@ $af->{user__nickname} = $g_nickname; $af->{user__email1} = $g_email; try{ - $af->{pm}->save_profile(); + $af->getPM->save_profile(); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("Cannot save_profile: $@"); @@ -335,7 +335,7 @@ # n names b i intro email url im my @flag_array = (1,1,1,1, 1,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); try{ - $af->{perm}->add_permission("f", "f1", \@flag_array); + $af->getPERM->add_permission("f", "f1", \@flag_array); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("adding F1 perm: $@"); @@ -347,7 +347,7 @@ # n names b i intro email url im my @flag_array = (1,0,0,0, 0,1, 1,1, 0,0,0,0, 1,1,1,1, 0,0,0,0,0,0, 1); try{ - $af->{perm}->add_permission("f", "f2", \@flag_array); + $af->getPERM->add_permission("f", "f2", \@flag_array); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("adding F2 perm: $@"); @@ -359,7 +359,7 @@ # n names b i intro email url im my @flag_array = (1,0,0,0, 0,0, 1,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,0,0, 0); try{ - $af->{perm}->add_permission("f", "pb", \@flag_array); + $af->getPERM->add_permission("f", "pb", \@flag_array); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("adding PB perm: $@"); @@ -370,7 +370,7 @@ ################################ my $gid; try{ - $gid = $af->{gm}->add_group($af->{lh}->maketext("_SETUP_group_dear_friend")); + $gid = $af->getGM->add_group($af->{lh}->maketext("_SETUP_group_dear_friend")); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("adding dear Grp: $@"); @@ -382,7 +382,7 @@ # n names b i intro email url im my @flag_array = (1,1,1,1, 1,1, 1,1, 1,1,1,1, 1,1,1,1, 1,1,1,1,1,1, 1); try{ - $af->{perm}->add_permission("g", $gid, \@flag_array); + $af->getPERM->add_permission("g", $gid, \@flag_array); }catch Error with{ my $e = shift; throw Affelio::exception::Exception("adding perm to Grp: $@"); From slash5234 @ users.sourceforge.jp Thu Oct 27 20:30:09 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 20:30:09 +0900 Subject: [Affelio-cvs 717] CVS update: affelio Message-ID: <20051027113009.1758B2AC012@users.sourceforge.jp> Index: affelio/index.cgi diff -u affelio/index.cgi:1.15 affelio/index.cgi:1.16 --- affelio/index.cgi:1.15 Thu Oct 27 20:15:00 2005 +++ affelio/index.cgi Thu Oct 27 20:30:08 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: index.cgi,v 1.15 2005/10/27 11:15:00 slash5234 Exp $ +# $Id: index.cgi,v 1.16 2005/10/27 11:30:08 slash5234 Exp $ use strict; @@ -93,6 +93,8 @@ my %output_data = (); my $TMPL_FILE =""; +$af->load_ApplicationManager(); + ###################################################### #Template file ###################################################### From slash5234 @ users.sourceforge.jp Thu Oct 27 21:06:34 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 21:06:34 +0900 Subject: [Affelio-cvs 718] CVS update: affelio Message-ID: <20051027120634.4E2272AC055@users.sourceforge.jp> Index: affelio/index.cgi diff -u affelio/index.cgi:1.16 affelio/index.cgi:1.17 --- affelio/index.cgi:1.16 Thu Oct 27 20:30:08 2005 +++ affelio/index.cgi Thu Oct 27 21:06:34 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: index.cgi,v 1.16 2005/10/27 11:30:08 slash5234 Exp $ +# $Id: index.cgi,v 1.17 2005/10/27 12:06:34 slash5234 Exp $ use strict; @@ -27,6 +27,7 @@ use CGI::Session qw(-ip_match); use HTML::Template; use Error qw(:try); +use Fcntl; use lib("./lib"); use Affelio; @@ -92,25 +93,33 @@ ############################################################################ my %output_data = (); my $TMPL_FILE =""; +my $INJ_FILE =""; $af->load_ApplicationManager(); ###################################################### #Template file ###################################################### -my $mode = $wi->PTN_mode($q->url_param("mode")); -debug_print("================$mode"); +if($af->{userpref__toppage_app_installname} eq "Affelio"){ -if(($mode eq "") || !defined($mode)){ - #If "mode" is not set, we will look at $self->{userpref__toppage_app_path} - #value. - my $abs_next_URL = $af->{site__web_root} . "/" . $af->{userpref__toppage_app_path}; + #top page is Affelio module. + my $mode = $wi->PTN_mode($q->url_param("mode")); + debug_print("index.cgi CGI mode = [$mode]"); + if($mode eq "") { + $mode="index"; + } + $TMPL_FILE = "$af->{site__fs_root}/templates_dyn/" . $mode . ".tmpl"; + $INJ_FILE = "$af->{site__fs_root}/templates_dyn/" . $mode . ".inj"; + +}else{ + + #top page is NOT Affelio module but one of applications. + my $abs_next_URL = $af->{site__web_root} . "/" . + $af->{userpref__toppage_app_path}; print "Location: $abs_next_URL", "\n\n"; exit(1); } -$TMPL_FILE = "$af->{site__fs_root}/templates_dyn/" . $mode . ".tmpl"; - ###################################################### #Data prep (1) @@ -131,7 +140,6 @@ error($q, "Affelio init error.\n" . $e); }; - ################# #Client info ################# @@ -164,6 +172,10 @@ ###################################################### #Data prep from Models ###################################################### +sysopen(INJ, $INJ_FILE, O_RDONLY); +my $injection_flg = ; +close INJ; + #Inject Profile Data use Affelio::App::ShowProfile; try{ @@ -176,43 +188,54 @@ error($q, "Affelio: model execution error.\n" . $e); }; +############################## #Friendlist use Affelio::App::FriendRoutines; -my @friendlist_5; -try{ - @friendlist_5 = get_friends_list($af, $visitor_afid, $visitor_type, 5); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_5"} = \@friendlist_5; - +############################## my @friendlist_5_IF; -try{ - @friendlist_5_IF = get_friends_list_IF($af,$visitor_afid, $visitor_type,5); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_5_IF"} = \@friendlist_5_IF; - +if($injection_flg =~ /block\_friendlist\_5\_IF\,/){ + try{ + @friendlist_5_IF = get_friends_list_IF($af,$visitor_afid, $visitor_type,5); + }catch Error with{ + my $e = shift; + error($q, "Affelio: model execution error.\n" . $e); + }; + $output_data{"friendlist_5_IF"} = \@friendlist_5_IF; +} +############################## +my @friendlist_5; +if($injection_flg =~ /block\_friendlist\_5\,/){ + try{ + @friendlist_5 = get_friends_list($af, $visitor_afid, $visitor_type, 5); + }catch Error with{ + my $e = shift; + error($q, "Affelio: model execution error.\n" . $e); + }; + $output_data{"friendlist_5"} = \@friendlist_5; +} +############################## my @friendlist_all; -try{ - @friendlist_all = get_friends_list($af, $visitor_afid, $visitor_type, -1); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_all"} = \@friendlist_all; - +if($injection_flg =~ /block\_friendlist\_all\,/){ + try{ + @friendlist_all = get_friends_list($af, $visitor_afid, $visitor_type, -1); + }catch Error with{ + my $e = shift; + error($q, "Affelio: model execution error.\n" . $e); + }; + $output_data{"friendlist_all"} = \@friendlist_all; +} +############################## my @friendlist_all_IF; -try{ - @friendlist_all_IF=get_friends_list_IF($af,$visitor_afid,$visitor_type,-1); -}catch Error with{ - my $e = shift; - error($q, "Affelio: model execution error.\n" . $e); -}; -$output_data{"friendlist_all_IF"} = \@friendlist_all_IF; +if($injection_flg =~ /block\_friendlist\_all_IF\,/){ + try{ + @friendlist_all_IF=get_friends_list_IF($af,$visitor_afid,$visitor_type,-1); + }catch Error with{ + my $e = shift; + error($q, "Affelio: model execution error.\n" . $e); + }; + $output_data{"friendlist_all_IF"} = \@friendlist_all_IF; +} +############################## try{ $output_data{"friend__F1count"} = $af->getFM->get_F1_count(); @@ -239,6 +262,7 @@ $tmpl->param($data_key => $output_data{$data_key}); } + ########################################################################### #AccessLog ########################################################################### From slash5234 @ users.sourceforge.jp Thu Oct 27 21:06:34 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 21:06:34 +0900 Subject: [Affelio-cvs 719] CVS update: affelio/lib Message-ID: <20051027120634.6DD822AC057@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.24 affelio/lib/Affelio.pm:1.25 --- affelio/lib/Affelio.pm:1.24 Thu Oct 27 20:15:01 2005 +++ affelio/lib/Affelio.pm Thu Oct 27 21:06:34 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.24 2005/10/27 11:15:01 slash5234 Exp $ +# $Id: Affelio.pm,v 1.25 2005/10/27 12:06:34 slash5234 Exp $ package Affelio; { @@ -134,17 +134,33 @@ ################################### #Initialization - ################################### - #Read site config. and user preferences. + # Read site config. and user preferences. $self->read_site_config(); $self->read_user_prefs(); + ################################### #Load locale $self->load_Locale(); - #if($self->{mode} ne "init"){ - # $self->load_ApplicationManager(); - #} + ########################### + #Configure "Top page" + ########################### + if($self->{mode} ne "init"){ + if(($self->{userpref__toppage_app_installname} ne "") + && ($self->{userpref__toppage_app_installname} ne "Affelio")){ + + #Here, top page is not Affelio module but one of apps. + #We now need to load Application Manager + $self->load_ApplicationManager(); + $self->{userpref__toppage_app_path}= "/apps/" . $self->{userpref__toppage_app_installname} . "/" . $self->{am}->{apps}->{"$self->{userpref__toppage_app_installname}"}->{guest_index}; + + }else{ + + #Here, top page is Affelio module. + $self->{userpref__toppage_app_installname} = "Affelio"; + $self->{userpref__toppage_app_path}="index.cgi?mode=index"; + } + } debug_print("Affelio::new: end."); return $self; @@ -494,22 +510,6 @@ ########################### $self->{am} = new Affelio::Managing::ApplicationManager($self); - ########################### - #Configure "Top page" - ########################### - if(($self->{userpref__toppage_app_installname} ne "") - && ($self->{userpref__toppage_app_installname} ne "Affelio")){ - - $self->{userpref__toppage_app_path}= - "/apps/" . - $self->{userpref__toppage_app_installname} . "/" . - $self->{am}->{apps}->{"$self->{userpref__toppage_app_installname}"}->{guest_index}; - - }else{ - $self->{userpref__toppage_app_installname} = "Affelio"; - $self->{userpref__toppage_app_path}="index.cgi?mode=index"; - } - }catch Error with { my $ex = shift; if($self->{mode} ne "init"){ From slash5234 @ users.sourceforge.jp Thu Oct 27 21:06:34 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 21:06:34 +0900 Subject: [Affelio-cvs 720] CVS update: affelio/lib/Affelio/App/Admin Message-ID: <20051027120634.8B5F82AC055@users.sourceforge.jp> Index: affelio/lib/Affelio/App/Admin/EditTemplates.pm diff -u affelio/lib/Affelio/App/Admin/EditTemplates.pm:1.8 affelio/lib/Affelio/App/Admin/EditTemplates.pm:1.9 --- affelio/lib/Affelio/App/Admin/EditTemplates.pm:1.8 Fri Jul 1 11:00:07 2005 +++ affelio/lib/Affelio/App/Admin/EditTemplates.pm Thu Oct 27 21:06:34 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: EditTemplates.pm,v 1.8 2005/07/01 02:00:07 slash5234 Exp $ +# $Id: EditTemplates.pm,v 1.9 2005/10/27 12:06:34 slash5234 Exp $ package Affelio::App::Admin::EditTemplates; { @@ -146,6 +146,8 @@ ################################################### #Replacement ################################################### + my $included_aftags=""; + # (1)s/AF_VAR/TMPL_VAR/g $output_contents =~ s/AF_VAR/TMPL_VAR/g; @@ -168,7 +170,11 @@ close(TAGCONTENT); my $rep = ''; - $output_contents =~ s/$rep/$tagcontent/g; + if($output_contents =~ /$rep/){ + $output_contents =~ s/$rep/$tagcontent/g; + $included_aftags .= "block_$tagname,"; + } + }#if }#while @@ -178,6 +184,10 @@ sysopen(OUT, "$af->{site__fs_root}/templates_dyn/$template_name.tmpl", O_WRONLY|O_CREAT|O_TRUNC, 0755); print OUT $output_contents; close(OUT); + + sysopen(OUT, "$af->{site__fs_root}/templates_dyn/$template_name.inj", O_WRONLY|O_CREAT|O_TRUNC, 0755); + print OUT $included_aftags; + close(OUT); }#if }#while(for each file...) From slash5234 @ users.sourceforge.jp Thu Oct 27 21:57:40 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 21:57:40 +0900 Subject: [Affelio-cvs 719] CVS update: affelio Message-ID: <20051027125740.612D12AC00E@users.sourceforge.jp> Index: affelio/index.cgi diff -u affelio/index.cgi:1.17 affelio/index.cgi:1.18 --- affelio/index.cgi:1.17 Thu Oct 27 21:06:34 2005 +++ affelio/index.cgi Thu Oct 27 21:57:40 2005 @@ -16,7 +16,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: index.cgi,v 1.17 2005/10/27 12:06:34 slash5234 Exp $ +# $Id: index.cgi,v 1.18 2005/10/27 12:57:40 slash5234 Exp $ use strict; @@ -236,7 +236,6 @@ $output_data{"friendlist_all_IF"} = \@friendlist_all_IF; } ############################## - try{ $output_data{"friend__F1count"} = $af->getFM->get_F1_count(); $output_data{"friend__F2count"} = $af->getFM->get_F2_count(); From slash5234 @ users.sourceforge.jp Thu Oct 27 21:57:40 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 21:57:40 +0900 Subject: [Affelio-cvs 720] CVS update: affelio/lib Message-ID: <20051027125740.8E1F82AC054@users.sourceforge.jp> Index: affelio/lib/Affelio.pm diff -u affelio/lib/Affelio.pm:1.25 affelio/lib/Affelio.pm:1.26 --- affelio/lib/Affelio.pm:1.25 Thu Oct 27 21:06:34 2005 +++ affelio/lib/Affelio.pm Thu Oct 27 21:57:40 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Affelio.pm,v 1.25 2005/10/27 12:06:34 slash5234 Exp $ +# $Id: Affelio.pm,v 1.26 2005/10/27 12:57:40 slash5234 Exp $ package Affelio; { @@ -142,6 +142,8 @@ #Load locale $self->load_Locale(); + my $dummy=$self->getPM(); + ########################### #Configure "Top page" ########################### @@ -322,7 +324,7 @@ sub getPM{ my $self=shift; - if(! ($self->{pm}) ){ + if(!($self->{pm}) ){ $self->load_ProfileManager(); } return($self->{pm}); From slash5234 @ users.sourceforge.jp Thu Oct 27 21:57:40 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Thu, 27 Oct 2005 21:57:40 +0900 Subject: [Affelio-cvs 721] CVS update: affelio/lib/Affelio/App/Admin Message-ID: <20051027125740.AB7E92AC00E@users.sourceforge.jp> Index: affelio/lib/Affelio/App/Admin/EditProfile.pm diff -u affelio/lib/Affelio/App/Admin/EditProfile.pm:1.4 affelio/lib/Affelio/App/Admin/EditProfile.pm:1.5 --- affelio/lib/Affelio/App/Admin/EditProfile.pm:1.4 Thu Oct 27 20:15:01 2005 +++ affelio/lib/Affelio/App/Admin/EditProfile.pm Thu Oct 27 21:57:40 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: EditProfile.pm,v 1.4 2005/10/27 11:15:01 slash5234 Exp $ +# $Id: EditProfile.pm,v 1.5 2005/10/27 12:57:40 slash5234 Exp $ package Affelio::App::Admin::EditProfile; { @@ -86,6 +86,8 @@ sub show_profileeditor{ my $af = shift; my $output_data_ref = shift; + + my $dummy=$af->getPM; foreach my $key (sort keys %$af){ #debug_print("set_profile_into_hash: " . $key . "=" . $af->{$key}); From slash5234 @ users.sourceforge.jp Sat Oct 29 03:17:58 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Sat, 29 Oct 2005 03:17:58 +0900 Subject: [Affelio-cvs 722] CVS update: affelio/skins/standard Message-ID: <20051028181758.772E22AC01A@users.sourceforge.jp> Index: affelio/skins/standard/style.css diff -u affelio/skins/standard/style.css:1.17 affelio/skins/standard/style.css:1.18 --- affelio/skins/standard/style.css:1.17 Fri Jul 1 08:18:06 2005 +++ affelio/skins/standard/style.css Sat Oct 29 03:17:58 2005 @@ -251,7 +251,7 @@ padding: 5px 5px 5px 5px; margin: 0px 0px 0px 0px; background-color: #fff; - font-size: small; + font-size: x-small; border: 1px solid #aaa; text-align: left; } @@ -260,7 +260,7 @@ color: black; padding: 5px 5px 5px 5px; margin: 0px 0px 0px 0px; - font-size: small; + font-size: x-small; border: 1px solid #aaa; text-align: left; } @@ -467,11 +467,12 @@ border-right: 1px solid #aaa; background-color: #fff; font-family: Verdana, Arial, sans-serif; + font-size: x-small; } .adAdminSubMenu{ - font-size: small; + font-size: x-small; text-align: left; font-weight: normal; line-height: 100%; @@ -490,7 +491,7 @@ padding-top: 5px; text-align: left; font-family: Verdana, Arial, sans-serif; - font-size: small; + font-size: x-small; line-height: 140%; border-bottom: 1px solid #aaa; } From slash5234 @ users.sourceforge.jp Sat Oct 29 04:36:35 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Sat, 29 Oct 2005 04:36:35 +0900 Subject: [Affelio-cvs 723] CVS update: affelio/lib/Affelio/App/Admin/AFTemplateBlocks Message-ID: <20051028193635.696082AC01A@users.sourceforge.jp> Index: affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag diff -u affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag:1.2 affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag:1.3 --- affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag:1.2 Sun Jul 3 07:46:13 2005 +++ affelio/lib/Affelio/App/Admin/AFTemplateBlocks/friendlist_all.aftag Sat Oct 29 04:36:35 2005 @@ -4,9 +4,6 @@
-
- -

">" WIDTH=100 BORDER=0> From slash5234 @ users.sourceforge.jp Sat Oct 29 04:36:35 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Sat, 29 Oct 2005 04:36:35 +0900 Subject: [Affelio-cvs 724] CVS update: affelio/skins/standard Message-ID: <20051028193635.87F422AC02C@users.sourceforge.jp> Index: affelio/skins/standard/style.css diff -u affelio/skins/standard/style.css:1.18 affelio/skins/standard/style.css:1.19 --- affelio/skins/standard/style.css:1.18 Sat Oct 29 03:17:58 2005 +++ affelio/skins/standard/style.css Sat Oct 29 04:36:35 2005 @@ -315,11 +315,13 @@ margin: 0px; padding: 0px; width: 130px; + height: 20px; line-height: 100%; overflow: hidden; font-family: Arial; font-size: xx-small; font-weight: normal; + overflow: hidden; } .aftag__friendlist_5__image{ width: 100px; @@ -334,7 +336,7 @@ } .aftag__friendlist_all__field{ background: #eee; - width: 149px; + width: 145px; vertical-align: top; text-align: center; float: left; From slash5234 @ users.sourceforge.jp Sat Oct 29 05:31:03 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Sat, 29 Oct 2005 05:31:03 +0900 Subject: [Affelio-cvs 725] CVS update: affelio/lib/Affelio/App Message-ID: <20051028203103.3172D2AC01A@users.sourceforge.jp> Index: affelio/lib/Affelio/App/FriendRoutines.pm diff -u affelio/lib/Affelio/App/FriendRoutines.pm:1.6 affelio/lib/Affelio/App/FriendRoutines.pm:1.7 --- affelio/lib/Affelio/App/FriendRoutines.pm:1.6 Thu Oct 27 20:15:01 2005 +++ affelio/lib/Affelio/App/FriendRoutines.pm Sat Oct 29 05:31:03 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: FriendRoutines.pm,v 1.6 2005/10/27 11:15:01 slash5234 Exp $ +# $Id: FriendRoutines.pm,v 1.7 2005/10/28 20:31:03 slash5234 Exp $ package Affelio::App::FriendRoutines; { @@ -210,7 +210,7 @@ URL => $dest_URL, image_URL => $image_URL, editurl => $editurl, - mailurl => $editurl, + mailurl => $mailurl, intro => $person[5], mystatus_URL => $mystatus_URL } From slash5234 @ users.sourceforge.jp Sat Oct 29 05:31:03 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Sat, 29 Oct 2005 05:31:03 +0900 Subject: [Affelio-cvs 726] CVS update: affelio/lib/Affelio/Managing Message-ID: <20051028203103.54C932AC030@users.sourceforge.jp> Index: affelio/lib/Affelio/Managing/MessageManager.pm diff -u affelio/lib/Affelio/Managing/MessageManager.pm:1.9 affelio/lib/Affelio/Managing/MessageManager.pm:1.10 --- affelio/lib/Affelio/Managing/MessageManager.pm:1.9 Thu Oct 27 20:15:01 2005 +++ affelio/lib/Affelio/Managing/MessageManager.pm Sat Oct 29 05:31:03 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: MessageManager.pm,v 1.9 2005/10/27 11:15:01 slash5234 Exp $ +# $Id: MessageManager.pm,v 1.10 2005/10/28 20:31:03 slash5234 Exp $ package Affelio::Managing::MessageManager; { @@ -182,9 +182,6 @@ Affelio::misc::Debug::debug_print("MM::post_message: start."); - #DB - #mid,timestamp,msg_title,msg_type,msg_from,msg_body,readflag - ############################## #Get existing max ID my $sth; @@ -225,11 +222,16 @@ } undef($sth); + + my $from_onlyname = $from; + $from_onlyname =~ s|(.*)|$1|; + ############################## #Email notification if needed if($af->{userpref__mesging__emailflg} eq "yes"){ my $abs_URL = $af->{site__web_root} . "/admin.cgi?mode=messages&action=show&mid=$newid"; - Affelio::NetLib::Email::send_email($af, "Your Affelio <$af->{user__email1}>", $af->{user__email1}, "New message to your Affelio", $abs_URL); + Affelio::NetLib::Email::send_email($af, "Your Affelio <$af->{user__email1}>", $af->{user__email1}, "Message from $from_onlyname", "Click this URL.\n$abs_URL"); + Affelio::misc::Debug::debug_print("MM::post_message: Email sent!"); } From slash5234 @ users.sourceforge.jp Sat Oct 29 05:31:03 2005 From: slash5234 @ users.sourceforge.jp (Tadashi Okoshi) Date: Sat, 29 Oct 2005 05:31:03 +0900 Subject: [Affelio-cvs 727] CVS update: affelio/lib/Affelio/SNS Message-ID: <20051028203103.73CD32AC01A@users.sourceforge.jp> Index: affelio/lib/Affelio/SNS/Handshaker_s.pm diff -u affelio/lib/Affelio/SNS/Handshaker_s.pm:1.22 affelio/lib/Affelio/SNS/Handshaker_s.pm:1.23 --- affelio/lib/Affelio/SNS/Handshaker_s.pm:1.22 Thu Oct 27 20:15:02 2005 +++ affelio/lib/Affelio/SNS/Handshaker_s.pm Sat Oct 29 05:31:03 2005 @@ -14,7 +14,7 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # -# $Id: Handshaker_s.pm,v 1.22 2005/10/27 11:15:02 slash5234 Exp $ +# $Id: Handshaker_s.pm,v 1.23 2005/10/28 20:31:03 slash5234 Exp $ use strict; use lib("../../../extlib/"); @@ -285,9 +285,9 @@ # Send a message to MessageManager ########################################### my $message_body= - MIME::Base64::Perl::encode_base64("You got a link request from $peer_nickname ( $peer_af_id ). \n\nMessage from the user is...\n") + MIME::Base64::Perl::encode_base64("You got a link request from $peer_nickname ( $peer_af_id ). \nMessage from the user is...\n\n") . "$MIMed_mesg\n" - . MIME::Base64::Perl::encode_base64("\n\nClick following link to approve this request.\n\n$af->{site__web_root}/bin/recv_mail_ack.cgi?id=$sessionid"); + . MIME::Base64::Perl::encode_base64("\n\nClick following link to approve this request.\n$af->{site__web_root}/bin/recv_mail_ack.cgi?id=$sessionid"); $af->getMESGM->post_message("Your Affelio", "Link Request from $peer_nickname",