kimarx/gist:1539192

## gistfile1.pl
#!/usr/bin/perl
use strict;
use warnings;
use utf8;

package CGI::Upie;
use Mouse;
use CGI::Carp qw( fatalsToBrowser );
use CGI::Simple;
use DBI;
use Encode qw( encode decode :fallbacks );
use Text::Xslate qw( mark_raw );
use XML::FeedPP;

has 'base_uri' => ( is => 'rw',
                    isa => 'Str', );

has 'absolute_root_path' => ( is => 'rw',
                              isa => 'Str', );

has 'this_cgi_name' => ( is => 'rw',
                         isa => 'Str', );

has 'max_post_size' => ( is      => 'rw',
                         isa     => 'Int',
                         default => 200 * 1024 * 1024, );

has 'max_total_size' => ( is      => 'rw',
                          isa     => 'Int',
                          default => 20 * 1024 * 1024 * 1024, );

has 'master_key' => ( is => 'rw',
                      isa => 'Str', );

has 'template_file' => ( is  => 'rw',
                         isa => 'Str', );

has 'rss_file' => ( is => 'rw',
                    isa => 'Str', );

has 'upload_dir' => ( is  => 'rw',
                      isa => 'Str', );

has 'db_file' => ( is  => 'rw',
                   isa => 'Str', );

has 'list_max' => ( is      => 'rw',
                    isa     => 'Int',
                    default => 10, );

has 'html_title' => ( is  => 'rw',
                      isa => 'Str', );


sub run {
  my $self = shift;

  $CGI::Simple::POST_MAX = $self->max_post_size;
  $CGI::Simple::DISABLE_UPLOADS = 0;

  my $q = CGI::Simple->new;


  # upload process
  my $this_location = $self->base_uri . $self->this_cgi_name;
  if ( ( $q->param( 'upload_file' ) ne '' )
         && ( $q->param( 'comment' ) ne '' ) ) {

    # POST method?
    my $bad_request = "<html><body><h1>不正なアクセスです</h1></body></html>";
    $self->error_message( $bad_request ) if $q->param( 'submit' ) ne 'UPLOAD';

    $self->register( $q );
    $self->save_as_rss;
    print $q->redirect( $this_location );
    exit;
  } elsif ( $q->param( 'request' ) eq 'DEL' ) {
    $self->delete_process( $q->param( 'key' ), $q->param( 'id' ) );
  } else {
    $self->output( $q );
    exit;
  }
}

sub error_message {
  my ( $self, $str ) = @_;

  my $q = CGI::Simple->new();
  print $q->header( -type => 'text/html',
                    -charset => 'utf-8', );
  print encode( 'utf8', $str );
  exit;
}

sub delete_process {
  my ( $self, $key, $del_id ) = @_;

  $key = decode( 'utf8', $key );

  my $miss_key = "<html><body><h1>KEY がないと削除できません</h1></body></html>";
  $self->error_message( $miss_key ) if $key eq '';

  my $req = qq| SELECT id, delete_key, path FROM t_upfile_list WHERE id = ? LIMIT 1 |;

  my $dbh = $self->connect_sql;
  my $arry_ref = $dbh->selectrow_arrayref( $req, undef, $del_id );
  my ( $id, $delete_key, $path ) = @$arry_ref;

  $path =~ s/^\.//;
  $path = $self->absolute_root_path . $path;

  if ( ( $key ne $delete_key ) && ( $key ne $self->master_key ) ) {
    $dbh->disconnect;

    my $wrong_key = "<html><body><h1>KEY がちがうみたいです</h1></body></html>";
    $self->error_message( $wrong_key );
  } else {

    # delete the file.
    if ( unlink $path ) {

      my $del_req = "DELETE FROM t_upfile_list WHERE id = ? ";
      $dbh->do( $del_req, undef, $del_id );
      $dbh->disconnect;

      # revise the rss file
      $self->save_as_rss;

      my $this_location = $self->base_uri . $self->this_cgi_name;
      my $q = CGI::Simple->new;
      print $q->redirect( $this_location );
      exit;
    } else {
      $dbh->disconnect;

      my $failure = "<html><body><h1>削除に失敗してしまいました。。。</h1></body></html>";
      $self->error_message( $failure );
    }
  }
}

