RTF-HTMLConverter
view release on metacpan or search on metacpan
HTMLConverter.pm view on Meta::CPAN
}
sub hex_mode {
my $self = shift;
return $self->{hex_mode} unless @_;
$self->{hex_char} = '';
my $old = $self->{hex_mode};
$self->{hex_mode} = $_[0] ? 1 : 0;
return $old;
}
sub raw_mode {
my $self = shift;
return $self->{raw_mode} unless @_;
my $old = $self->{raw_mode};
$self->{raw_mode} = $_[0] ? 1 : 0;
return $old;
}
sub _current_stack {
my ($self, $name, $el) = @_;
return $self->{$name}[0] unless $el;
unshift @{$self->{$name}}, $el;
return $el;
}
sub current_buffer { shift()->_current_stack('buffers', @_) }
sub current_table { shift()->_current_stack('tables', @_) }
sub _set_new_stack {
my ($self, $class, $name) = splice(@_, 0, 3);
my $buf = $class->new(@_);
return unless $buf;
unshift @{$self->{$name}}, $buf;
return $buf;
}
sub set_new_buffer { $_[0]->_set_new_stack($_[0]->get_buffer_class(), 'buffers', $_[0]) }
sub set_new_table { $_[0]->_set_new_stack($_[0]->get_table_buf_class(), 'tables', $_[0]) }
sub remove_buffer {
my ($self, $buf) = @_;
return unless $buf;
@{$self->{buffers}} = grep { $_ != $buf } @{$self->{buffers}};
}
sub set_new_group_buffer {
my $self = shift;
my $buf = $self->set_new_buffer();
$self->add_on_leave_handler('remove_buffer', [$buf]);
return $buf;
}
sub get_parsed_group_text {
my $self = shift;
my $buf = $self->set_new_group_buffer();
$self->parse();
return $buf->get_text();
}
sub get_parsed_group_pcdata { $_[0]->set_pcdata_mode(); $_[0]->get_parsed_group_text() }
sub set_group_cwhandler {
my ($self, $prefix) = @_;
my @oldvalues;
$oldvalues[0] = $self->set_token_handler(CWORD, 'pth_cword');
$oldvalues[1] = $self->{cword_prefix};
$self->{cword_prefix} = $prefix;
$self->add_on_leave_handler('_restore_cwhandler', \@oldvalues);
}
sub _restore_cwhandler {
$_[0]->set_token_handler(CWORD, $_[1]);
$_[0]->{cword_prefix} = $_[2];
}
sub set_group_orig_cword_handler {
my ($self, $handler) = @_;
my $oldh = $self->{orig_cword_handler};
$self->{orig_cword_handler} = $handler;
$self->add_on_leave_handler(sub { $_[0]->{orig_cword_handler} = $_[1] }, [$oldh]);
}
sub set_group_sink {
my ($self, $sink) = @_;
my $old_sink = $self->set_sink(ref($sink) eq 'SCALAR' ? sub { $$sink .= $_[1] } : $sink);
$self->add_on_leave_handler(sub { $_[0]->set_sink($_[1]) }, [$old_sink]);
}
sub _encode_text {
my ($self, $text, $enc) = @_;
$enc ||= $self->_get_text_encoding();
return $enc eq 'utf8' ? $text : Encode::decode($enc, $text);
}
sub notes {
my $self = shift;
my $notes = $self->{notes};
if(@_ == 2){
my $old = $notes->{$_[0]};
$notes->{$_[0]} = $_[1];
return $old;
}
return $notes->{$_[0]};
}
sub del_note { delete $_[0]->{notes}{$_[1]} }
sub group_notes {
my ($self, $key, $value) = @_;
unless(exists $self->{notes}{$key}){
$self->notes($key => $value);
$self->_add_on_leave('on_leave2', sub { $_[0]->del_note($_[1]) }, [$key]);
return;
}
my $old = $self->notes($key => $value);
$self->_add_on_leave('on_leave2', sub { $_[0]->notes($_[1], $_[2]) }, [$key, $old]);
return $old;
}
sub store_notes {
my ($self, $arr) = splice(@_, 0, 2);
$self->add_on_leave_handler(sub { push @{$_[1]}, map { $_[0]->notes($_) } @{$_[2]} }, [$arr, [@_]]);
}
sub set_pcdata_mode { $_[0]->group_notes(pcdata => 1) }
sub _add_on_leave { unshift @{$_[0]->{$_[1]}[0]}, [$_[2], $_[3] || []] }
sub add_on_leave_handler { shift()->_add_on_leave('on_leave1', @_) }
sub add_sect_on_leave_handler {
my ($self, $sub, $args) = @_;
unshift @{$self->{sect_on_leave}}, [$sub, $args || []];
}
sub _do_on_leave {
my $self = shift;
for my $name (qw(on_leave1 on_leave2)){
my $on_leave = shift @{$self->{$name}};
next unless $on_leave && @$on_leave;
my $meth;
for my $rec (@$on_leave){
$meth = $rec->[0];
$self->$meth(@{$rec->[1]});
}
}
}
sub exec_program {
shift if ref($_[0]);
local $/;
my $dirname = shift;
my $pid = open(my $fh, '-|');
throw Error::Simple("Can't fork: $!!\n") unless defined $pid;
unless($pid){
throw Error::Simple("Can't dup STDERR: $!!\n") unless open(STDERR, ">&STDOUT");
if($dirname){
throw Error::Simple("Can't chdir to '$dirname': $!!\n") unless chdir $dirname;
}
no warnings 'syntax';
exec @_;
throw Error::Simple("Can't exec '".join(' ', @_)."': $!!\n");
}
my $output = <$fh>;
$fh->close();
return $output;
}
sub get_next_image_name {
my ($self, $extn) = @_;
$self->{image_count}++;
my $name = '';
if(ref($self->{image_names}) eq 'CODE'){
$name = $self->{image_names}($self->{image_count});
}else{
$name = sprintf($self->{image_names}, $self->{image_count});
}
$name .= ".$extn" if length $extn;
my $url = join('/', grep { length } ($self->{image_uri}, $name));
$name = File::Spec->catfile($self->{image_dir}, $name) if length $self->{image_dir};
return ($name, $url);
}
sub get_color_triplet {
my ($self, $num) = @_;
HTMLConverter.pm view on Meta::CPAN
sub cw_upr {
my $self = shift;
while(1) {
my $token = $self->get_token();
if(!$token || $self->is_stop_token($token)){
$self->unget_token($token);
last;
}
if($token->type() == ENTER){
my $h = $self->get_token_handler(ENTER);
$self->$h($token) if $h && $self->can($h);
$self->set_destination();
last;
}
}
}
sub cw_ud { } # By default this is destination word.
sub cw_u {
my ($self, $char) = @_;
$char = 65536 + $char if $char < 0;
$self->out(pack('U', $char), 'utf8');
my $uc = $self->notes('uc');
$uc = 1 unless defined $uc;
my $string = '';
while(length($string) < $uc){
my $token = $self->get_token(1);
my ($type, $text) = ($token->type(), $token->text());
if($type == PTEXT){
$string .= $text;
next;
}elsif($self->is_enter_token($token) || $self->is_leave_token($token) || $self->is_stop_token($token)){
$self->unget_token($token);
return;
}elsif($type == CWORD){
if($text eq 'bin'){
while(my $tk = $self->get_token()){
last if $tk->type() == ENBIN || $self->is_stop_token($tk);
}
}
}elsif($type == CSYMB){
if($text eq "'" && ($token = $self->get_token())){
unless($token->type() == ENHEX){
$self->unget_token($token);
}
}
}
$string .= ' '; # Count tokens
}
substr($string, 0, $uc) = '';
$self->out($string) if length $string;
}
sub cw_uc { $_[0]->group_notes(uc => $_[1]) }
###### Font Table
sub cw_fonttbl {
my $self = shift;
$self->set_pcdata_mode();
$self->set_new_group_buffer();
$self->set_group_cwhandler('fcw_');
$self->parse();
my $deff = $self->notes('deff');
if(length $deff){
my $font = $self->notes('f'.$deff);
return unless $font;
$self->notes(f => $font);
my $ff = $self->_get_font_family($font);
return unless $ff;
my $style = $self->get_style_element();
$self->append_text_node($style, " BODY { font-family: $ff; font-size: 10pt }\n", 1) if $style;
}
}
sub fcw_f {
my ($self, $num) = @_;
my $font = {};
$self->notes(f => $font);
$self->notes('f'.$num => $font);
my $txt = $self->get_parsed_group_pcdata();
$txt =~ s/;$//;
$font->{face} = $txt;
}
sub fcw_fnil { delete (($_[0]->notes('f') || {})->{family}) }
sub fcw_froman { ($_[0]->notes('f') || {})->{family} = 'serif' }
sub fcw_fswiss { ($_[0]->notes('f') || {})->{family} = 'sans-serif' }
sub fcw_fmodern { ($_[0]->notes('f') || {})->{family} = 'monospace' }
sub fcw_fscript { ($_[0]->notes('f') || {})->{family} = 'cursive' }
sub fcw_fdecor { ($_[0]->notes('f') || {})->{family} = 'fantasy' }
sub cw_deff {
my ($self, $num) = @_;
$self->notes(deff => $num);
my $font = $self->notes('f'.$num);
return unless $font;
$self->notes(f => $font);
}
{
my %charsets = (
0 => 'iso-8859-1', # ?? ANSI
1 => 'iso-8859-1', # ?? Default
2 => 'symbol', # Symbol
#3 => '??', # Invalid
#77 => '??', # Mac
128 => 'Shift_JIS', # Shift JIS
#129 => '??', # Hangul
130 => 'johab', # Johab
134 => 'euc-cn', # GB2312
136 => 'Big5', # Big5
161 => 'cp1253', # Greek
162 => 'cp1254', # Turkish
163 => 'cp1258', # Vietnamese
177 => 'cp1255', # Hebrew
178 => 'cp1256', # Arabic
#179 => '??', # Arabic Traditional
#180 => '??', # Arabic user
#181 => '??', # Hebrew user
186 => 'cp1257', # Baltic
204 => 'cp1251', # Russian
222 => 'cp874', # Thai
238 => 'cp1250', # Eastern European
254 => 'cp437', # PC 437
#255 => '??', # OEM
);
sub fcw_fcharset {
my ($self, $num) = @_;
my $font = $self->notes('f');
return unless $font;
$font->{codepage} = $charsets{$num};
}
}
sub fcw_falt {
my $self = shift;
my $font = $self->notes('f');
my $txt = $self->get_parsed_group_pcdata();
($font || {})->{falt} = $txt;
}
sub _get_text_encoding {
($_[0]->notes('pcdata') ? {} : $_[0]->notes('f') || {})->{codepage}
|| $_[0]->notes('ansicpg') || $_[0]->{doc_codepage}
}
sub _get_font_family { $_[1]->{family} }
###### Color Table
sub cw_colortbl {
my $self = shift;
$self->set_pcdata_mode();
$self->notes(colortbl => []);
$self->group_notes(colortbl_current => [(undef)x3]);
$self->set_group_token_handler(PTEXT, 'th_ptext_colortbl');
}
sub cw_red { ($_[0]->notes('colortbl_current') || [])->[0] = sprintf("%02x", $_[1]) }
sub cw_green { ($_[0]->notes('colortbl_current') || [])->[1] = sprintf("%02x", $_[1]) }
sub cw_blue { ($_[0]->notes('colortbl_current') || [])->[2] = sprintf("%02x", $_[1]) }
sub th_ptext_colortbl {
my ($self, $token) = @_;
my $text = $token->text();
return unless $text =~ /;/;
push @{$self->notes('colortbl')}, $self->notes('colortbl_current');
$self->notes(colortbl_current => [(undef)x3]);
}
###### Style Sheet
sub cw_stylesheet {
my $self = shift;
$self->set_pcdata_mode();
$self->set_new_group_buffer();
$self->set_group_cwhandler('scw_');
my $oldh = $self->set_group_token_handler(ENTER, 'th_enter_style');
$self->group_notes(stylesheet_enter => $oldh);
}
sub th_enter_style {
my $self = shift;
my $oldh = $self->notes('stylesheet_enter');
$self->$oldh();
my $style = { formatting => [] };
$self->notes(style => $style);
$self->notes(style_name => ['s', '0']) unless $self->notes('s0');
$self->set_group_orig_cword_handler('_style_format_collector');
$self->set_group_token_handler(ENTER, $oldh);
$self->parse();
my $stname = $self->notes('style_name');
return unless $stname;
$style->{type} = $stname->[0];
$self->notes($stname->[0].$stname->[1] => $style);
$self->del_note('style_name');
}
sub _style_format_collector {
my ($self, $word, $param) = @_;
my $style = $self->notes('style');
return unless $style;
$style->{formatting} = [] unless $style->{formatting};
push @{$style->{formatting}}, $self->get_token_class()->new(CWORD, $word, $param);
}
sub scw_cs { $_[0]->notes(style_name => ['cs', $_[1]]) }
sub scw_s { $_[0]->notes(style_name => ['s', $_[1]]) }
sub scw_ds { $_[0]->notes(style_name => ['ds', $_[1]]) }
sub scw_ts { $_[0]->notes(style_name => ['ts', $_[1]]) }
sub scw_additive { ($_[0]->notes('style') || {})->{additive} = 1 }
sub scw_sbasedon {
my ($self, $num) = @_;
return if $num == 222;
my $curstyle = $self->notes('style');
return unless $curstyle;
my $sn = $self->notes('style_name');
return unless $sn;
my $basestyle = $self->notes($sn->[0].$num);
return unless $basestyle;
unshift @{$curstyle->{formatting}}, @{$basestyle->{formatting} || []};
for my $key (keys %$basestyle){
next if exists $curstyle->{$key};
$curstyle->{$key} = $basestyle->{$key};
}
}
###### Table Styles
sub _ts_set_padding {
my ($self, $num, $val) = @_;
my $dim = $self->notes($val);
return unless defined($dim) && $dim == 3;
HTMLConverter.pm view on Meta::CPAN
sub cw_tscellpaddr { $_[0]->_ts_set_padding($_[1], 'tscellpaddfr') }
sub cw_tscellpaddb { $_[0]->_ts_set_padding($_[1], 'tscellpaddfb') }
sub cw_tscellpaddft { $_[0]->group_notes(tscellpaddft => $_[1]) }
sub cw_tscellpaddfl { $_[0]->group_notes(tscellpaddfl => $_[1]) }
sub cw_tscellpaddfr { $_[0]->group_notes(tscellpaddfr => $_[1]) }
sub cw_tscellpaddfb { $_[0]->group_notes(tscellpaddfb => $_[1]) }
sub cw_tsvertalt { $_[0]->_td_attr(valign => 'top' ) }
sub cw_tsvertalc { $_[0]->_td_attr(valign => 'center') }
sub cw_tsvertalb { $_[0]->_td_attr(valign => 'bottom') }
sub cw_tsnowrap { $_[0]->_td_style('white-space' => 'nowrap') }
sub cw_tscellcfpat { $_[0]->_td_cfpat($_[1], 'tscellpct') }
sub cw_tscellpct { $_[0]->_td_shdng($_[1], 'tscellpct') }
sub cw_tsbrdrt { $_[0]->_set_td_border_style('top') }
sub cw_tsbrdrb { $_[0]->_set_td_border_style('bottom') }
sub cw_tsbrdrl { $_[0]->_set_td_border_style('left') }
sub cw_tsbrdrr { $_[0]->_set_td_border_style('right') }
###### List Table
sub _get_current_list { $_[0]->notes($_[0]->notes('list_name') || 'list') }
sub cw_listtable {
my $self = shift;
$self->set_new_group_buffer();
$self->set_group_cwhandler('ltcw_');
$self->set_group_orig_cword_handler('_list_format_collector');
}
sub _list_format_collector {
my ($self, $word, $param) = @_;
my $list = $self->_get_current_list();
return unless $list && @{$list->{levels}};
$list->{levels}[-1]{formatting} ||= [];
push @{$list->{levels}[-1]{formatting}}, $self->get_token_class()->new(CWORD, $word, $param);
}
######## Top-Level List Properties
sub ltcw_list { $_[0]->group_notes(list => { levels => [] }) }
sub ltcw_listid {
my ($self, $num) = @_;
my $list = $self->notes('list');
return unless $list;
$list->{id} = $num;
$self->notes('list'.($num || 0) => $list);
}
sub ltcw_listtemplateid { ($_[0]->notes('list') || {})->{templateid} = $_[1] }
sub ltcw_listsimple { ($_[0]->notes('list') || {})->{simple} = $_[1] }
sub ltcw_listhybrid { ($_[0]->notes('list') || {})->{hybrid} = 1 }
sub ltcw_listname {
my $self = shift;
my $txt = $self->get_parsed_group_pcdata();
$txt =~ s/;$//;
($self->notes('list') || {})->{name} = $txt;
}
######## List Levels
sub ltcw_listlevel {
my $self = shift;
my $list = $self->_get_current_list();
unless($list){
$self->set_destination();
return;
}
push @{$list->{levels}}, {};
}
sub _set_list_level_prop {
my ($self, $name, $value) = @_;
my $list = $self->_get_current_list();
return unless $list && @{$list->{levels}};
$list->{levels}[-1]{$name} = $value;
}
sub ltcw_levelstartat { shift()->_set_list_level_prop('start', @_) }
{
my %list_numbering = (
0 => ['decimal', '1', 'ol'],
1 => ['upper-roman', 'I', 'ol'],
2 => ['lower-roman', 'i', 'ol'],
3 => ['upper-alpha', 'A', 'ol'],
4 => ['lower-alpha', 'a', 'ol'],
12 => ['katakana'],
13 => ['katakana-iroha'],
22 => ['decimal-leading-zero'],
23 => ['disk', 'disk'],
45 => ['hebrew'], ## ??
47 => ['hebrew'], ## ??
);
sub get_list_numbering { $list_numbering{$_[1]} }
sub add_list_numbering { $list_numbering{$_[1]} = $_[2] }
sub del_list_numbering { delete $list_numbering{$_[1]} }
}
sub ltcw_levelnfc { shift()->_set_list_level_prop('num', @_) }
sub ltcw_levelnfcn { shift()->ltcw_levelnfc(@_) }
sub ltcw_leveljc { shift()->_set_list_level_prop('align', { 0 => 'left', 1 => 'center', 2 => 'right' }->{$_[0]}) }
sub ltcw_leveljcn { shift()->ltcw_leveljc(@_) }
sub ltcw_leveltext { $_[0]->set_destination() }
sub ltcw_levelnumbers { $_[0]->set_destination() }
######## List Override Table
sub cw_listoverridetable {
my $self = shift;
$self->group_notes(list_name => 'listoverride');
$self->set_new_group_buffer();
$self->set_group_cwhandler('lotcw_');
$self->set_group_orig_cword_handler('_list_format_collector');
}
sub lotcw_listoverride { $_[0]->group_notes(listoverride => { levels => [] }) }
sub lotcw_listid { ($_[0]->notes('listoverride') || {})->{lid} = $_[1] }
sub lotcw_ls {
my ($self, $num) = @_;
my $lo = $self->notes('listoverride');
return unless $lo;
$lo->{id} = $num;
$self->notes('listoverride'.($num || 0) => $lo);
}
######## List Override Level
sub lotcw_lfolevel {
my $self = shift;
unless($self->_get_current_list()){
$self->set_destination();
return;
}
$self->set_group_cwhandler('ltcw_');
}
sub ltcw_listoverridestartat {
my $self = shift;
my $lo = $self->_get_current_list();
return unless $lo;
push @{$lo->{lists}}, {};
}
###### Paragraph Group Properties
#### Document Area
###### Information Group
sub cw_info { }
sub cw_title {
my $self = shift;
my $text = $self->get_parsed_group_pcdata();
my $head = $self->get_head_element();
return unless $head;
my $title = $self->create_element('title', $head);
$self->append_text_node($title, $text);
}
###### Document Formatting Properties
sub cw_private { $_[0]->set_destination() if $_[1] == 1 }
###### Section Text
sub cw_sect { $_[0]->flush_section() }
sub cw_sectd { $_[0]->get_sect_stack()->[0] = $_[0]->get_element_class()->new() }
######## Headers and Footers
###### Paragraph Text
######## Paragraph Formatting Properties
sub cw_par {
my $self = shift;
my ($ls, $ilvl) = map { $self->get_par()->notes($_) } qw(ls ilvl);
unless(defined $ls){
$self->current_buffer()->create_paragraph();
return;
}
my $buf = $self->current_buffer();
$buf->create_paragraph('li');
my $pl = $buf->get_paragraphs();
my ($ppar, $par) = @{$pl}[-3,-2];
$ilvl = 0 if $ilvl < 0;
my $listlevels = $self->notes('par_listlevels');
if($ppar && $listlevels && $listlevels->[0] == $ppar->data()){
splice @$listlevels, $ilvl+1 if $#$listlevels > $ilvl;
for (my $i = @$listlevels; $i<=$ilvl; $i++){
$self->_append_list_levels($listlevels, $ls, $i);
}
splice @$pl, @$pl-2, 1;
}else{
$listlevels = [];
$self->notes(par_listlevels => $listlevels);
for (my $i=0; $i<=$ilvl; $i++){
$self->_append_list_levels($listlevels, $ls, $i);
}
my $el = $self->get_element_class()->new();
$el->data($listlevels->[0]);
splice @$pl, @$pl-2, 1, $el;
}
$listlevels->[$ilvl]->appendChild($par->data());
}
sub _append_list_levels {
my ($self, $listlevels, $ls, $i) = @_;
my $start = $self->get_list_level_prop($ls, $i, 'start');
my $num = $self->get_list_level_prop($ls, $i, 'num');
my $lnum = $self->get_list_numbering($num) || [];
my $le = $self->get_document()->createElement($lnum->[2] || 'ul');
HTMLConverter.pm view on Meta::CPAN
unless(length($deff) && $num == $deff){
my $ff = $self->_get_font_family($font);
$self->char_tag_style('font', 'font-family' => $ff) if $ff;
}
}
sub cw_cf {
my ($self, $num) = @_;
my $color = $self->get_color_triplet($num);
return unless $color;
$self->char_tag_attr('font', color => $color);
}
sub cw_fs { $_[0]->char_tag_style('font', 'font-size' => (int($_[1]/2)+$_[1]%2).'pt') }
sub cw_i { shift()->_manage_tag('i', @_) }
sub cw_sub { $_[0]->open_char_tag('sub') }
sub cw_super { $_[0]->open_char_tag('sup') }
sub cw_ul { shift()->_manage_tag('u', @_) }
######## Special Characters
sub cw_line { $_[0]->append_tag('br') }
sub cw_lbr {
my ($self, $par) = @_;
my $el = $self->append_tag('br');
my $clear = $par == 3 ? 'all' :
$par == 2 ? 'right' :
$par == 1 ? 'left' : 0;
$el->setAttribute(clear => $clear) if $clear;
}
sub cw_tab { $_[0]->append_entity('nbsp') foreach 1..8 }
sub cw_emdash { $_[0]->append_entity('mdash') }
sub cw_endash { $_[0]->append_entity('ndash') }
sub cw_emspace { $_[0]->append_entity('emsp') }
sub cw_enspace { $_[0]->append_entity('ensp') }
sub cw_qmspace { $_[0]->append_entity('thinsp') }
sub cw_bullet { $_[0]->append_entity('bull') }
sub cw_lquote { $_[0]->append_entity('lsquo') }
sub cw_rquote { $_[0]->append_entity('rsquo') }
sub cw_ldblquote { $_[0]->append_entity('ldquo') }
sub cw_rdblquote { $_[0]->append_entity('rdquo') }
sub cw_zwj { $_[0]->append_entity('zwj') }
sub cw_zwnj { $_[0]->append_entity('zwnj') }
###### Bookmarks
sub _get_ancor_name {
my ($self, $txt) = @_;
$self->{ancor_count} = 0 unless defined $self->{ancor_count};
$self->{ancors} ||= {};
my $name = $self->{ancors}{$txt};
return $name if defined $name;
return $self->{ancors}{$txt} = 'a'.$self->{ancor_count}++;
}
sub cw_bkmkstart {
my $self = shift;
$self->set_pcdata_mode();
my $txt = $self->get_parsed_group_text();
my $name = $self->_get_ancor_name($txt);
my $el= $self->create_element('a');
$el->setAttribute(name => $name);
$self->append_text_node($el, ' ');
$self->append_element($el);
}
###### Pictures
sub cw_shppict { $_[0]->notes(shppict => -1) }
sub cw_nonshppict {
my $self = shift;
my $shppict = $self->notes(shppict => 0);
$self->set_destination() if $shppict > 0;
}
sub cw_pict {
my $self = shift;
if($self->{discard_images}){
$self->set_destination();
}else{
my $buf = $self->set_new_group_buffer();
$self->group_notes(pict_buf => $buf);
}
}
sub cw_picscalex { $_[0]->group_notes(picscalex => $_[1]) }
sub cw_picscaley { $_[0]->group_notes(picscaley => $_[1]) }
sub cw_picwgoal { $_[0]->group_notes(picwgoal => $_[1]) }
sub cw_pichgoal { $_[0]->group_notes(pichgoal => $_[1]) }
{
my %res_coeff = (i => 1, m => 0.0254, cm => 2.54);
sub _get_image_dim {
my ($self, $w, $h, $sx, $sy, $res) = @_;
my ($rx, $ry, $un);
my $scr = $self->{screen_resolution} || 100; # dpi
if($res =~ /(\d+)\s+dp(\w+)/){
$rx = $ry = $1;
$un = $res_coeff{$2};
}elsif($res =~ m|(\d+)\s+/\s+(\d+)\s+dp(\w+)|){
$rx = $1;
$ry = $2;
$un = $res_coeff{$3};
}elsif($res eq '1/1'){
$rx = $ry = $scr;
$un = 1;
}
return unless $rx && $ry && $un;
return ($scr/$un/$rx*$sx/100*$w, $scr/$un/$ry*$sy/100*$h);
}
}
sub _picblib {
my ($self, $ext) = @_;
my ($imgname, $imgurl) = $self->get_next_image_name($ext);
return unless open my $fh, '>', $imgname;
$self->set_group_sink($fh);
( run in 2.727 seconds using v1.01-cache-2.11-cpan-df04353d9ac )