#!/usr/local/bin/perl
use lib qw(PATH TO LIBRARY);
use strict;
use utf8;
use Encode;
binmode STDOUT=>":utf8";
$| = 1;
my $ref = reference->new({});
$ref->check_key_id; #
my $form = $ref->_read_form(40000,{enc=>'utf8'});
$ref->ret_err({}) unless ( $form->{'post_content'} =~ m!$ref->{to}! || $form->{'post_content'} =~ m!(?:タイトル|著者)[:：].+! );
# for http signature
$ref->ret_err({code=>'401'}) if $ENV{'REQUEST_METHOD'} ne 'POST';
$ref->ret_err({code=>'401'}) if ! $ref->verify_signature({});
print "Status:200 OK\n\n";
# for get json
my $content = $ref->parse_json({content=>$form->{'post_content'}});
exit if ! $content;
# for seach sql
my $result = $ref->bookinfo({content=>$content});
# for post activity
my $posted = $ref->post_actpb({url=>$ref->{to} . '/inbox',content=>$ref->make_create({content=>$result})});
exit;
package reference;
use JSON;
use DBI;
use Crypt::Perl::RSA::Parse;
use Digest::SHA qw(sha256 sha256_base64 hmac_sha256 hmac_sha256_base64);
use MIME::Base64;
use LWP::UserAgent;
use UUID::Tiny;
use base qw( siteutil );
use vars qw( $dbh );
sub new{
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $args = shift;
my ( $obj ) = bless {
root=>'/bookshelf',
db_path => '/db/',
dbname=>'00001',
ap_url=>'https://bookshelf.doncha.net/',
actor=>'librarian',
keyid=>'https://bookshelf.doncha.net/librarian#main-key',
# only bookshelf owner
to=>'https://tokoroten.doncha.net/t2aki',
to_name=>'@t2aki@tokoroten.doncha.net',
%$args,
@_
}, $class;
if( $dbh eq '' ){
$obj->connect_db;
}
return $obj;
}
sub DESTROY {
my $self = shift;
$dbh->disconnect;
exit;
}
####
sub vacuum_db{
my $self = shift;
$dbh->do('VACUUM');
return;
}
sub connect_db{
my $self = shift;
my $dbname = (shift || $self->{dbname});
$dbname = $self->{root} . $self->{db_path} . $dbname . '.sqlite';
$dbh = DBI->connect( "dbi:SQLite:dbname=$dbname","","",{ RaiseError => 1, AutoCommit=>1 });
if( ! $dbh ) { die 'cannot connect db'; }
return $dbh;
}
sub disconnect_db{
my $self = shift;
return if ! $dbh;
$dbh->disconnect;
undef $dbh;
}
###
sub execute_sql{
my $self = shift;
my $sql = shift;
return if ! $sql;
eval {
my $sth = $dbh->prepare($sql);
my $r = $sth->execute;
};
if( $@ ){
print qq{<Content-type:text/html\n\n><html><body>};
print '<br /> Unable execute....' . $sql;
print qq{</body></html>};
exit;
}
return;
}
sub select_data{
my $self = shift;
my $sql = shift;
my $cols = shift;
return if ! $sql;
my $sth; my $r;
eval{
$sth = $dbh->prepare($sql);
$r = $sth->execute;
};
if( $@ ){
open(LOG,'>>','_check.log');
printf LOG qq{%s\n<br />%s},$sql, $@;
close(LOG);
exit;
}
$cols= $sth->{NAME} if ! $cols;
my @buf;
while( my $p = $sth->fetchrow_arrayref){
my %h;
map{$_ = $self->touch_decode($_)} @{$p};
map{$_ =~ s/\'\'/\'/g;} @{$p}; # for sqlite escape
@h{ @{$cols} } = @{$p};
push(@buf, \%h);
}
return \@buf;
}
###
sub make_create{
my $self = shift;
my $args = shift;
return if ! $args->{content};
my ($sec,$mi,$h, $d,$m,$y) = (gmtime(time))[0..5]; ++$m; $y+=1900;
my $datetime = sprintf qq{%s-%02d-%02dT%02d:%02d:%02dZ}, $y,$m,$d, $h,$mi,$sec;
my $uuid = create_UUID_as_string(UUID_V1);
my $cid = sprintf qq{%s%s/activity/%s}, $self->{ap_url},$self->{actor}, $uuid;
my $oid = sprintf qq{%s%s/item/%s}, $self->{ap_url},$self->{actor}, $uuid;
my $ref = {
'@context'=>[
"https://www.w3.org/ns/activitystreams",
{'Hashtag'=>'as:Hashtag'},
"https://w3id.org/security/v1"
],
'type'=>'Create',
'id'=>$cid,
'url'=>$cid,
'published'=>$datetime,
'actor'=>$self->{ap_url} . $self->{actor},
'to'=>[$self->{to}],
'cc'=>[],
'object'=>{
'type'=>'Note',
'id'=>$oid,
'url'=>$oid,
'published'=>$datetime,
'to'=>[$self->{to}],
'cc'=>[],
'attributedTo'=>$self->{ap_url} . $self->{actor},
'content'=>$args->{content},
'tag'=>[
{
'href'=>$self->{ap_url} . $self->{actor},
'name'=>$self->{to_name},
'type'=>'Mention'
}
]
},
};
my $json = JSON->new->canonical(1)->utf8(1)->indent(0)->space_before(0)->space_after(0)->encode($ref);
return $json;
}
###
sub post_actpb{
my $self = shift;
my $args = shift;
return if ! $args->{url};
return if ! $args->{content};
my $url = $args->{url}; $url =~ s!/$!!;
my $res;
my $req;
if( $args->{ver} ){
if( $args->{ver} eq 'RFC9421' ){
$req = $self->signature_RFC9421({url=>$url,content=>$args->{content}});
}
elsif( $args->{ver} eq 'legacy' ){
$req = $self->signature_legacy({url=>$url,content=>$args->{content}});
}
$res = $self->_request({req=>$req});
}
else{
# 1st HTTP Signature RFC9421
$res = $self->_request({req=>$self->signature_RFC9421({url=>$url,content=>$args->{content}})});
# 2nd HTTP Signature legacy
if( ! $res->is_success ){
undef $res;
$res = $self->_request({req=>$self->signature_legacy({url=>$url,content=>$args->{content}})});
}
}
if( ! $res->is_success ){
printf qq{ERROR get_actpb : %s}, $url;
}
return $res;
}
sub get_actpb{
my $self = shift;
my $args = shift;
return if ! $args->{url};
my $url = $args->{url};
if( ref($url) =~ m!(ARRAY|Hash)! ){
print $url;
print $args->{filename};
return;
}
$url =~ s!\#main\-key!!;
$url =~ s!/$!!;
my $res;
my $req;
if( $args->{ver} ){
if( $args->{ver} eq 'RFC9421' ){
$req = $self->signature_RFC9421({method=>'GET',url=>$url,accept=>'application/activity+json',auth=>$args->{auth}});
}
elsif( $args->{ver} eq 'legacy' ){
$req = $self->signature_legacy({method=>'GET',url=>$url,accept=>'application/activity+json',auth=>$args->{auth}});
}
$res = $self->_request({req=>$req});
}
else{
# 1st HTTP Signature RFC9421
$res = $self->_request({req=>$self->signature_RFC9421({method=>'GET',url=>$url,accept=>'application/activity+json',auth=>$args->{auth}})});
# 2nd HTTP Signature legacy
if( ! $res->is_success ){
undef $res;
$res = $self->_request({req=>$self->signature_legacy({method=>'GET',url=>$url,accept=>'application/activity+json',auth=>$args->{auth}})});
}
}
if( ! $res->is_success ){
printf qq{ERROR get_actpb : %s}, $url;
return;
}
return $res->decoded_content; #gzip 対応
}
sub _request{
my $self = shift;
my $args = shift;
return if ! $args->{req};
my $ua = LWP::UserAgent->new(agent=>'http.pl/5.38 (bookshelf/0.1.0; +https://bookshelf.doncha.net/)');
$ua->timeout( $self->{timeout} );
my $res;
eval{
local $SIG{ALRM} = sub{die "timeout";};
alarm $self->{timeout};
$res = $ua->request($args->{req});
alarm 0;
};
alarm 0;
if( $@ ){
printf qq{ERROR _request: %s},$@;
return;
}
return $res;
}
###
sub sign{
my $self = shift;
my $args = shift;
return if ! $args->{signature_base};
my $buf = $self->select_data(qq{select private_key from KEYS});
my $priv = Crypt::Perl::RSA::Parse::private($buf->[0]{private_key});
my $sign = $priv->sign_RS256($args->{signature_base});
return encode_base64($sign, "");
}
sub verify_signature{
my $self = shift;
my $args = shift;
my $item = $self->prepare_verify_signature({});
if( ! $item ){
printf qq{ERROR verify signature: %s\n}, $args->{logfile} unless $self->{script} =~ m!tameike\-pool\.pl!;
return;
}
my $pub = $item->{pubkey};
my $publickey = Crypt::Perl::RSA::Parse::public($pub);
my $decoded = decode_base64($item->{signature});
return $publickey->verify_RS256($item->{signature_base}, $decoded);
}
sub prepare_verify_signature{
my $self = shift;
my $args = shift;
my $http_ref = $self->parse_http_env({});
if( ! $http_ref->{sig}->{keyid} ){
return;
}
my $req; my $ver;
if( ! $http_ref->{http}->{'signature-input'}){
$req = $self->signature_legacy({url=>$http_ref->{sig}->{keyid}, content=>'', method=>'GET',accept=>'application/activity+json'});
$ver = 'legacy';
}
else{
$req = $self->signature_RFC9421({url=>$http_ref->{sig}->{keyid}, content=>'', method=>'GET',accept=>'application/activity+json'});
$ver = 'RFC9421';
}
my $content = $self->get_actpb({url=>$http_ref->{sig}->{keyid}, req=>$req, ver=>$ver});
if( ! $content ){
printf qq{prepare verify No content: %s}, $http_ref->{sig}->{keyid} unless $self->{script} =~ m!tameike\-pool\.pl!;
return;
}
my $json;
eval{ $json = decode_json($content) };
if($@){
printf qq{prepare verify Json ERROR: %s<br/>\n%s}, $http_ref->{sig}->{keyid}, $@ unless $self->{script} =~ m!tameike\-pool\.pl!;
return;
}
my $base = $self->_make_signature_base({sig=>$http_ref->{sig}, http=>$http_ref->{http}});
if(! $base ){
printf qq{prepare verify No Signature base: %s<br/>\n%s}, $http_ref->{sig}->{keyid}, $@ unless $self->{script} =~ m!tameike\-pool\.pl!;
return;
}
return {signature=>$http_ref->{sig}->{signature}, signature_base=>$base,pubkey=>$json->{publicKey}->{publicKeyPem}};
}
sub parse_http_env{
my $self = shift;
my $args = shift;
my $env = ( $args->{env} || \%ENV );
my $http;
foreach (keys %{$env}){
my $k = $_;
$k =~ s!^HTTP_!!; $k =~ s!^REQUEST_!!; $k =~ tr/A-Z/a-z/; $k =~ s!_!-!g;
$http->{$k} = $env->{$_};
}
my $sig;
foreach my $k (keys %{$http} ){
if( $k eq 'signature' ){
$sig->{sign} = $http->{$k};
}
elsif( $k eq 'signature-input' ){
$sig->{base} = $http->{$k};
}
}
if( ! $sig->{base} ){
my @buf = split(',', $sig->{sign});
foreach (@buf){
my ($k,$v) = split('='); $v =~ s!^"!!; $v =~ s!"$!!;
if( $k =~ m!keyId!i ){
$sig->{keyid} = $v;
}
elsif( $k =~ m!^alg! ){
$sig->{alg} = $v;
}
elsif( $k =~ m!signature! ){
$sig->{signature} = $v;
}
elsif( $k =~ m!headers! ){
$sig->{headers} = $v;
}
}
foreach my $k ( split(' ', $sig->{headers}) ){
$sig->{$k} = $http->{$k};
}
}
else{
my @buf = split(';', $sig->{base});
foreach (@buf){
my($k,$v) = split('='); $v =~ s!^"!!; $v =~ s!"$!!;
if( $k =~ m!keyid!i ){
$sig->{keyid} = $v;
}
elsif( $k =~ m!alg! ){
$sig->{alg} = $v;
}
elsif( $k =~ m!created! ){
$sig->{created} = $v;
}
elsif( $k =~ m!sig\d! ){
$sig->{params} = $v;
}
}
# legacyに合わせて%$sigのsignatureに入れておく
$sig->{signature} = $http->{'signature'}; $sig->{signature} =~ s!sig\d=:!!; $sig->{signature} =~ s!:$!!;
}
return {sig=>$sig, http=>$http};
}
# for verify signature base
sub _make_signature_base{
my $self = shift;
my $args = shift;
my $base;
if( $args->{sig}->{headers} ){
my @buf;
foreach (split(' ', $args->{sig}->{headers})){
if( $_ eq '(request-target)' ){
$args->{http}->{method} =~ tr/A-Z/a-z/;
push(@buf, sprintf(qq{%s: %s %s},$_, $args->{http}->{method}, $args->{http}->{uri}));
}
else{
push(@buf, sprintf(qq{%s: %s},$_, $args->{http}->{$_}));
}
}
$base = join("\n", @buf);
}
else{
my @buf;
$args->{sig}->{params} =~ s!^\(!!; $args->{sig}->{params} =~ s!\)$!!;
my @params = split(' ',$args->{sig}->{params});
foreach my $k ( @params ){
$k =~ s!^"!!; $k =~ s!"$!!;
if($args->{http}->{$k}){
push(@buf, sprintf(qq{"%s": %s},$k, $args->{http}->{$k}));
next;
}
push(@buf, sprintf(qq{"%s": %s},$k, $args->{http}->{method})) , next if $k eq '@method';
push(@buf, sprintf(qq{"%s": %s},$k, $args->{http}->{host})), next if $k eq '@authority';
push(@buf, sprintf(qq{"%s": %s://%s%s},$k, $args->{http}->{scheme},$args->{http}->{host}, $args->{http}->{uri})), next if $k eq '@target-uri';
push(@buf, sprintf(qq{"%s": %s://%s%s},$k, $args->{http}->{scheme},$args->{http}->{host}, $args->{http}->{uri})), next if $k eq '@request-target';
}
if(scalar(@buf) != scalar(@params)){
printf qq{_make signature base: buf:%s params:%s\n}, scalar(@buf), scalar(@params);
return;
}
my $sig_base = $args->{sig}->{base}; $sig_base =~ s!sig\d=!!;
push(@buf, sprintf( qq{"\@signature-params": %s}, $sig_base));
$base = join("\n", @buf);
}
return $base;
}
###
sub signature_legacy{
my $self = shift;
my $args = shift;
return if ! $args->{url};
my $method = ($args->{method} || 'POST');
my $url = $args->{url}; $url =~ s!^"!!; $url =~ s!"$!!; $url =~ s!/$!!;
my $content;
if( $args->{content} ){
$content = $args->{content};
$content = Encode::encode('utf8', $content) if Encode::is_utf8($content);
}
my $accept = $args->{accept}; # for get request
my $req = HTTP::Request->new($method=>$url);
$req->content_type('application/activity+json');
my @items;
if( $method eq 'GET'){
@items = ('(request-target)','host','date');
}
else{
@items = ('(request-target)','host','date','digest','content-type');
}
my $host = $url; $host =~ s!^"!!; $host =~ s!"$!!; $host =~ s!^https://!!; $host =~ s!/.+$!!;
my ($target) = $url =~ m!$host(.+)!;
$target = sprintf qq{%s %s}, $method, $target; $target =~ tr/A-Z/a-z/;
$req->headers->date(time);
my $digest = encode_base64(sha256($content),"") if $content;
my $item;
$item->{'(request-target)'} = $target;
$item->{'host'} = $host;
$item->{'date'} = $req->headers->header('date');
$item->{'digest'} = 'SHA-256=' . $digest if $content;
$item->{'content-type'} = 'application/activity+json' if $content;
my @buf1;
foreach (@items){
push(@buf1, sprintf(qq{%s: %s},$_,$item->{$_}));
}
my $base = join("\n", @buf1);
my $signature = $self->sign({signature_base=>$base});
my $keyid = $self->{keyid};
my $params = sprintf qq{keyId="%s",algorithm="rsa-sha256",headers="%s",signature="%s"},
$keyid,join(' ', @items), $signature;
$req->headers->push_header('Signature'=>$params);
$req->headers->push_header('Digest'=>'SHA-256=' . $digest) if $content;
$req->headers->push_header('host'=>$host);
$req->headers->push_header('Accept'=>$accept) if $accept;
$req->headers->push_header('Authorization'=>$args->{auth}) if $args->{auth};
$req->content($content) if $content;
return $req;
}
###
sub signature_RFC9421{
my $self = shift;
my $args = shift;
return if ! $args->{url};
my $method = ($args->{method} || 'POST');
my $url = $args->{url}; $url =~ s!^"!!; $url =~ s!"$!!; $url =~ s!/$!!;
my @items;
if( $method eq 'GET' ){
@items = ('@target-uri','host','date');
}
else{
@items = ('@method','@target-uri','content-digest');
}
my $content;
if( $args->{content} ){
$content = $args->{content};
$content = Encode::encode('utf8', $content) if Encode::is_utf8($content);
}
my $accept = $args->{accept}; # for get request
my $req = HTTP::Request->new($method=>$url);
$req->content_type('application/activity+json');
my $host = $url; $host =~ s!^https://!!; $host =~ s!/.+$!!;
$req->headers->date(time);
my $digest = encode_base64(sha256($content),"") if $content;
my $item;
$item->{'@method'} = $method;
$item->{'@authority'} = $host;
$item->{'@target-uri'} = $url;
$item->{'@request-target'} = $url;
$item->{'content-digest'} = 'sha-256=:' . $digest . ':' if $content;
$item->{'host'} = $host;
$item->{'date'} = $req->headers->header('date');
my @buf0;
foreach (@items){
push(@buf0, sprintf qq{"%s"}, $_);
}
my $keyid = $self->{keyid};
my $params = sprintf qq{(%s);alg="rsa-v1_5-sha256";keyid="%s";created=%s}, join(' ',@buf0), $keyid, (time);
my @buf1;
foreach (@items){
push(@buf1, sprintf(qq{"%s": %s},$_,$item->{$_}));
}
my $base = join("\n", @buf1) . "\n" . '"@signature-params": ' . $params;
my $signature = $self->sign({signature_base=>$base});
$req->headers->push_header('Signature'=>'sig1=:'. $signature . ':');
$req->headers->push_header('Signature-Input'=>'sig1=' . $params);
$req->headers->push_header('Content-Digest'=>'sha-256=:' . $digest . ':') if $content;
$req->headers->push_header('host'=>$host);
$req->headers->push_header('Accept'=>$accept) if $accept;
$req->headers->push_header('Authorization'=>$args->{auth}) if $args->{auth};
$req->content($content) if $content;
return $req;
}
###
sub parse_json{
my $self = shift;
my $args = shift;
return if ! $args->{content};
my $content = Encode::encode('utf8',$args->{content});
$content =~ s!\r?\n!!g;
my $json;
eval{ $json = decode_json($content); };
if( $@ ){
return;
}
unless( $json->{object}->{attributedTo} =~ m!$self->{to}! ){
return;
}
return $json->{object}->{content};
}
#
sub bookinfo{
my $self = shift;
my $args = shift;
return if ! $args->{content};
my ($title) = $args->{content} =~ m!タイトル[:：](.+)!;
my ($author) = $args->{content} =~ m!著者[:：](.+)!;
$title =~ s!^ *!!; $title =~ s! *$!!; $title =~ s![;:\'=<>]!!;
$author =~ s!^ *!!; $author =~ s! *$!!; $author =~ s![;:\'=<>]!!;
my $sql;
if($title && $author){
$sql = qq{select books_list.title,authors_list.author,books_memo.comment,books_list.ymd,books_list.readed from books_list
inner join authors_list on books_list.bookid = authors_list.bookid
left outer join books_memo on books_list.bookid = books_memo.bookid
where books_list.title like '%$title%' and authors_list.author like '%$author%'};
}
elsif( $title ){
$sql = qq{select books_list.title,authors_list.author,books_memo.comment,books_list.ymd,books_list.readed from books_list
inner join authors_list on books_list.bookid = authors_list.bookid
left outer join books_memo on books_list.bookid = books_memo.bookid
where books_list.title like '%$title%'};
}
elsif( $author ){
$sql = qq{select books_list.title,authors_list.author,books_memo.comment,books_list.ymd,books_list.readed from books_list
inner join authors_list on books_list.bookid = authors_list.bookid
left outer join books_memo on books_list.bookid = books_memo.bookid
where authors_list.author like '%$author%'};
}
my $buf;
if( $sql ){
$buf = $self->select_data($sql);
}
my @list;
my $info;
if( $buf ){
my $zzz;
foreach ( @{$buf} ){
push(@list, $_->{title}) if ! $zzz->{$_->{title}}++;
if( ! $zzz->{$_->{author}}++ ){
$info->{$_->{title}}->{author} .= sprintf qq{%s\t}, $_->{author};
}
if( $_->{comment} ){
$info->{$_->{title}}->{comment} .= sprintf qq{%s\t}, $_->{comment};
}
$info->{$_->{title}}->{readed} = $_->{readed};
}
}
my $res;
if(@list){
foreach (@list){
$info->{$_}->{author} =~ s!\t$!!; $info->{$_}->{author} =~ s!\t!:!g;
$info->{$_}->{comment} =~ s!\t$!!; $info->{$_}->{comment} =~ s!\t!<br/>--------------<br/>!g; $info->{$_}->{comment} =~ s!\r?\n!<br/>!g;
$res .= sprintf qq{%s<br/>%s『%s』%s},
$info->{$_}->{author}, $info->{$_}->{readed} ? '[既]':'[未]', $_,
$info->{$_}->{comment} ? sprintf(qq{<br/>%s<br/>}, $info->{$_}->{comment}) : '';
}
}
else{
$res = sprintf qq{登録はありません};
}
return $res;
}
sub check_key_id{
my $self = shift;
my $args = shift;
my $keyid;
if( $ENV{HTTP_SIGNATURE_INPUT} ){
($keyid) = $ENV{HTTP_SIGNATURE_INPUT} =~ m!keyid="([^"]+)"!;
}
else{
($keyid) = $ENV{HTTP_SIGNATURE} =~ m!keyId="([^"]+)"!;
}
unless( $keyid =~ m!$self->{to}! ){
$self->ret_err({});
}
return;
}
#
sub ret_err{
my $self = shift;
my $args = shift;
my $code = ( $args->{code} || 404 );
my $response = {401=>'Unauthorized', 403=>'Forbidden', 404=>'Not Found',410=>'gone'};
printf qq{Status: %s %s\n\n}, $code, $response->{$code};
exit;
}
#
sub _read_form{
my $self = shift;
my $limit = shift;
my $opt = shift;
my($buf,$form_name, $form_value, $pair,@pairs);
my %form;
my %zzz;
my $post_content;
if( $ENV{'REQUEST_METHOD'} eq 'POST' ){
read(STDIN, $buf, $ENV{'CONTENT_LENGTH'});
# 2025-03-18 08:32:49
# POST の場合、FORMデータ(本文)に「key=value&key=value」のような文字列のことがあるので「=」でsplitしてkey valueを取得するのが定番
# だけど、Activityの場合は、ActivityのJSONだけなのでバラすフェーズはスキップしてここでreturnする
$buf = Encode::decode('utf8', $buf) if ! Encode::is_utf8($buf);
$form{'post_content'} = $buf if( $buf );
return \%form;
}
else{
$buf = $ENV{'QUERY_STRING'};
}
@pairs = split(/&/,$buf);
foreach $pair (@pairs){
($form_name, $form_value) = split(/=/,$pair);
$form_value =~ tr/+/ /;
$form_value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
my $enc;
if( $opt->{enc} ){
$enc = $opt->{enc};
}
else{
my $guess = Encode::Guess->guess($form_value);
$enc = ref($guess) ? $guess->name : 'utf8';
}
$form_value = Encode::encode('utf8',Encode::decode($enc, $form_value));
$form_name = Encode::decode('utf8', $form_name) if ! Encode::is_utf8($form_name);
$form_value = Encode::decode('utf8', $form_value) if ! Encode::is_utf8($form_value);
$form_value =~ s/\x0D\x0A/\n/g;
$form_value =~ s/\x0D/\n/g;
$form_value =~ s/\</\</g;
$form_value =~ s/\>/\>/g;
$form_name =~ s!\t!_TAB_!g;
$form_value =~ s!\t!_TAB_!g;
if( ! $zzz{$form_name}++ ){
$form{$form_name} = $form_value;
}
else{
$form{$form_name} .= "\t" . $form_value;
}
}
return \%form;
}