sub register {
  my ( $self, $q ) = @_;

  my $ip = $q->remote_addr();
  my $hostname = $self->get_host_by_addr( $ip );

  # sanitizing query parameters.
  my ( $comment, $delete_key ) = $self->sanitize( $q );

  # get an uploaded file.
  my ( $tag, $file_size, $upload_path ) = $self->upload_process( $q );

  my $file_name = '';
  $file_name = $1 if $upload_path =~ /\/([a-zA-Z0-9]+\.[a-zA-Z0-9]+)$/;

  my $date = $self->get_date; # get date.

  # encode in UTF-8
  # $comment = encode( 'utf8', $comment );

  my $dbh = $self->connect_sql;

  my $req = qq| INSERT INTO t_upfile_list |;
  $req .= qq| ( file_name, comment, date, delete_key, tag, file_size, path ) |;
  $req .= qq| VALUES( ?, ?, ?, ?, ?, ?, ? ) |;

  my $sth = $dbh->prepare( $req );
  $sth->execute( $file_name, $comment, $date, $delete_key,
                 $tag, $file_size, $upload_path );

  $dbh->disconnect;

  return 0;
}

sub get_date {
  my $self = shift;

  use Time::Piece;
  my $t = localtime;
  my $date = $t->strftime( '%FT%T' );

  return $date;
}

sub connect_sql {
  my $self = shift;

  my $db_file = $self->absolute_root_path . '/' . $self->db_file;


  my $dbh = DBI->connect( "dbi:SQLite:dbname=$db_file", "", "",
                          {
                            RaiseError     => 1,
                            sqlite_unicode => 1,
                          }
                        );

  return $dbh;
}

sub get_host_by_addr {
  my ( $self, $ip ) = @_;

  my @addr = split(/\./, $ip);
  my $packed_ip = pack("C4", $addr[0], $addr[1], $addr[2], $addr[3]);
  my $hostname = gethostbyaddr($packed_ip, 2);

  return $hostname;
}

sub upload_process {
  my ( $self, $q ) = @_;

  my $up_file = $q->param( 'upload_file' );
  my $mime = $q->upload_info( $up_file, 'mime' );
  my $file_size = $q->upload_info( $up_file, 'size' );

  my $extension = '';
  $extension = $1 if $up_file =~ /.+\.([a-zA-Z0-9-]+)$/;

  my $tag = '';
  if ( $mime =~ /^image\/((gif|jpeg|jpg|png))$/ ) {
    $extension = $1 if $extension eq '';
    $tag = 'image';
  } elsif ( $mime =~ /^audio\/((mp3|x-mp3|mpg|x-mpg|mpeg|x-mpeg|wav|x-wav))$/ ) {
    $extension = $1 if $extension eq '';
    $extension =~ s/^x-//;
    $tag = 'audio';
  } elsif ( $mime =~ /^video\/((mpg|mpeg|mp4|flv|x-flv))$/ ) {
    $extension = $1 if $extension eq '';
    $extension =~ s/^x-//;
    $tag = 'video';
  } else {
    my $caution = "<html><body><h1>このファイル形式は受け付けていません: $mime</h1></body></html>";
    $self->error_message( $caution );
  }

  my $unix_time = time();
  my $uploaded_file_name = $unix_time . '.' . $extension;
  my $save_path = $self->upload_dir . '/' . $tag . '/' . $uploaded_file_name;

  # convert this relational path into the absolute path
  # for mod_perl.
  my $absolute_save_path = '';
  $absolute_save_path = $1 if $save_path =~ /^\.(.+)$/;
  $absolute_save_path = $self->absolute_root_path . $absolute_save_path;

  my $ok = $q->upload( $up_file, $absolute_save_path );
  if ( $ok ) {
    return ( $tag, $file_size, $save_path );
  } else {
    my $failure = "<html><body><h1>アップロードに失敗したようです</h1></body></html>";
    $self->error_message( $failure );
  }
}

sub sanitize {
  my ( $self, $q ) = @_;

  my %params = $q->Vars; # get query parameters.

  foreach ( %params ) {
    my $value = $q->escapeHTML( $params{$_} );
    $value =~ s/'/&#39;/g;
    $params{$_} = decode( 'utf8', $value );
  }

  my $comment = $params{ comment };
  my $delete_key = $params{ delete_key };

  if ( $delete_key ne '' ) {
    my $no_multibyte = "<html><body><h1>削除キーは半角英数字だけ OK です</h1></body></html>";
    $self->error_message( $no_multibyte )
      unless $delete_key =~ /^[a-zA-Z0-9]+$/;
  }

  return ( $comment, $delete_key );
}

