Loading...   


#!/usr/bin/perl

use DBI;
use DBD::mysql;
# CONFIG VARIABLES
my $confile = "eqemu_config.xml"; #default
open(F, "<$confile") or die "Unable to open config: $confile\n";
my $indb = 0;
while(<F>) {
	s/\r//g;
	if(/<database>/i) { $indb = 1; }
	next unless($indb == 1);
	if(/<\/database>/i) { $indb = 0; last; }
	if(/<host>(.*)<\/host>/i) { $host = $1; } 
	elsif(/<username>(.*)<\/username>/i) { $user = $1; } 
	elsif(/<password>(.*)<\/password>/i) { $pass = $1; } 
	elsif(/<db>(.*)<\/db>/i) { $db = $1; }
}
# DATA SOURCE NAME
$dsn = "dbi:mysql:$db:localhost:3306";
# PERL DBI CONNECT
if(!$connect){ $connect = DBI->connect($dsn, $user, $pass); }
if(!$connect2){ $connect2 = DBI->connect($dsn, $user, $pass); }

#use HTML::TagParser;
#use URI::Fetch;

$query_handle = $connect->prepare("SELECT `short_name`, `long_name`, `zoneidnumber` FROM `zone` ORDER BY `zoneidnumber`;"); $query_handle->execute();
while (@row = $query_handle->fetchrow_array()){
	($SN, $LN, $ZID) = ($row[0], $row[1], $row[2]);
	my $url  = 'http://eq.magelo.com/zone/' . $row[2]; 
	my $html = HTML::TagParser->new( $url ); # Get web page HTML
	if($html != 0){
		$PageTitle = undef;
		@NPCDATA = undef;
		#Get Page Title String
		my @list = $html->getElementsByTagName( "title" );
		foreach my $elem ( @list ) { $PageTitle = $elem->innerText;	}
		### Get NPC List from Zone
		### Define Text Table Headers (For script readability)
		use Text::ASCIITable;
		$t = Text::ASCIITable->new({ headingText => 'NPC List: ' . $PageTitle });
		$t->setCols('Magelo NPC ID','NPC Name','NPC Description', 'Min Level', 'Max Level');
		### Pull apart the javascript used NPC Data
		my @list = $html->getElementsByTagName( "script" );
		foreach my $elem ( @list ) {
			my $tagname = $elem->tagName;
			my $attr = $elem->attributes;
			my $text = $elem->innerText;
			if($text=~/var data=\(function()/i){
				$text =~ s/{var data=\(function\(\){return\[//; ### Strip Garbage from the beginning of the data set
				$String = quotemeta("]]];})();var columns=new JSTableColumn");
				$text =~ s/$String//; ### Strip Garbage from the beginning of the data set
				@Data = split(/\]\],\[/, $text); $n = 0;
				foreach $line (@Data){
					if($line=~/var columns/i){}else{
						$MaxLevel = 0;
						$line =~ s|"||g; $line =~ s|\[||g;
						@NPCLine = split(/,/, $line);
						($NPCID, $NPCNAME, $NPCDESC, $MinLevel, $MaxLevel) = ($NPCLine[0], $NPCLine[1], $NPCLine[2], $NPCLine[3], $NPCLine[4]);
						### Hackish way to tell if javascript garbage is on the last line
						if(length($NPCLine[4]) > 2){  $MaxLevel = substr($NPCLine[4], 0, 2);  $MaxLevel =~ s|]||g; } else{ $MaxLevel = $NPCLine[4]; }
						### Stuff Data to Table for script display
						$t->addRow([$NPCID, $NPCNAME, $NPCDESC, $MinLevel, $MaxLevel]);
						@NPCDATA[$n] = [@NPCLine];
						$n++;
					}
				}
				print $t;
			}
		}
	}
	### Start digging inside NPC Pages based on what was observed from the zone
	print "\n Let's find out what the NPC's have to say!\n";
	
	$n=0;
	while (@NPCDATA[$n]){
		print "Analyzing NPC: '" . $NPCDATA[$n][1] . "'\n";
		my $url  = 'http://eq.magelo.com/npc/' . $NPCDATA[$n][0]; 
		my $html = HTML::TagParser->new( $url ); # Get web page HTML
		### Parse the NPC Loot Tab using the Javascript that populates the data towards the bottom of the page
		my @list = $html->getElementsByTagName( "script" );
		foreach my $elem ( @list ) {
			my $tagname = $elem->tagName;
			my $attr = $elem->attributes;
			my $text = $elem->innerText;
			if($text=~/{var data=\(function\(\){/i){
				$tn = Text::ASCIITable->new({ headingText => 'NPC: ' . $NPCDATA[$n][1] });
				$tn->setCols('Item ID','Item Name','Req. LVL', 'Type', 'Drop Rate', 'Drop Rate %');
				$String = quotemeta('var data=(function(){var _0=[0,"Platinum"];return[[');
				$text =~ s/$String//; ### Strip Garbage from the beginning of the data set
				$String = quotemeta('{var data=(function(){return[');
				$text =~ s/$String//; ### Strip Garbage from the beginning of the data set
				@Data = split(/\]\],\[/, $text); 
				$print = 0;
				foreach $line (@Data){
					if($line=~/var columns/i){}else{
						$MaxLevel = 0;
						$line =~ s|"||g; $line =~ s|\[||g;
						@ItemData = split(/,/, $line);
						($ItemID, $ItemIconURL, $ItemName, $ReqLevel, $Type, $Price, $MinLoot, $MaxLoot) = ($ItemData[0], $ItemData[1], $ItemData[2], $ItemData[3], $ItemData[4], $ItemData[5],  $ItemData[6],  $ItemData[7]);
						### Hackish way to tell if javascript garbage is on the last line
						### Stuff Data to Table for script display
						if($ItemID){
							$print = 1;
							if(int(($MinLoot / $MaxLoot) * 100) == 0){ $LootPercent = 1; } else { $LootPercent = int(($MinLoot / $MaxLoot) * 100); }
							$tn->addRow([$ItemID, $ItemName, $ReqLevel, $Type, $MinLoot . " of " . $MaxLoot, int(($MinLoot / $MaxLoot) * 100) . "%"]);
							  
							$query_handle2 = $connect2->prepare("INSERT INTO `magelo_npc_loot_parse` (`npc_name`, `zoneid`, `itemid`, `Type`, `drop_actual`, `drop_max`, `drop_rate`) VALUES (?, ?, ?, ?, ?, ?, ?);");
							$query_handle2->execute($NPCDATA[$n][1], $ZID, $ItemID, $Type, $MinLoot, $MaxLoot, $LootPercent);
						}
					}
				}
				if($print == 1){ print $tn; }
			}
		}
		### Parse the Magelo Tab using the Javascript that populates the data towards the bottom of the page
		if($html != 0){
			$tm = Text::ASCIITable->new({ headingText => 'Merchant List: ' . $NPCDATA[$n][1]});
			$tm->setCols('Merchant Name','Item ID','Item Name', 'Item Type');
			### Pull apart the javascript for Merchantlist data
			$mprint = 0;
			my @mlist = $html->getElementsByTagName( "script" );
			foreach my $elem ( @mlist ) {
				my $text = $elem->innerText;
				$Q = quotemeta("{var data=(function(){var _0=[0,\"Platinum\"];return[[");
				if($text=~/$Q/i){
					$Q = quotemeta("{var data=(function(){var _0=[0,\"Platinum\"];return["); $text =~ s/$Q//; ### Strip Garbage from the beginning of the data set
					@Data = split(/\],\[/, $text);
					foreach my $mline (@Data){
						$mline =~ s|"||g; $mline =~ s|\[||g;
						@MD = split(/,/, $mline); ### Merchant Data Array
						my ($ItemID, $ItemName, $ItemType) = ($MD[0], $MD[2], $MD[3]);
						if($MD[0]){
							$mprint = 1;
							$tm->addRow([$NPCDATA[$n][1], $ItemID, $ItemName, $ItemType]);
							
							### Dump Info into `Magelo_NPC_Merchantlist`
							$query_handle2 = $connect2->prepare("INSERT INTO `magelo_npc_merchantlist` (`npc_name`, `zoneid`, `itemid`, `item_name`, `item_type`) VALUES (?, ?, ?, ?, ?);");
							$query_handle2->execute($NPCDATA[$n][1], $ZID, $ItemID, $ItemName, $ItemType);
						}
					}
				}
			}
		}
		if($mprint == 1){ print $tm; }
		
		### Parse the Coordinates of the NPC Spawn points
		my $html = HTML::TagParser->new( $url ); # Get web page HTML
		if($html != 0){
			$PageTitle = undef;
			#Get Page Title String
			my @list = $html->getElementsByTagName( "title" );
			foreach my $elem ( @list ) { $PageTitle = $elem->innerText;	}
			$tm = Text::ASCIITable->new({ headingText => 'NPC Coordinates: ' . $PageTitle });
			$tm->setCols('NPC Name','X','Y');
			### Pull apart the javascript for Merchantlist data
			$cprint = 0;
			my @list = $html->getElementsByTagName( "script" );
			foreach my $elem ( @list ) {
				my $tagname = $elem->tagName;
				my $attr = $elem->attributes;
				my $text = $elem->innerText;
				$Q = quotemeta("var spawnList = new JSTableFilteredModel(new JSDefaultTableModel([");
				#print $text . "\n";
				if($text=~/$Q/i){
					$Q = quotemeta("var spawnList = new JSTableFilteredModel(new JSDefaultTableModel(["); $text =~ s/$Q//; ### Strip Garbage from the beginning of the data set
					@Data = split(/\] \] , \[ "eq:npc:/, $text);
					foreach $line (@Data){
						if($line=~/eq/i){}else{ ###Hack way to ignore some data I don't care about
							$line =~ s|"||g; $line =~ s|\[||g; $line =~ s|\]||g;
							@CID = split(/,/, $line); ### Merchant Data Array
							my ($X, $Y) = ($CID[1], $CID[2]);
							if($X && $Y){
								$cprint = 1;
								$tm->addRow([$NPCDATA[$n][1], $X, $Y]);
								
								### Dump Info into `Magelo_NPC_Map_Coords`
								$query_handle2 = $connect2->prepare("INSERT INTO `magelo_npc_map_coords` (`npc_name`, `zoneid`, `x`, `y`) VALUES (?, ?, ?, ?);");
								$query_handle2->execute($NPCDATA[$n][1], $ZID, $X, $Y);
							}
						}
					}
				}
			}
		}
		if($cprint == 1){ print $tm; }
		
		$n++;
	}
}
	
	

	
### Module Tag Parser - I had to rip it and reference it locally because it doesn't have proper error handling - Akkadius
	
package HTML::TagParser;
use strict;
use Symbol;
use Carp;

use vars qw( $VERSION );
$VERSION = "0.16.1";

my $J2E        = {qw( jis ISO-2022-JP sjis Shift_JIS euc EUC-JP ucs2 UCS2 )};
my $E2J        = { map { lc($_) } reverse %$J2E };
my $SEC_OF_DAY = 60 * 60 * 24;

#  [000]	'/' if closing tag.
#  [001]	tagName
#  [002]	attributes string (with trailing /, if self-closing tag).
#  [003]	content until next (nested) tag.
#  [004]	attributes hash cache.
#  [005]	innerText combined strings cache.
#  [006]	index of matching closing tag (or opening tag, if [000]=='/')
#  [007]	index of parent (aka container) tag.
# 
sub new {
    my $package = shift;
    my $src     = shift;
    my $self    = {};
    bless $self, $package;
    return $self unless defined $src;

    if ( $src =~ m#^https?://\w# ) {
        $self->fetch( $src, @_ );
    }
    elsif ( $src !~ m#[\<\>\|]# && -f $src ) {
        $self->open($src);
    }
    elsif ( $src =~ /<.*>/ ) {
        $self->parse($src);
    }

    $self;
}

sub fetch {
    my $self = shift;
    my $url  = shift;
    if ( !defined $URI::Fetch::VERSION ) {
        local $@;
        eval { require URI::Fetch; };
        Carp::croak "URI::Fetch is required: $url" if $@;
    }
    my $res = URI::Fetch->fetch( $url, @_ );
	if(!$res) { return 0; }
    Carp::croak "URI::Fetch failed: $url" unless ref $res;
	
    return if $res->is_error();
    $self->{modified} = $res->last_modified();
    my $text = $res->content();
    $self->parse( \$text );
}

sub open {
    my $self = shift;
    my $file = shift;
    my $text = HTML::TagParser::Util::read_text_file($file);
    return unless defined $text;
    my $epoch = ( time() - ( -M $file ) * $SEC_OF_DAY );
    $epoch -= $epoch % 60;
    $self->{modified} = $epoch;
    $self->parse( \$text );
}

sub parse {
    my $self   = shift;
    my $text   = shift;
    my $txtref = ref $text ? $text : \$text;

    my $charset = HTML::TagParser::Util::find_meta_charset($txtref);
    if ( !$charset && $$txtref =~ /[^\000-\177]/ ) {
        HTML::TagParser::Util::load_jcode();
        my ($jc) = Jcode::getcode($txtref) if $Jcode::VERSION;
        $charset = $J2E->{$jc} if $J2E->{$jc};
    }
    $self->{charset} ||= $charset;
    if ($charset) {
        HTML::TagParser::Util::encode_from_to( $txtref, $charset, "utf-8" );
    }
    my $flat = HTML::TagParser::Util::html_to_flat($txtref);
    Carp::croak "Null HTML document." unless scalar @$flat;
    $self->{flat} = $flat;
    scalar @$flat;
}

sub getElementsByTagName {
    my $self    = shift;
    my $tagname = lc(shift);

    my $flat = $self->{flat};
    my $out = [];
    for( my $i = 0 ; $i <= $#$flat ; $i++ ) {
        next if ( $flat->[$i]->[001] ne $tagname );
        next if $flat->[$i]->[000];                 # close
        my $elem = HTML::TagParser::Element->new( $flat, $i );
        return $elem unless wantarray;
        push( @$out, $elem );
    }
    return unless wantarray;
    @$out;
}

sub getElementsByAttribute {
    my $self = shift;
    my $key  = lc(shift);
    my $val  = shift;

    my $flat = $self->{flat};
    my $out  = [];
    for ( my $i = 0 ; $i <= $#$flat ; $i++ ) {
        next if $flat->[$i]->[000];    # close
        my $elem = HTML::TagParser::Element->new( $flat, $i );
        my $attr = $elem->attributes();
        next unless exists $attr->{$key};
        next if ( $attr->{$key} ne $val );
        return $elem unless wantarray;
        push( @$out, $elem );
    }
    return unless wantarray;
    @$out;
}

sub getElementsByClassName {
    my $self  = shift;
    my $class = shift;
    return $self->getElementsByAttribute( "class", $class );
}

sub getElementsByName {
    my $self = shift;
    my $name = shift;
    return $self->getElementsByAttribute( "name", $name );
}

sub getElementById {
    my $self = shift;
    my $id   = shift;
    return scalar $self->getElementsByAttribute( "id", $id );
}

sub modified {
    $_[0]->{modified};
}

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

package HTML::TagParser::Element;
use strict;

sub new {
    my $package = shift;
    my $self    = [@_];
    bless $self, $package;
    $self;
}

sub tagName {
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    return $flat->[$cur]->[001];
}

sub id {
    my $self = shift;
    $self->getAttribute("id");
}

sub getAttribute {
    my $self = shift;
    my $name = lc(shift);
    my $attr = $self->attributes();
    return unless exists $attr->{$name};
    $attr->{$name};
}

sub innerText {
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    my $elem = $flat->[$cur];
    return $elem->[005] if defined $elem->[005];    # cache
    return if $elem->[000];                         # </xxx>
    return if ( defined $elem->[002] && $elem->[002] =~ m#/$# ); # <xxx/>

    my $tagname = $elem->[001];
    my $closing = HTML::TagParser::Util::find_closing($flat, $cur);
    my $list    = [];
    for ( ; $cur < $closing ; $cur++ ) {
        push( @$list, $flat->[$cur]->[003] );
    }
    my $text = join( "", grep { $_ ne "" } @$list );
    $text =~ s/^\s+//s;
    $text =~ s/\s+$//s;
#   $text = "" if ( $cur == $#$flat );              # end of source
    $elem->[005] = HTML::TagParser::Util::xml_unescape( $text );
}

sub subTree
{
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    my $elem = $flat->[$cur];
    return if $elem->[000];                         # </xxx>
    my $closing = HTML::TagParser::Util::find_closing($flat, $cur);
    my $list    = [];
    while (++$cur < $closing) 
      {
        push @$list, $flat->[$cur];
      }

    # allow the getElement...() methods on the returned object.
    return bless { flat => $list }, 'HTML::TagParser';
}


sub nextSibling
{
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    my $elem = $flat->[$cur];

    return undef if $elem->[000];                         # </xxx>
    my $closing = HTML::TagParser::Util::find_closing($flat, $cur);
    my $next_s = $flat->[$closing+1];
    return undef unless $next_s;
    return undef if $next_s->[000];	# parent's </xxx>
    return HTML::TagParser::Element->new( $flat, $closing+1 );
}

sub firstChild
{
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    my $elem = $flat->[$cur];
    return undef if $elem->[000];                         # </xxx>
    my $closing = HTML::TagParser::Util::find_closing($flat, $cur);
    return undef if $closing <= $cur+1;			# no children here.
    return HTML::TagParser::Element->new( $flat, $cur+1 );
}

sub childNodes
{
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    my $child = firstChild($self);
    return [] unless $child;	# an empty array is easier for our callers than undef
    my @c = ( $child );
    while (defined ($child = nextSibling($child)))
      {
        push @c, $child;
      }
    return \@c;
}

sub lastChild
{
    my $c = childNodes(@_);
    return undef unless $c->[0];
    return $c->[-1];
}

sub previousSibling
{
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    
    ## This one is expensive. 
    ## We use find_closing() which walks forward. 
    ## We'd need a find_opening() which walks backwards.
    ## So we walk backwards one by one and consult find_closing()
    ## until we find $cur-1 or $cur.

    my $idx = $cur-1;
    while ($idx >= 0)
      {
        if ($flat->[$idx][000] && defined($flat->[$idx][006]))
	  {
	    $idx = $flat->[$idx][006];	# use cache for backwards skipping
	    next;
	  }

        my $closing = HTML::TagParser::Util::find_closing($flat, $idx);
	return HTML::TagParser::Element->new( $flat, $idx )
	  if defined $closing and ($closing == $cur || $closing == $cur-1);
	$idx--;
      }
    return undef;
}

sub parentNode
{
    my $self = shift;
    my ( $flat, $cur ) = @$self;

    return HTML::TagParser::Element->new( $flat, $flat->[$cur][007]) if $flat->[$cur][007];	# cache

    ##
    ## This one is very expensive. 
    ## We use previousSibling() to walk backwards, and
    ## previousSibling() is expensive.
    ##
    my $ps = $self;
    my $first = $self;

    while (defined($ps = previousSibling($ps))) { $first = $ps; }

    my $parent = $first->[1] - 1;
    return undef if $parent < 0;
    die "parent too short" if HTML::TagParser::Util::find_closing($flat, $parent) <= $cur;

    $flat->[$cur][007] = $parent;	# cache
    return HTML::TagParser::Element->new( $flat, $parent )
}

##
## feature: 
## self-closing tags have an additional attribute '/' => '/'.
##
sub attributes {
    my $self = shift;
    my ( $flat, $cur ) = @$self;
    my $elem = $flat->[$cur];
    return $elem->[004] if ref $elem->[004];    # cache
    return unless defined $elem->[002];
    my $attr = {};
    while ( $elem->[002] =~ m{
        ([^\s\=\"\']+)(\s*=\s*(?:(")(.*?)"|(')(.*?)'|([^'"\s=]+)['"]*))?
    }sgx ) {
        my $key  = $1;
        my $test = $2;
        my $val  = ( $3 ? $4 : ( $5 ? $6 : $7 ));
        my $lckey = lc($key);
        if ($test) {
            $key =~ tr/A-Z/a-z/;
            $val = HTML::TagParser::Util::xml_unescape( $val );
            $attr->{$lckey} = $val;
        }
        else {
            $attr->{$lckey} = $key;
        }
    }
    $elem->[004] = $attr;    # cache
    $attr;
}

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

package HTML::TagParser::Util;
use strict;

sub xml_unescape {
    my $str = shift;
    $str =~ s/&quot;/"/g;
    $str =~ s/&lt;/</g;
    $str =~ s/&gt;/>/g;
    $str =~ s/&amp;/&/g;
    $str;
}

sub read_text_file {
    my $file = shift;
    my $fh   = Symbol::gensym();
    open( $fh, $file ) or Carp::croak "$! - $file\n";
    local $/ = undef;
    my $text = <$fh>;
    close($fh);
    $text;
}

sub html_to_flat {
    my $txtref  = shift;    # reference
    my $flat = [];
    pos($$txtref) = undef;  # reset matching position
    while ( $$txtref =~ m{
        (?:[^<]*) < (?:
            ( / )? ( [^/!<>\s"'=]+ )
            ( (?:"[^"]*"|'[^']*'|[^"'<>])+ )?
        |   
            (!-- .*? -- | ![^\-] .*? )
        ) > ([^<]*)
    }sxg ) {
        #  [000]  $1  close
        #  [001]  $2  tagName
        #  [002]  $3  attributes
        #         $4  comment element
        #  [003]  $5  content
        next if defined $4;
        my $array = [ $1, $2, $3, $5 ];
        $array->[001] =~ tr/A-Z/a-z/;
        #  $array->[003] =~ s/^\s+//s;
        #  $array->[003] =~ s/\s+$//s;
        push( @$flat, $array );
    }
    $flat;
}

## returns 1 beyond the end, if not found.
## returns undef if called on a </xxx> closing tag
sub find_closing 
{
  my ($flat, $cur) = @_;

  return $flat->[$cur][006]        if   $flat->[$cur][006];	# cache
  return $flat->[$cur][006] = $cur if (($flat->[$cur][002]||'') =~ m{/$});    # self-closing

  my $name = $flat->[$cur][001];
  my $pre_nest = 0;	
  ## count how many levels deep this type of tag is nested.
  my $idx;
  for ($idx = 0; $idx <= $cur; $idx++)
    {
      my $e = $flat->[$idx];
      next unless   $e->[001] eq $name;
      next if     (($e->[002]||'') =~ m{/$});	# self-closing
      $pre_nest += ($e->[000]) ? -1 : 1;
      $pre_nest = 0 if $pre_nest < 0;
      $idx = $e->[006]-1 if !$e->[000] && $e->[006];	# use caches for skipping forward.
    }
  my $last_idx = $#$flat;

  ## we move last_idx closer, in case this container 
  ## has not all its subcontainers closed properly.
  my $post_nest = 0;
  for ($idx = $last_idx; $idx > $cur; $idx--)
    {
      my $e = $flat->[$idx];
      next unless    $e->[001] eq $name;
      $last_idx = $idx-1;		# remember where a matching tag was
      next if      (($e->[002]||'') =~ m{/$});	# self-closing
      $post_nest -= ($e->[000]) ? -1 : 1;
      $post_nest = 0 if $post_nest < 0;
      last if $pre_nest <= $post_nest;
      $idx = $e->[006]+1 if $e->[000] && defined $e->[006];	# use caches for skipping backwards.
    }
  
  my $nest = 1;		# we know it is not self-closing. start behind.

  for ($idx = $cur+1; $idx <= $last_idx; $idx++)
    {
      my $e = $flat->[$idx];
      next unless    $e->[001] eq $name;
      next if      (($e->[002]||'') =~ m{/$});	# self-closing
      $nest      += ($e->[000]) ? -1 : 1;
      if ($nest <= 0)
        {
	  die "assert </xxx>" unless $e->[000];
	  $e->[006] = $cur;	# point back to opening tag
	  return $flat->[$cur][006] = $idx;
	}
      $idx = $e->[006]-1 if !$e->[000] && $e->[006];	# use caches for skipping forward.
    } 

  # not all closed, but cannot go further
  return $flat->[$cur][006] = $last_idx+1;	
}

sub find_meta_charset {
    my $txtref = shift;    # reference
    while ( $$txtref =~ m{
        <meta \s ((?: [^>]+\s )? http-equiv=['"]?Content-Type [^>]+ ) >
    }sxgi ) {
        my $args = $1;
        return $1 if ( $args =~ m# charset=['"]?([^'"\s/]+) #sxgi );
    }
    undef;
}

sub encode_from_to {
    my ( $txtref, $from, $to ) = @_;
    return     if ( $from     eq "" );
    return     if ( $to       eq "" );
    return $to if ( uc($from) eq uc($to) );
    &load_encode() if ( $] > 5.008 );
    if ( defined $Encode::VERSION ) {
        # 2006/11/01 FB_XMLCREF -> XMLCREF see [Jcode5 802]
        Encode::from_to( $$txtref, $from, $to, Encode::XMLCREF() );
    }
    elsif ( (  uc($from) eq "ISO-8859-1"
            || uc($from) eq "US-ASCII"
            || uc($from) eq "LATIN-1" ) && uc($to) eq "UTF-8" ) {
        &latin1_to_utf8($txtref);
    }
    else {
        my $jfrom = &get_jcode_name($from);
        my $jto   = &get_jcode_name($to);
        return $to if ( uc($jfrom) eq uc($jto) );
        if ( $jfrom && $jto ) {
            &load_jcode();
            if ( defined $Jcode::VERSION ) {
                Jcode::convert( $txtref, $jto, $jfrom );
            }
            else {
                Carp::croak "Jcode.pm is required: $from to $to";
            }
        }
        else {
            Carp::croak "Encode.pm is required: $from to $to";
        }
    }
    $to;
}

sub latin1_to_utf8 {
    my $txtref = shift;
    $$txtref =~ s{
        ([\x80-\xFF])
    }{
        pack( "C2" => 0xC0|(ord($1)>>6),0x80|(ord($1)&0x3F) )
    }exg;
}

sub load_jcode {
    return if defined $Jcode::VERSION;
    local $@;
    eval { require Jcode; };
}

sub load_encode {
    return if defined $Encode::VERSION;
    local $@;
    eval { require Encode; };
}

sub get_jcode_name {
    my $src = shift;
    my $dst;
    if ( $src =~ /^utf-?8$/i ) {
        $dst = "utf8";
    }
    elsif ( $src =~ /^euc.*jp$/i ) {
        $dst = "euc";
    }
    elsif ( $src =~ /^(shift.*jis|cp932|windows-31j)$/i ) {
        $dst = "sjis";
    }
    elsif ( $src =~ /^iso-2022-jp/ ) {
        $dst = "jis";
    }
    $dst;
}

# ----------------------------------------------------------------
1;
# ----------------------------------------------------------------

	
	

Raw Paste Data