1# You may distribute under the terms of either the GNU General Public License 2# or the Artistic License (the same terms as Perl itself) 3# 4# (C) Paul Evans, 2011-2017 -- leonerd@leonerd.org.uk 5 6package Tickit::Pen 0.72; 7 8use v5.14; 9use warnings; 10 11use Carp; 12 13our @ALL_ATTRS = qw( fg bg b u i rv strike af blink ); 14 15our @BOOL_ATTRS = qw( b u i rv strike blink ); 16our @INT_ATTRS = qw( fg bg af ); 17 18# Load the XS code 19require Tickit; 20 21=head1 NAME 22 23C<Tickit::Pen> - store a collection of rendering attributes 24 25=head1 DESCRIPTION 26 27A pen instance stores a collection of rendering attributes for text to 28display. It comes in two forms, mutable and immutable. Both types of pen are 29subclasses of the base C<Tickit::Pen> class. 30 31An immutable pen is an instance of C<Tickit::Pen::Immutable>. Its attributes 32are set by the constructor and are fixed thereafter. Methods are provided to 33query the presence or value of attributes, and to fetch the entire set as a 34hash. 35 36A mutable pen is an instance of C<Tickit::Pen::Mutable>. Its attributes may be 37set by the constructor, and can be changed at any time. As well as supporting 38the same query methods as immutable pens, more methods are provided to change 39or remove them. 40 41While mutable pens may initially seem more useful, they can complicate logic 42due to their shared referential nature. If the same mutable pen is shared 43across multiple places, care needs to be taken to redraw anything that depends 44on it if it is ever changed. If pens need sharing, especially if results are 45cached for performance, consider using immutable pens to simplify the logic. 46 47=head2 Attributes 48 49The following named pen attributes are supported: 50 51=over 8 52 53=item fg => COL 54 55=item bg => COL 56 57Foreground or background colour. C<COL> may be an integer or one of the eight 58colour names. A colour name may optionally be prefixed by C<hi-> for the 59high-intensity version (may not be supported by all terminals). Some terminals 60may support a palette of 256 colours instead, some 16, and some only 8. The 61pen object will not check this as it cannot be reliably detected in all cases. 62 63=item fg:rgb8 => STRING 64 65=item bg:rgb8 => STRING 66 67Foreground or background colour secondary RGB8 specification. The value is a 68string encoding the three 8-bit values in hexadecimal notation, prefixed by a 69hash (C<#>) symbol; for example 70 71 #13579B 72 73On input, either lower- or upper-case is accepted; on output the letters will 74be upper-case. 75 76These attribute can only be set if the corresponding regular index attribute 77is also set. Changing or clearing the regular index will also clear the RGB8 78version. 79 80Applications wishing to use this attribute should be aware that the majority 81of terminal drivers will not be able to support it, and so should make sure to 82set an appropriate regular colour index as well. Some terminals using the 83F<xterm> driver may make use of it, however, and therefore ignore the index 84version. 85 86=item b => BOOL 87 88=item u => BOOL 89 90=item i => BOOL 91 92=item rv => BOOL 93 94=item strike => BOOL 95 96=item blink => BOOL 97 98Bold, underline, italics, reverse video, strikethrough, blink. 99 100=item af => INT 101 102Alternate font. 103 104=back 105 106Note that not all terminals can render the italics, strikethrough, or 107alternate font attributes. 108 109=cut 110 111=head1 CONSTRUCTORS 112 113=cut 114 115=head2 new 116 117 $pen = Tickit::Pen->new( %attrs ) 118 119Returns a new pen, initialised from the given attributes. 120 121Currently this method returns a C<Tickit::Pen::Mutable>, though this may 122change in a future version. It is provided for backward-compatibility for code 123that expects to be able to construct a C<Tickit::Pen> directly. 124 125 $pen = Tickit::Pen::Immutable->new( %attrs ) 126 127 $pen = Tickit::Pen::Mutable->new( %attrs ) 128 129Return a new immutable, or mutable pen, initialised from the given attributes. 130 131=cut 132 133sub new 134{ 135 my $class = shift; 136 my %attrs = @_; 137 138 # Default to mutable for now 139 $class = "Tickit::Pen::Mutable" if $class eq __PACKAGE__; 140 141 my $self = $class->_new( \%attrs ); 142 croak "Unrecognised pen attributes " . join( ", ", sort keys %attrs ) if %attrs; 143 return $self; 144} 145 146=head2 new_from_attrs 147 148 $pen = Tickit::Pen->new_from_attrs( $attrs ) 149 150Returns a new pen, initialised from keys in the given HASH reference. Used 151keys are deleted from the hash. 152 153Currently this method returns a C<Tickit::Pen::Mutable>, though this may 154change in a future version. It is provided for backward-compatibility for code 155that expects to be able to construct a C<Tickit::Pen> directly. 156 157 $pen = Tickit::Pen::Immutable->new_from_attrs( $attrs ) 158 159 $pen = Tickit::Pen::Mutable->new_from_attrs( $attrs ) 160 161Return a new immutable, or mutable pen, initialised from the given attributes. 162 163=cut 164 165sub new_from_attrs 166{ 167 my $class = shift; 168 my ( $attrs ) = @_; 169 170 # Default to mutable for now 171 $class = "Tickit::Pen::Mutable" if $class eq __PACKAGE__; 172 173 return $class->_new( $attrs ); 174} 175 176=head2 as_mutable 177 178=head2 clone 179 180 $pen = $orig->as_mutable 181 182 $pen = $orig->clone 183 184Returns a new mutable pen, initialised by copying the attributes of the 185original. 186 187C<clone> is provided as a legacy alias, but may be removed in a future 188version. 189 190=cut 191 192sub as_mutable 193{ 194 my $orig = shift; 195 return Tickit::Pen::Mutable->new_from_attrs( { $orig->getattrs } ); 196} 197*clone = \&as_mutable; 198 199=head2 as_immutable 200 201 $pen = $orig->as_immutable 202 203Returns an immutable pen, initialised by copying the attributes of the 204original. When called on an immutable pen, this method just returns the same 205pen instance. 206 207=cut 208 209sub as_immutable 210{ 211 my $orig = shift; 212 return Tickit::Pen::Immutable->new_from_attrs( { $orig->getattrs } ); 213} 214 215=head2 mutable 216 217 $is_mutable = $pen->mutable 218 219Returns true on mutable pens and false on immutable ones. 220 221=cut 222 223=head1 METHODS ON ALL PENS 224 225The following query methods apply to both immutable and mutable pens. 226 227=cut 228 229=head2 hasattr 230 231 $exists = $pen->hasattr( $attr ) 232 233Returns true if the given attribute exists on this object 234 235=cut 236 237=head2 getattr 238 239 $value = $pen->getattr( $attr ) 240 241Returns the current value of the given attribute 242 243=cut 244 245=head2 getattrs 246 247 %values = $pen->getattrs 248 249Returns a key/value list of all the attributes 250 251=cut 252 253=head2 equiv_attr 254 255 $equiv = $pen->equiv_attr( $other, $attr ) 256 257Returns true if the two pens have the equivalent values for the given 258attribute; that is, either both define it to the same value, or neither 259defines it. 260 261=cut 262 263=head2 equiv 264 265 $equiv = $pen->equiv( $other ) 266 267Returns true if the two pens have equivalent values for all attributes. 268 269=cut 270 271=head1 METHODS ON MUTABLE PENS 272 273The following mutation methods exist on mutable pens. 274 275=cut 276 277=head2 chattr 278 279 $pen->chattr( $attr, $value ) 280 281Change the value of an attribute. Setting C<undef> deletes the attribute 282entirely. See also C<delattr>. 283 284=cut 285 286=head2 chattrs 287 288 $pen->chattrs( \%attrs ) 289 290Change the values of all the attributes given in the hash. Recgonised 291attributes will be deleted from the hash. 292 293=cut 294 295=head2 delattr 296 297 $pen->delattr( $attr ) 298 299Delete an attribute from this pen. This attribute will no longer be modified 300by this pen. 301 302=cut 303 304=head2 copy_from 305 306=head2 default_from 307 308 $pen->copy_from( $other ) 309 310 $pen->default_from( $other ) 311 312Copy attributes from the given pen. C<copy_from> will override attributes 313already defined by C<$pen>; C<default_from> will only copy attributes that are 314not yet defined by C<$pen>. 315 316As a convenience both methods return C<$pen>. 317 318=cut 319 320sub copy_from 321{ 322 my $self = shift; 323 my ( $other ) = @_; 324 $self->copy( $other, 1 ); 325 return $self; 326} 327 328sub default_from 329{ 330 my $self = shift; 331 my ( $other ) = @_; 332 $self->copy( $other, 0 ); 333 return $self; 334} 335 336sub sprintf 337{ 338 my $self = shift; 339 340 return "{" . join( ",", map { 341 $self->hasattr($_) ? "$_=" . $self->getattr($_) : () 342 } @ALL_ATTRS ) . "}"; 343} 344 345use overload 346 '""' => sub { 347 my $self = shift; 348 return ref($self) . $self->sprintf 349 }, 350 bool => sub { 1 }; 351 352use Scalar::Util qw( refaddr ); 353use overload '==' => sub { refaddr($_[0]) == refaddr($_[1]) }; 354 355package Tickit::Pen::Immutable 0.72; 356use base qw( Tickit::Pen ); 357use constant mutable => 0; 358 359sub as_immutable { return $_[0] } 360 361package Tickit::Pen::Mutable 0.72; 362use base qw( Tickit::Pen ); 363use constant mutable => 1; 364 365# Adds further methods in XS 366 367=head1 AUTHOR 368 369Paul Evans <leonerd@leonerd.org.uk> 370 371=cut 372 3730x55AA; 374