sub output {
  my ( $self, $q ) = @_;

  my $page = 1;
  $page = $q->param( 'page' ) if $q->param( 'page' ) ne '';

  my $paging_html = $self->paging_html( $page );

  my @hash_refs = $self->make_list( $page );

  my $size_sum = $self->get_sum;
  my $limit_ok = 1;
  $limit_ok = 0 if $size_sum > $self->max_total_size;

  my $max_post_size = $self->nice_size( $self->max_post_size );
  my $max_total_size = $self->nice_size( $self->max_total_size );
  $size_sum = $self->nice_size( $size_sum );

  my $limitation_html = "最大 " . $max_post_size . " のファイルが";
  $limitation_html .= "アップロード可能です。<br>";
  $limitation_html .= "mpeg, mp4, flv, mp3, wav, jpg, png, gif のみ受け付けています。<br>";
  $limitation_html .= "合計 " . $max_total_size . " に達した時点で";
  $limitation_html .= "アップロード不可になる予定です。<br>";
  $limitation_html .= "現在、" . $size_sum . " 使用してしています。<br>";
  $limitation_html .= "投稿削除後変化がなければ、RELOAD ボタンを押してください。<br>";
  $limitation_html .= "β 版なので文字化けなど不具合があるかもです。";

  $limitation_html = "<span style='font: bold 1.5em sans-serif;'>もうお腹一杯です。。。</span>"
    if $limit_ok == 0;

  my $rss_file = $self->rss_file;
  $rss_file =~ s/^\.\///;
  my $rss_location = $self->base_uri . $rss_file;
  my $top_nav = qq| <a href="$rss_location">RSS</a> |;


  my $cache_dir = $self->absolute_root_path . '/.xslate_cache';
  my $tx = Text::Xslate->new( path      => $self->absolute_root_path,
                              cache_dir => $cache_dir, );


  my %vars = ( base       => $self->base_uri,
               rss        => $rss_location,
               cgi_name   => $self->this_cgi_name,
               top_nav    => mark_raw( $top_nav ),
               paging     => mark_raw( $paging_html ),
               limit_ok   => $limit_ok,
               limitation => mark_raw( $limitation_html ),
               title      => $self->html_title,
               up_list    => \@hash_refs, );


  my $tt_file = $self->template_file;
  my $content = $tx->render( $tt_file, \%vars );

  print "Content-Type: text/html; charset=UTF-8\n\n";
  print $content;
}

sub nice_size {
  my ( $self, $file_size ) = @_;

  my $fs;
  if ( $file_size < 1024 ) {
    $fs = $file_size . ' Bytes';
  } elsif ( $file_size < 1024 ** 2 ) {
    $fs = int( $file_size / 1024 ) . ' KB';
  } elsif ( $file_size < 1024 ** 3 ) {
    $fs = int( $file_size / ( 1024 ** 2 ) ) . ' MB';
  } elsif ( $file_size < 1024 ** 4 ) {
    $fs = int( $file_size / ( 1024 ** 3 ) ) . ' GB';
  }

  return $fs;
}


sub commify {
  my ( $self, $num_str ) = @_;
  $num_str = reverse $num_str;
  $num_str =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
  return scalar reverse $num_str;
}

sub make_list {
  my ( $self, $page ) = @_;

  my $end = $page * $self->list_max;
  my $offset = $end - $self->list_max;
  my $limit = $self->list_max;

  # pull data from database.
  my $req = qq| SELECT id, file_name, comment, date, file_size, path |;
  $req .= qq| FROM t_upfile_list ORDER BY id DESC |;
  $req .= qq| LIMIT ?, ? |;

  my $dbh = $self->connect_sql;
  my $sth = $dbh->prepare( $req );
  $sth->execute( $offset, $limit );

  my @hash_refs = ();
  while ( my $arry_ref = $sth->fetchrow_arrayref ) {
    my ( $id, $file_name, $comment, $date, $file_size, $path ) = @$arry_ref;

    $file_size = $self->commify( $file_size );

    if ( $path eq '' ) {
      next;
    } else {

      my $hash_ref = { id        => $id,
                       file_name => $file_name,
                       comment   => $comment,
                       date      => $date,
                       file_size => $file_size,
                       path      => $path, };

      push( @hash_refs, $hash_ref );
    }
  }

  $dbh->disconnect;

  return @hash_refs;
}

sub paging_html {
  my ( $self, $page ) = @_;

  # # get the last id.

  my $req = qq| SELECT file_name FROM t_upfile_list |;
  my $dbh = $self->connect_sql;
  my $sth = $dbh->prepare( $req );
  $sth->execute;

  my $row_num = 0;
  while ( my $arry_ref = $sth->fetchrow_arrayref ) {
    if ( $arry_ref ) {
      $row_num += 1;
    }
  }

  $dbh->disconnect;

  my $total_pages = int( ( $row_num - 1 ) / $self->list_max ) + 1;

  my $this_location = $self->base_uri . $self->this_cgi_name;
  my $paging_html;
  for ( my $i = 1; $i <= $total_pages; $i++ ) {
    if ( $i != $page ) {
      $paging_html .= qq| <a href="$this_location?page=$i">$i</a>&nbsp; |;
    } else {
      $paging_html .= qq| <span style="font-size: 1.25em;">$i</span>&nbsp; |;
    }
  }

  if ( ( $page * $self->list_max ) < $row_num ) {
    my $next_link = "$this_location?page=";
    $next_link .= $page + 1;
    $paging_html .= qq| <a rel="next" href="$next_link">Next</a>&nbsp; |;
  }

  # # DEBUG
  # $paging_html .= $row_num;

  return $paging_html;
}

sub get_sum {
  my $self = shift;

  my $dbh = $self->connect_sql;

  my $req = "SELECT file_size FROM t_upfile_list";

  my $sth = $dbh->prepare( $req );
  $sth->execute;

  my $total_size = 0;
  while ( my $arry_ref = $sth->fetchrow_arrayref ) {
    my ( $byte ) = @$arry_ref;
    $total_size += $byte;
  }

  $dbh->disconnect;

  return $total_size;
}

sub save_as_rss {
  my $self = shift;

  my $this_location = $self->base_uri . $self->this_cgi_name;
  my $feed = XML::FeedPP::RSS->new ( title => $self->html_title,
                                     link => $this_location, );

  my $req = 'SELECT file_name, comment, tag, file_size, path FROM t_upfile_list ';
  $req .= 'ORDER BY id DESC LIMIT ' . $self->list_max;
  my $dbh = $self->connect_sql;
  my $sth = $dbh->prepare( $req );
  $sth->execute;

  while ( my $arry_ref = $sth->fetchrow_arrayref ) {
    my ( $file_name, $comment, $tag, $file_size, $path ) = @$arry_ref;

    $path =~ s/^\.\///;
    my $full_path = $self->base_uri . $path;

    my $type = $tag . '/';
    $type .= $1 if $file_name =~ /\.([a-zA-Z0-9]+)$/;
    $type =~ s/jpg/jpeg/i;

    my $item = $feed->add_item( $full_path );
    $item->title( $comment );
    my $enclosure = {
      'enclosure@url'    => $full_path,
      'enclosure@length' => $file_size,
      'enclosure@type'   => $type,
    };
    $item->set( %$enclosure );

  }

  my $rss_path = $self->absolute_root_path . '/' . $self->rss_file;

  $feed->to_file( $rss_path );
}


# -------------

package main;

my $base_uri = '';
my $absolute_root_path = '';
my $this_cgi_name = 'pie.cgi';
my $master_key = '';
my $template_file = 'upie.tx';
my $rss_file = 'upie.rss';
my $upload_dir = './up';
my $db_file = '';
my $title = '';

my $upie = CGI::Upie->new( base_uri           => $base_uri,
                           absolute_root_path => $absolute_root_path,
                           this_cgi_name      => $this_cgi_name,
                           master_key         => $master_key,
                           template_file      => $template_file,
                           rss_file           => $rss_file,
                           upload_dir         => $upload_dir,
                           db_file            => $db_file,
                           html_title         => $title, );

$upie->run;

# last modified: 2011-12-30 19:16+09:00.
	#!/usr/bin/perl
	use strict;
	use warnings;
	use utf8;

	package CGI::Upie;
	use Mouse;
	use CGI::Carp qw( fatalsToBrowser );
	use CGI::Simple;
	use DBI;
	use Encode qw( encode decode :fallbacks );
	use Text::Xslate qw( mark_raw );
	use XML::FeedPP;

	has 'base_uri' => ( is => 'rw',
	isa => 'Str', );

	has 'absolute_root_path' => ( is => 'rw',
	isa => 'Str', );

	has 'this_cgi_name' => ( is => 'rw',
	isa => 'Str', );

	has 'max_post_size' => ( is => 'rw',
	isa => 'Int',
	default => 200 * 1024 * 1024, );

	has 'max_total_size' => ( is => 'rw',
	isa => 'Int',
	default => 20 * 1024 * 1024 * 1024, );

	has 'master_key' => ( is => 'rw',
	isa => 'Str', );

	has 'template_file' => ( is => 'rw',
	isa => 'Str', );

	has 'rss_file' => ( is => 'rw',
	isa => 'Str', );

	has 'upload_dir' => ( is => 'rw',
	isa => 'Str', );

	has 'db_file' => ( is => 'rw',
	isa => 'Str', );

	has 'list_max' => ( is => 'rw',
	isa => 'Int',
	default => 10, );

	has 'html_title' => ( is => 'rw',
	isa => 'Str', );


	sub run {
	my $self = shift;

	$CGI::Simple::POST_MAX = $self->max_post_size;
	$CGI::Simple::DISABLE_UPLOADS = 0;

	my $q = CGI::Simple->new;


	# upload process
	my $this_location = $self->base_uri . $self->this_cgi_name;
	if ( ( $q->param( 'upload_file' ) ne '' )
	&& ( $q->param( 'comment' ) ne '' ) ) {

	# POST method?
	my $bad_request = "<html><body><h1>不正なアクセスです</h1></body></html>";
	$self->error_message( $bad_request ) if $q->param( 'submit' ) ne 'UPLOAD';

	$self->register( $q );
	$self->save_as_rss;
	print $q->redirect( $this_location );
	exit;
	} elsif ( $q->param( 'request' ) eq 'DEL' ) {
	$self->delete_process( $q->param( 'key' ), $q->param( 'id' ) );
	} else {
	$self->output( $q );
	exit;
	}
	}

	sub error_message {
	my ( $self, $str ) = @_;

	my $q = CGI::Simple->new();
	print $q->header( -type => 'text/html',
	-charset => 'utf-8', );
	print encode( 'utf8', $str );
	exit;
	}

	sub delete_process {
	my ( $self, $key, $del_id ) = @_;

	$key = decode( 'utf8', $key );

	my $miss_key = "<html><body><h1>KEY がないと削除できません</h1></body></html>";
	$self->error_message( $miss_key ) if $key eq '';

	my $req = qq\| SELECT id, delete_key, path FROM t_upfile_list WHERE id = ? LIMIT 1 \|;

	my $dbh = $self->connect_sql;
	my $arry_ref = $dbh->selectrow_arrayref( $req, undef, $del_id );
	my ( $id, $delete_key, $path ) = @$arry_ref;

	$path =~ s/^\.//;
	$path = $self->absolute_root_path . $path;

	if ( ( $key ne $delete_key ) && ( $key ne $self->master_key ) ) {
	$dbh->disconnect;

	my $wrong_key = "<html><body><h1>KEY がちがうみたいです</h1></body></html>";
	$self->error_message( $wrong_key );
	} else {

	# delete the file.
	if ( unlink $path ) {

	my $del_req = "DELETE FROM t_upfile_list WHERE id = ? ";
	$dbh->do( $del_req, undef, $del_id );
	$dbh->disconnect;

	# revise the rss file
	$self->save_as_rss;

	my $this_location = $self->base_uri . $self->this_cgi_name;
	my $q = CGI::Simple->new;
	print $q->redirect( $this_location );
	exit;
	} else {
	$dbh->disconnect;

	my $failure = "<html><body><h1>削除に失敗してしまいました。。。</h1></body></html>";
	$self->error_message( $failure );
	}
	}
	}

	sub register {
	my ( $self, $q ) = @_;

	my $ip = $q->remote_addr();
	my $hostname = $self->get_host_by_addr( $ip );

	# sanitizing query parameters.
	my ( $comment, $delete_key ) = $self->sanitize( $q );

	# get an uploaded file.
	my ( $tag, $file_size, $upload_path ) = $self->upload_process( $q );

	my $file_name = '';
	$file_name = $1 if $upload_path =~ /\/([a-zA-Z0-9]+\.[a-zA-Z0-9]+)$/;

	my $date = $self->get_date; # get date.

	# encode in UTF-8
	# $comment = encode( 'utf8', $comment );

	my $dbh = $self->connect_sql;

	my $req = qq\| INSERT INTO t_upfile_list \|;
	$req .= qq\| ( file_name, comment, date, delete_key, tag, file_size, path ) \|;
	$req .= qq\| VALUES( ?, ?, ?, ?, ?, ?, ? ) \|;

	my $sth = $dbh->prepare( $req );
	$sth->execute( $file_name, $comment, $date, $delete_key,
	$tag, $file_size, $upload_path );

	$dbh->disconnect;

	return 0;
	}

	sub get_date {
	my $self = shift;

	use Time::Piece;
	my $t = localtime;
	my $date = $t->strftime( '%FT%T' );

	return $date;
	}

	sub connect_sql {
	my $self = shift;

	my $db_file = $self->absolute_root_path . '/' . $self->db_file;


	my $dbh = DBI->connect( "dbi:SQLite:dbname=$db_file", "", "",
	{
	RaiseError => 1,
	sqlite_unicode => 1,
	}
	);

	return $dbh;
	}

	sub get_host_by_addr {
	my ( $self, $ip ) = @_;

	my @addr = split(/\./, $ip);
	my $packed_ip = pack("C4", $addr[0], $addr[1], $addr[2], $addr[3]);
	my $hostname = gethostbyaddr($packed_ip, 2);

	return $hostname;
	}

	sub upload_process {
	my ( $self, $q ) = @_;

	my $up_file = $q->param( 'upload_file' );
	my $mime = $q->upload_info( $up_file, 'mime' );
	my $file_size = $q->upload_info( $up_file, 'size' );

	my $extension = '';
	$extension = $1 if $up_file =~ /.+\.([a-zA-Z0-9-]+)$/;

	my $tag = '';
	if ( $mime =~ /^image\/((gif\|jpeg\|jpg\|png))$/ ) {
	$extension = $1 if $extension eq '';
	$tag = 'image';
	} elsif ( $mime =~ /^audio\/((mp3\|x-mp3\|mpg\|x-mpg\|mpeg\|x-mpeg\|wav\|x-wav))$/ ) {
	$extension = $1 if $extension eq '';
	$extension =~ s/^x-//;
	$tag = 'audio';
	} elsif ( $mime =~ /^video\/((mpg\|mpeg\|mp4\|flv\|x-flv))$/ ) {
	$extension = $1 if $extension eq '';
	$extension =~ s/^x-//;
	$tag = 'video';
	} else {
	my $caution = "<html><body><h1>このファイル形式は受け付けていません: $mime</h1></body></html>";
	$self->error_message( $caution );
	}

	my $unix_time = time();
	my $uploaded_file_name = $unix_time . '.' . $extension;
	my $save_path = $self->upload_dir . '/' . $tag . '/' . $uploaded_file_name;

	# convert this relational path into the absolute path
	# for mod_perl.
	my $absolute_save_path = '';
	$absolute_save_path = $1 if $save_path =~ /^\.(.+)$/;
	$absolute_save_path = $self->absolute_root_path . $absolute_save_path;

	my $ok = $q->upload( $up_file, $absolute_save_path );
	if ( $ok ) {
	return ( $tag, $file_size, $save_path );
	} else {
	my $failure = "<html><body><h1>アップロードに失敗したようです</h1></body></html>";
	$self->error_message( $failure );
	}
	}

	sub sanitize {
	my ( $self, $q ) = @_;

	my %params = $q->Vars; # get query parameters.

	foreach ( %params ) {
	my $value = $q->escapeHTML( $params{$_} );
	$value =~ s/'/'/g;
	$params{$_} = decode( 'utf8', $value );
	}

	my $comment = $params{ comment };
	my $delete_key = $params{ delete_key };

	if ( $delete_key ne '' ) {
	my $no_multibyte = "<html><body><h1>削除キーは半角英数字だけ OK です</h1></body></html>";
	$self->error_message( $no_multibyte )
	unless $delete_key =~ /^[a-zA-Z0-9]+$/;
	}

	return ( $comment, $delete_key );
	}

	sub output {
	my ( $self, $q ) = @_;

	my $page = 1;
	$page = $q->param( 'page' ) if $q->param( 'page' ) ne '';

	my $paging_html = $self->paging_html( $page );

	my @hash_refs = $self->make_list( $page );

	my $size_sum = $self->get_sum;
	my $limit_ok = 1;
	$limit_ok = 0 if $size_sum > $self->max_total_size;

	my $max_post_size = $self->nice_size( $self->max_post_size );
	my $max_total_size = $self->nice_size( $self->max_total_size );
	$size_sum = $self->nice_size( $size_sum );

	my $limitation_html = "最大 " . $max_post_size . " のファイルが";
	$limitation_html .= "アップロード可能です。<br>";
	$limitation_html .= "mpeg, mp4, flv, mp3, wav, jpg, png, gif のみ受け付けています。<br>";
	$limitation_html .= "合計 " . $max_total_size . " に達した時点で";
	$limitation_html .= "アップロード不可になる予定です。<br>";
	$limitation_html .= "現在、" . $size_sum . " 使用してしています。<br>";
	$limitation_html .= "投稿削除後変化がなければ、RELOAD ボタンを押してください。<br>";
	$limitation_html .= "β 版なので文字化けなど不具合があるかもです。";

	$limitation_html = "<span style='font: bold 1.5em sans-serif;'>もうお腹一杯です。。。</span>"
	if $limit_ok == 0;

	my $rss_file = $self->rss_file;
	$rss_file =~ s/^\.\///;
	my $rss_location = $self->base_uri . $rss_file;
	my $top_nav = qq\| <a href="$rss_location">RSS</a> \|;


	my $cache_dir = $self->absolute_root_path . '/.xslate_cache';
	my $tx = Text::Xslate->new( path => $self->absolute_root_path,
	cache_dir => $cache_dir, );


	my %vars = ( base => $self->base_uri,
	rss => $rss_location,
	cgi_name => $self->this_cgi_name,
	top_nav => mark_raw( $top_nav ),
	paging => mark_raw( $paging_html ),
	limit_ok => $limit_ok,
	limitation => mark_raw( $limitation_html ),
	title => $self->html_title,
	up_list => \@hash_refs, );


	my $tt_file = $self->template_file;
	my $content = $tx->render( $tt_file, \%vars );

	print "Content-Type: text/html; charset=UTF-8\n\n";
	print $content;
	}

	sub nice_size {
	my ( $self, $file_size ) = @_;

	my $fs;
	if ( $file_size < 1024 ) {
	$fs = $file_size . ' Bytes';
	} elsif ( $file_size < 1024 ** 2 ) {
	$fs = int( $file_size / 1024 ) . ' KB';
	} elsif ( $file_size < 1024 ** 3 ) {
	$fs = int( $file_size / ( 1024 ** 2 ) ) . ' MB';
	} elsif ( $file_size < 1024 ** 4 ) {
	$fs = int( $file_size / ( 1024 ** 3 ) ) . ' GB';
	}

	return $fs;
	}


	sub commify {
	my ( $self, $num_str ) = @_;
	$num_str = reverse $num_str;
	$num_str =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
	return scalar reverse $num_str;
	}

	sub make_list {
	my ( $self, $page ) = @_;

	my $end = $page * $self->list_max;
	my $offset = $end - $self->list_max;
	my $limit = $self->list_max;

	# pull data from database.
	my $req = qq\| SELECT id, file_name, comment, date, file_size, path \|;
	$req .= qq\| FROM t_upfile_list ORDER BY id DESC \|;
	$req .= qq\| LIMIT ?, ? \|;

	my $dbh = $self->connect_sql;
	my $sth = $dbh->prepare( $req );
	$sth->execute( $offset, $limit );

	my @hash_refs = ();
	while ( my $arry_ref = $sth->fetchrow_arrayref ) {
	my ( $id, $file_name, $comment, $date, $file_size, $path ) = @$arry_ref;

	$file_size = $self->commify( $file_size );

	if ( $path eq '' ) {
	next;
	} else {

	my $hash_ref = { id => $id,
	file_name => $file_name,
	comment => $comment,
	date => $date,
	file_size => $file_size,
	path => $path, };

	push( @hash_refs, $hash_ref );
	}
	}

	$dbh->disconnect;

	return @hash_refs;
	}

	sub paging_html {
	my ( $self, $page ) = @_;

	# # get the last id.

	my $req = qq\| SELECT file_name FROM t_upfile_list \|;
	my $dbh = $self->connect_sql;
	my $sth = $dbh->prepare( $req );
	$sth->execute;

	my $row_num = 0;
	while ( my $arry_ref = $sth->fetchrow_arrayref ) {
	if ( $arry_ref ) {
	$row_num += 1;
	}
	}

	$dbh->disconnect;

	my $total_pages = int( ( $row_num - 1 ) / $self->list_max ) + 1;

	my $this_location = $self->base_uri . $self->this_cgi_name;
	my $paging_html;
	for ( my $i = 1; $i <= $total_pages; $i++ ) {
	if ( $i != $page ) {
	$paging_html .= qq\| <a href="$this_location?page=$i">$i</a>  \|;
	} else {
	$paging_html .= qq\| <span style="font-size: 1.25em;">$i</span>  \|;
	}
	}

	if ( ( $page * $self->list_max ) < $row_num ) {
	my $next_link = "$this_location?page=";
	$next_link .= $page + 1;
	$paging_html .= qq\| <a rel="next" href="$next_link">Next</a>  \|;
	}

	# # DEBUG
	# $paging_html .= $row_num;

	return $paging_html;
	}

	sub get_sum {
	my $self = shift;

	my $dbh = $self->connect_sql;

	my $req = "SELECT file_size FROM t_upfile_list";

	my $sth = $dbh->prepare( $req );
	$sth->execute;

	my $total_size = 0;
	while ( my $arry_ref = $sth->fetchrow_arrayref ) {
	my ( $byte ) = @$arry_ref;
	$total_size += $byte;
	}

	$dbh->disconnect;

	return $total_size;
	}

	sub save_as_rss {
	my $self = shift;

	my $this_location = $self->base_uri . $self->this_cgi_name;
	my $feed = XML::FeedPP::RSS->new ( title => $self->html_title,
	link => $this_location, );

	my $req = 'SELECT file_name, comment, tag, file_size, path FROM t_upfile_list ';
	$req .= 'ORDER BY id DESC LIMIT ' . $self->list_max;
	my $dbh = $self->connect_sql;
	my $sth = $dbh->prepare( $req );
	$sth->execute;

	while ( my $arry_ref = $sth->fetchrow_arrayref ) {
	my ( $file_name, $comment, $tag, $file_size, $path ) = @$arry_ref;

	$path =~ s/^\.\///;
	my $full_path = $self->base_uri . $path;

	my $type = $tag . '/';
	$type .= $1 if $file_name =~ /\.([a-zA-Z0-9]+)$/;
	$type =~ s/jpg/jpeg/i;

	my $item = $feed->add_item( $full_path );
	$item->title( $comment );
	my $enclosure = {
	'enclosure@url' => $full_path,
	'enclosure@length' => $file_size,
	'enclosure@type' => $type,
	};
	$item->set( %$enclosure );

	}

	my $rss_path = $self->absolute_root_path . '/' . $self->rss_file;

	$feed->to_file( $rss_path );
	}


	# -------------

	package main;

	my $base_uri = '';
	my $absolute_root_path = '';
	my $this_cgi_name = 'pie.cgi';
	my $master_key = '';
	my $template_file = 'upie.tx';
	my $rss_file = 'upie.rss';
	my $upload_dir = './up';
	my $db_file = '';
	my $title = '';

	my $upie = CGI::Upie->new( base_uri => $base_uri,
	absolute_root_path => $absolute_root_path,
	this_cgi_name => $this_cgi_name,
	master_key => $master_key,
	template_file => $template_file,
	rss_file => $rss_file,
	upload_dir => $upload_dir,
	db_file => $db_file,
	html_title => $title, );

	$upie->run;

	# last modified: 2011-12-30 19:16+09:00.